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