core/classes/algebra/algebra.factor

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