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