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