core/classes/algebra/algebra.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel classes classes.private combinators accessors
   4 sequences arrays vectors assocs namespaces words sorting layouts
   5 math hashtables kernel.private sets math.order ;
   6 FROM: classes => members ;
   7 IN: classes.algebra
   8
   9 <PRIVATE
  10
  11 TUPLE: anonymous-union { members read-only } ;
  12
  13 : <anonymous-union> ( members -- class )
  14     [ null eq? not ] filter prune
  15     dup length 1 = [ first ] [ anonymous-union boa ] if ;
  16
  17 TUPLE: anonymous-intersection { participants read-only } ;
  18
  19 : <anonymous-intersection> ( participants -- class )
  20     prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
  21
  22 TUPLE: anonymous-complement { class read-only } ;
  23
  24 C: <anonymous-complement> anonymous-complement
  25
  26 DEFER: (class<=)
  27
  28 DEFER: (class-not)
  29
  30 GENERIC: (classes-intersect?) ( first second -- ? )
  31
  32 DEFER: (class-and)
  33
  34 DEFER: (class-or)
  35
  36 GENERIC: (flatten-class) ( class -- )
  37
  38 GENERIC: normalize-class ( class -- class' )
  39
  40 M: object normalize-class ;
  41
  42 PRIVATE>
  43
  44 GENERIC: classoid? ( obj -- ? )
  45
  46 M: word classoid? class? ;
  47 M: anonymous-union classoid? members>> [ classoid? ] all? ;
  48 M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
  49 M: anonymous-complement classoid? class>> classoid? ;
  50
  51 : class<= ( first second -- ? )
  52     class<=-cache get [ (class<=) ] 2cache ;
  53
  54 : class< ( first second -- ? )
  55     {
  56         { [ 2dup class<= not ] [ 2drop f ] }
  57         { [ 2dup swap class<= not ] [ 2drop t ] }
  58         [ [ rank-class ] bi@ < ]
  59     } cond ;
  60
  61 : class= ( first second -- ? )
  62     [ class<= ] [ swap class<= ] 2bi and ;
  63
  64 : class-not ( class -- complement )
  65     class-not-cache get [ (class-not) ] cache ;
  66
  67 : classes-intersect? ( first second -- ? )
  68     classes-intersect-cache get [
  69         normalize-class (classes-intersect?)
  70     ] 2cache ;
  71
  72 : class-and ( first second -- class )
  73     class-and-cache get [ (class-and) ] 2cache ;
  74
  75 : class-or ( first second -- class )
  76     class-or-cache get [ (class-or) ] 2cache ;
  77
  78 <PRIVATE
  79
  80 : superclass<= ( first second -- ? )
  81     swap superclass dup [ swap class<= ] [ 2drop f ] if ;
  82
  83 : left-anonymous-union<= ( first second -- ? )
  84     [ members>> ] dip [ class<= ] curry all? ;
  85
  86 : right-union<= ( first second -- ? )
  87     members [ class<= ] with any? ;
  88
  89 : right-anonymous-union<= ( first second -- ? )
  90     members>> [ class<= ] with any? ;
  91
  92 : left-anonymous-intersection<= ( first second -- ? )
  93     [ participants>> ] dip [ class<= ] curry any? ;
  94
  95 : right-anonymous-intersection<= ( first second -- ? )
  96     participants>> [ class<= ] with all? ;
  97
  98 : anonymous-complement<= ( first second -- ? )
  99     [ class>> ] bi@ swap class<= ;
 100
 101 : normalize-complement ( class -- class' )
 102     class>> normalize-class {
 103         { [ dup anonymous-union? ] [
 104             members>>
 105             [ class-not normalize-class ] map
 106             <anonymous-intersection>
 107         ] }
 108         { [ dup anonymous-intersection? ] [
 109             participants>>
 110             [ class-not normalize-class ] map
 111             <anonymous-union>
 112         ] }
 113         [ drop object ]
 114     } cond ;
 115
 116 : left-anonymous-complement<= ( first second -- ? )
 117     [ normalize-complement ] dip class<= ;
 118
 119 PREDICATE: nontrivial-anonymous-complement < anonymous-complement
 120     class>> {
 121         [ anonymous-union? ]
 122         [ anonymous-intersection? ]
 123         [ members ]
 124         [ participants ]
 125     } cleave or or or ;
 126
 127 PREDICATE: empty-union < anonymous-union members>> empty? ;
 128
 129 PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
 130
 131 : (class<=) ( first second -- ? )
 132     2dup eq? [ 2drop t ] [
 133         [ normalize-class ] bi@
 134         2dup superclass<= [ 2drop t ] [
 135             {
 136                 { [ 2dup eq? ] [ 2drop t ] }
 137                 { [ dup empty-intersection? ] [ 2drop t ] }
 138                 { [ over empty-union? ] [ 2drop t ] }
 139                 { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
 140                 { [ over anonymous-union? ] [ left-anonymous-union<= ] }
 141                 { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
 142                 { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
 143                 { [ dup members ] [ right-union<= ] }
 144                 { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
 145                 { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
 146                 { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
 147                 [ 2drop f ]
 148             } cond
 149         ] if
 150     ] if ;
 151
 152 M: anonymous-union (classes-intersect?)
 153     members>> [ classes-intersect? ] with any? ;
 154
 155 M: anonymous-intersection (classes-intersect?)
 156     participants>> [ classes-intersect? ] with all? ;
 157
 158 M: anonymous-complement (classes-intersect?)
 159     class>> class<= not ;
 160
 161 : anonymous-union-and ( first second -- class )
 162     members>> [ class-and ] with map <anonymous-union> ;
 163
 164 : anonymous-intersection-and ( first second -- class )
 165     participants>> swap suffix <anonymous-intersection> ;
 166
 167 : (class-and) ( first second -- class )
 168     {
 169         { [ 2dup class<= ] [ drop ] }
 170         { [ 2dup swap class<= ] [ nip ] }
 171         { [ 2dup classes-intersect? not ] [ 2drop null ] }
 172         [
 173             [ normalize-class ] bi@ {
 174                 { [ dup anonymous-union? ] [ anonymous-union-and ] }
 175                 { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
 176                 { [ over anonymous-union? ] [ swap anonymous-union-and ] }
 177                 { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
 178                 [ 2array <anonymous-intersection> ]
 179             } cond
 180         ]
 181     } cond ;
 182
 183 : anonymous-union-or ( first second -- class )
 184     members>> swap suffix <anonymous-union> ;
 185
 186 : ((class-or)) ( first second -- class )
 187     [ normalize-class ] bi@ {
 188         { [ dup anonymous-union? ] [ anonymous-union-or ] }
 189         { [ over anonymous-union? ] [ swap anonymous-union-or ] }
 190         [ 2array <anonymous-union> ]
 191     } cond ;
 192
 193 : anonymous-complement-or ( first second -- class )
 194     2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
 195
 196 : (class-or) ( first second -- class )
 197     {
 198         { [ 2dup class<= ] [ nip ] }
 199         { [ 2dup swap class<= ] [ drop ] }
 200         { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
 201         { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
 202         [ ((class-or)) ]
 203     } cond ;
 204
 205 : (class-not) ( class -- complement )
 206     {
 207         { [ dup anonymous-complement? ] [ class>> ] }
 208         { [ dup object eq? ] [ drop null ] }
 209         { [ dup null eq? ] [ drop object ] }
 210         [ <anonymous-complement> ]
 211     } cond ;
 212
 213 M: anonymous-union (flatten-class)
 214     members>> [ (flatten-class) ] each ;
 215
 216 PRIVATE>
 217
 218 ERROR: topological-sort-failed ;
 219
 220 : largest-class ( seq -- n elt )
 221     dup [ [ class< ] with any? not ] curry find-last
 222     [ topological-sort-failed ] unless* ;
 223
 224 : sort-classes ( seq -- newseq )
 225     [ name>> ] sort-with >vector
 226     [ dup empty? not ]
 227     [ dup largest-class [ swap remove-nth! ] dip ]
 228     produce nip ;
 229
 230 : smallest-class ( classes -- class/f )
 231     [ f ] [
 232         natural-sort <reversed>
 233         [ ] [ [ class<= ] most ] map-reduce
 234     ] if-empty ;
 235
 236 : flatten-class ( class -- assoc )
 237     [ (flatten-class) ] H{ } make-assoc ;
 238
 239 SYMBOL: +incomparable+
 240
 241 : compare-classes ( class1 class2 -- ? )
 242     {
 243         { [ 2dup class<= ] [ t ] }
 244         { [ 2dup classes-intersect? not ] [ f ] }
 245         [ +incomparable+ ]
 246     } cond 2nip ;