core/classes/algebra/algebra.factor

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