core/classes/algebra/algebra.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.private
   4 combinators kernel make math math.order namespaces sequences
   5 sets sorting vectors ;
   6 IN: classes.algebra
   7
   8 DEFER: sort-classes
   9
  10 <PRIVATE
  11
  12 TUPLE: anonymous-union { members read-only } ;
  13
  14 INSTANCE: anonymous-union classoid
  15
  16 : <anonymous-union> ( members -- classoid )
  17     [ classoid check-instance ] map [ null eq? ] reject
  18     members dup length 1 =
  19     [ first ] [ sort-classes f like anonymous-union boa ] if ;
  20
  21 M: anonymous-union rank-class drop 6 ;
  22
  23 TUPLE: anonymous-intersection { participants read-only } ;
  24
  25 INSTANCE: anonymous-intersection classoid
  26
  27 : <anonymous-intersection> ( participants -- classoid )
  28     [ classoid check-instance ] map
  29     members dup length 1 =
  30     [ first ] [ sort-classes f like anonymous-intersection boa ] if ;
  31
  32 M: anonymous-intersection rank-class drop 4 ;
  33
  34 TUPLE: anonymous-complement { class read-only } ;
  35
  36 INSTANCE: anonymous-complement classoid
  37
  38 : <anonymous-complement> ( object -- classoid )
  39     classoid check-instance anonymous-complement boa ;
  40
  41 M: anonymous-complement rank-class drop 3 ;
  42
  43 M: anonymous-complement predicate-def
  44     class>> '[ [ _ instance? not ] [ t ] if* ] curry ;
  45
  46 M: anonymous-complement instance?
  47     over [ class>> instance? not ] [ 2drop t ] if ;
  48
  49 M: anonymous-complement class-name
  50     class>> class-name ;
  51
  52 DEFER: (class<=)
  53
  54 DEFER: (class-not)
  55
  56 GENERIC: (classes-intersect?) ( first second -- ? )
  57
  58 DEFER: (class-and)
  59
  60 DEFER: (class-or)
  61
  62 GENERIC: (flatten-class) ( class -- )
  63
  64 GENERIC: normalize-class ( class -- class' )
  65
  66 M: object normalize-class ;
  67
  68 : symmetric-class-op ( first second cache quot -- result )
  69     [ 2dup [ rank-class ] bi@ > [ swap ] when ] 2dip 2cache ; inline
  70
  71 PRIVATE>
  72
  73 : only-classoid? ( obj -- ? )
  74     dup classoid? [ class? not ] [ drop f ] if ;
  75
  76 : class<= ( first second -- ? )
  77     class<=-cache get [ (class<=) ] 2cache ;
  78
  79 : class< ( first second -- ? )
  80     {
  81         { [ 2dup class<= not ] [ 2drop f ] }
  82         { [ 2dup swap class<= not ] [ 2drop t ] }
  83         [ [ rank-class ] bi@ < ]
  84     } cond ;
  85
  86 : class= ( first second -- ? )
  87     2dup class<= [ swap class<= ] [ 2drop f ] if ;
  88
  89 : class-not ( class -- complement )
  90     class-not-cache get [ (class-not) ] cache ;
  91
  92 : classes-intersect? ( first second -- ? )
  93     [ normalize-class ] bi@
  94     classes-intersect-cache get [ (classes-intersect?) ] symmetric-class-op ;
  95
  96 : class-and ( first second -- class )
  97     class-and-cache get [ (class-and) ] symmetric-class-op ;
  98
  99 : class-or ( first second -- class )
 100     class-or-cache get [ (class-or) ] symmetric-class-op ;
 101
 102 SYMBOL: +incomparable+
 103
 104 : compare-classes ( first second -- <=> )
 105     [ swap class<= ] [ class<= ] 2bi
 106     [ +eq+ +lt+ ] [ +gt+ +incomparable+ ] if ? ;
 107
 108 : evaluate-class-predicate ( class1 class2 -- ? )
 109     {
 110         { [ 2dup class<= ] [ t ] }
 111         { [ 2dup classes-intersect? not ] [ f ] }
 112         [ +incomparable+ ]
 113     } cond 2nip ;
 114
 115 <PRIVATE
 116
 117 : superclass<= ( first second -- ? )
 118     swap superclass-of [ swap class<= ] [ drop f ] if* ;
 119
 120 : left-anonymous-union<= ( first second -- ? )
 121     [ members>> ] dip [ class<= ] curry all? ;
 122
 123 : right-union<= ( first second -- ? )
 124     class-members [ class<= ] with any? ;
 125
 126 : right-anonymous-union<= ( first second -- ? )
 127     members>> [ class<= ] with any? ;
 128
 129 : left-anonymous-intersection<= ( first second -- ? )
 130     [ participants>> ] dip [ class<= ] curry any? ;
 131
 132 PREDICATE: nontrivial-anonymous-intersection < anonymous-intersection
 133     participants>> empty? not ;
 134
 135 : right-anonymous-intersection<= ( first second -- ? )
 136     participants>> [ class<= ] with all? ;
 137
 138 : anonymous-complement<= ( first second -- ? )
 139     [ class>> ] bi@ swap class<= ;
 140
 141 : normalize-complement ( class -- class' )
 142     class>> normalize-class {
 143         { [ dup anonymous-union? ] [
 144             members>>
 145             [ class-not normalize-class ] map
 146             <anonymous-intersection>
 147         ] }
 148         { [ dup anonymous-intersection? ] [
 149             participants>>
 150             [ class-not normalize-class ] map
 151             <anonymous-union>
 152         ] }
 153         [ drop object ]
 154     } cond ;
 155
 156 : left-anonymous-complement<= ( first second -- ? )
 157     [ normalize-complement ] dip class<= ;
 158
 159 PREDICATE: nontrivial-anonymous-complement < anonymous-complement
 160     class>> dup anonymous-union? [ drop t ] [
 161         dup anonymous-intersection? [ drop t ] [
 162             dup class-members [ drop t ] [
 163                 class-participants
 164             ] if
 165         ] if
 166     ] if ;
 167
 168 PREDICATE: empty-union < anonymous-union members>> empty? ;
 169
 170 PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
 171
 172 : (class<=) ( first second -- ? )
 173     2dup eq? [ 2drop t ] [
 174         [ normalize-class ] bi@
 175         2dup superclass<= [ 2drop t ] [
 176             {
 177                 { [ 2dup eq? ] [ 2drop t ] }
 178                 { [ dup empty-intersection? ] [ 2drop t ] }
 179                 { [ over empty-union? ] [ 2drop t ] }
 180                 { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
 181                 { [ over anonymous-union? ] [ left-anonymous-union<= ] }
 182                 { [ over nontrivial-anonymous-intersection? ] [ left-anonymous-intersection<= ] }
 183                 { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
 184                 { [ dup class-members ] [ right-union<= ] }
 185                 { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
 186                 { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
 187                 { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
 188                 [ 2drop f ]
 189             } cond
 190         ] if
 191     ] if ;
 192
 193 M: anonymous-union (classes-intersect?)
 194     members>> [ classes-intersect? ] with any? ;
 195
 196 M: anonymous-intersection (classes-intersect?)
 197     participants>> [ classes-intersect? ] with all? ;
 198
 199 M: anonymous-complement (classes-intersect?)
 200     class>> class<= not ;
 201
 202 : anonymous-union-and ( first second -- class )
 203     members>> [ class-and ] with map <anonymous-union> ;
 204
 205 : anonymous-intersection-and ( first second -- class )
 206     participants>> swap suffix <anonymous-intersection> ;
 207
 208 : (class-and) ( first second -- class )
 209     2dup compare-classes {
 210         { +lt+ [ drop ] }
 211         { +gt+ [ nip ] }
 212         { +eq+ [ nip ] }
 213         { +incomparable+ [
 214             2dup classes-intersect? [
 215                 [ normalize-class ] bi@ {
 216                     { [ dup anonymous-union? ] [ anonymous-union-and ] }
 217                     { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
 218                     { [ over anonymous-union? ] [ swap anonymous-union-and ] }
 219                     { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
 220                     [ 2array <anonymous-intersection> ]
 221                 } cond
 222             ] [ 2drop null ] if
 223         ] }
 224     } case ;
 225
 226 : anonymous-union-or ( first second -- class )
 227     members>> swap suffix <anonymous-union> ;
 228
 229 : classes>anonymous-union ( first second -- class )
 230     [ normalize-class ] bi@ {
 231         { [ dup anonymous-union? ] [ anonymous-union-or ] }
 232         { [ over anonymous-union? ] [ swap anonymous-union-or ] }
 233         [ 2array <anonymous-union> ]
 234     } cond ;
 235
 236 : anonymous-complement-or ( first second -- class )
 237     2dup class>> swap class<= [ 2drop object ] [ classes>anonymous-union ] if ;
 238
 239 : (class-or) ( first second -- class )
 240     2dup compare-classes {
 241         { +lt+ [ nip ] }
 242         { +gt+ [ drop ] }
 243         { +eq+ [ nip ] }
 244         { +incomparable+ [
 245             {
 246                 { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
 247                 { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
 248                 [ classes>anonymous-union ]
 249             } cond
 250         ] }
 251     } case ;
 252
 253 : (class-not) ( class -- complement )
 254     {
 255         { [ dup anonymous-complement? ] [ class>> ] }
 256         { [ dup object eq? ] [ drop null ] }
 257         { [ dup null eq? ] [ drop object ] }
 258         [ <anonymous-complement> ]
 259     } cond ;
 260
 261 M: anonymous-union (flatten-class)
 262     members>> [ (flatten-class) ] each ;
 263
 264 PRIVATE>
 265
 266 ERROR: topological-sort-failed ;
 267
 268 : largest-class ( seq -- n elt )
 269     dup [ [ class< ] with none? ] curry find-last
 270     [ topological-sort-failed ] unless* ;
 271
 272 : sort-classes ( seq -- newseq )
 273     [ class-name ] sort-with >vector
 274     [ dup empty? not ]
 275     [ dup largest-class [ swap remove-nth! ] dip ]
 276     produce nip ;
 277
 278 : smallest-class ( classes -- class/f )
 279     [ f ] [
 280         natural-sort <reversed>
 281         [ ] [ [ class<= ] most ] map-reduce
 282     ] if-empty ;
 283
 284 : flatten-class ( class -- seq )
 285     [ (flatten-class) ] { } make members ;