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