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