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