core/classes/algebra/algebra.factor

   1 ! Copyright (C) 2004, 2010 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 GENERIC: normalize-class ( class -- class' )\r
  38 \r
  39 M: object normalize-class ;\r
  40 \r
  41 PRIVATE>\r
  42 \r
  43 GENERIC: classoid? ( obj -- ? )\r
  44 \r
  45 M: word classoid? class? ;\r
  46 M: anonymous-union classoid? members>> [ classoid? ] all? ;\r
  47 M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;\r
  48 M: anonymous-complement classoid? class>> classoid? ;\r
  49 \r
  50 : class<= ( first second -- ? )\r
  51     class<=-cache get [ (class<=) ] 2cache ;\r
  52 \r
  53 : class< ( first second -- ? )\r
  54     {\r
  55         { [ 2dup class<= not ] [ 2drop f ] }\r
  56         { [ 2dup swap class<= not ] [ 2drop t ] }\r
  57         [ [ rank-class ] bi@ < ]\r
  58     } cond ;\r
  59 \r
  60 : class<=> ( first second -- ? )\r
  61     {\r
  62         { [ 2dup class<= not ] [ 2drop +gt+ ] }\r
  63         { [ 2dup swap class<= not ] [ 2drop +lt+ ] }\r
  64         [ [ rank-class ] bi@ <=> ]\r
  65     } cond ;\r
  66 \r
  67 : class= ( first second -- ? )\r
  68     [ class<= ] [ swap class<= ] 2bi and ;\r
  69 \r
  70 : class-not ( class -- complement )\r
  71     class-not-cache get [ (class-not) ] cache ;\r
  72 \r
  73 : classes-intersect? ( first second -- ? )\r
  74     classes-intersect-cache get [\r
  75         normalize-class (classes-intersect?)\r
  76     ] 2cache ;\r
  77 \r
  78 : class-and ( first second -- class )\r
  79     class-and-cache get [ (class-and) ] 2cache ;\r
  80 \r
  81 : class-or ( first second -- class )\r
  82     class-or-cache get [ (class-or) ] 2cache ;\r
  83 \r
  84 <PRIVATE\r
  85 \r
  86 : superclass<= ( first second -- ? )\r
  87     swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
  88 \r
  89 : left-anonymous-union<= ( first second -- ? )\r
  90     [ members>> ] dip [ class<= ] curry all? ;\r
  91 \r
  92 : right-union<= ( first second -- ? )\r
  93     members [ class<= ] with any? ;\r
  94 \r
  95 : right-anonymous-union<= ( first second -- ? )\r
  96     members>> [ class<= ] with any? ;\r
  97 \r
  98 : left-anonymous-intersection<= ( first second -- ? )\r
  99     [ participants>> ] dip [ class<= ] curry any? ;\r
 100 \r
 101 : right-anonymous-intersection<= ( first second -- ? )\r
 102     participants>> [ class<= ] with all? ;\r
 103 \r
 104 : anonymous-complement<= ( first second -- ? )\r
 105     [ class>> ] bi@ swap class<= ;\r
 106 \r
 107 : normalize-complement ( class -- class' )\r
 108     class>> normalize-class {\r
 109         { [ dup anonymous-union? ] [\r
 110             members>>\r
 111             [ class-not normalize-class ] map\r
 112             <anonymous-intersection> \r
 113         ] }\r
 114         { [ dup anonymous-intersection? ] [\r
 115             participants>>\r
 116             [ class-not normalize-class ] map\r
 117             <anonymous-union>\r
 118         ] }\r
 119         [ drop object ]\r
 120     } cond ;\r
 121 \r
 122 : left-anonymous-complement<= ( first second -- ? )\r
 123     [ normalize-complement ] dip class<= ;\r
 124 \r
 125 PREDICATE: nontrivial-anonymous-complement < anonymous-complement\r
 126     class>> {\r
 127         [ anonymous-union? ]\r
 128         [ anonymous-intersection? ]\r
 129         [ members ]\r
 130         [ participants ]\r
 131     } cleave or or or ;\r
 132 \r
 133 PREDICATE: empty-union < anonymous-union members>> empty? ;\r
 134 \r
 135 PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;\r
 136 \r
 137 : (class<=) ( first second -- ? )\r
 138     2dup eq? [ 2drop t ] [\r
 139         [ normalize-class ] bi@\r
 140         2dup superclass<= [ 2drop t ] [\r
 141             {\r
 142                 { [ 2dup eq? ] [ 2drop t ] }\r
 143                 { [ dup empty-intersection? ] [ 2drop t ] }\r
 144                 { [ over empty-union? ] [ 2drop t ] }\r
 145                 { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }\r
 146                 { [ over anonymous-union? ] [ left-anonymous-union<= ] }\r
 147                 { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }\r
 148                 { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }\r
 149                 { [ dup members ] [ right-union<= ] }\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