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