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