classes.algebra: cleanup

core/classes/algebra/algebra-docs.factor

@@ -11,12 +11,7 @@ ARTICLE: "class-operations" "Class operations"
     class-and
     class-or
     classes-intersect?
-}
-"Low-level implementation detail:"
-{ $subsections
     flatten-class
-    flatten-builtin-class
-    class-types
 } ;
 
 ARTICLE: "class-linearization" "Class linearization"
@@ -45,18 +40,10 @@ $nl
 "Metaclass order:"
 { $subsections rank-class } ;
 
-HELP: flatten-builtin-class
-{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
-{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
-
 HELP: flatten-class
 { $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
 { $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
 
-HELP: class-types
-{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
-{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
-
 HELP: class<=
 { $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }

core/classes/algebra/algebra-tests.factor

@@ -7,36 +7,37 @@ stack-checker effects kernel.private sbufs math.order
 classes.tuple accessors generic.private ;
 IN: classes.algebra.tests
 
-: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
-
-: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
-
-[ t ] [ object  object  object class-and* ] unit-test
-[ t ] [ fixnum  object  fixnum class-and* ] unit-test
-[ t ] [ object  fixnum  fixnum class-and* ] unit-test
-[ t ] [ fixnum  fixnum  fixnum class-and* ] unit-test
-[ t ] [ fixnum  integer fixnum class-and* ] unit-test
-[ t ] [ integer fixnum  fixnum class-and* ] unit-test
-
-[ t ] [ vector    fixnum   null   class-and* ] unit-test
-[ t ] [ number    object   number class-and* ] unit-test
-[ t ] [ object    number   number class-and* ] unit-test
-[ t ] [ slice     reversed null   class-and* ] unit-test
-[ t ] [ \ f class-not \ f      null   class-and* ] unit-test
-[ t ] [ \ f class-not \ f      object class-or*  ] unit-test
-
 TUPLE: first-one ;
 TUPLE: second-one ;
 UNION: both first-one union-class ;
 
-[ t ] [ both tuple classes-intersect? ] unit-test
+PREDICATE: no-docs < word "documentation" word-prop not ;
-[ t ] [ vector virtual-sequence null class-and* ] unit-test
-[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
 
-[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
+UNION: no-docs-union no-docs integer ;
 
-[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
+TUPLE: a ;
+TUPLE: b ;
+UNION: c a b ;
 
+TUPLE: tuple-example ;
+
+TUPLE: a1 ;
+TUPLE: b1 ;
+TUPLE: c1 ;
+
+UNION: x1 a1 b1 ;
+UNION: y1 a1 c1 ;
+UNION: z1 b1 c1 ;
+
+SINGLETON: sa
+SINGLETON: sb
+SINGLETON: sc
+
+INTERSECTION: empty-intersection ;
+
+INTERSECTION: generic-class generic class ;
+
+! class<=
 [ t ] [ \ fixnum \ integer class<= ] unit-test
 [ t ] [ \ fixnum \ fixnum class<= ] unit-test
 [ f ] [ \ integer \ fixnum class<= ] unit-test
@@ -50,71 +51,41 @@ UNION: both first-one union-class ;
 [ f ] [ \ reversed \ slice class<= ] unit-test
 [ f ] [ \ slice \ reversed class<= ] unit-test
 
-PREDICATE: no-docs < word "documentation" word-prop not ;
-
-UNION: no-docs-union no-docs integer ;
-
 [ t ] [ no-docs no-docs-union class<= ] unit-test
 [ f ] [ no-docs-union no-docs class<= ] unit-test
 
-TUPLE: a ;
-TUPLE: b ;
-UNION: c a b ;
-
 [ t ] [ \ c \ tuple class<= ] unit-test
 [ f ] [ \ tuple \ c class<= ] unit-test
 
 [ t ] [ \ tuple-class \ class class<= ] unit-test
 [ f ] [ \ class \ tuple-class class<= ] unit-test
 
-TUPLE: tuple-example ;
-
 [ t ] [ \ null \ tuple-example class<= ] unit-test
 [ f ] [ \ object \ tuple-example class<= ] unit-test
 [ f ] [ \ object \ tuple-example class<= ] unit-test
 [ t ] [ \ tuple-example \ tuple class<= ] unit-test
 [ f ] [ \ tuple \ tuple-example class<= ] unit-test
 
-TUPLE: a1 ;
-TUPLE: b1 ;
-TUPLE: c1 ;
-
-UNION: x1 a1 b1 ;
-UNION: y1 a1 c1 ;
-UNION: z1 b1 c1 ;
-
 [ f ] [ z1 x1 y1 class-and class<= ] unit-test
 
 [ t ] [ x1 y1 class-and a1 class<= ] unit-test
 
-[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
-
 [ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
 
 [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
 
-[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
+[ t ] [ growable tuple sequence class-and class<= ] unit-test
 
-[ t ] [
+[ t ] [ growable assoc class-and tuple class<= ] unit-test
-    growable tuple sequence class-and class<=
-] unit-test
-
-[ t ] [
-    growable assoc class-and tuple class<=
-] unit-test
 
 [ t ] [ object \ f \ f class-not class-or class<= ] unit-test
 
 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
 
-[ f ] [ integer integer class-not classes-intersect? ] unit-test
-
 [ t ] [ array number class-not class<= ] unit-test
 
 [ f ] [ bignum number class-not class<= ] unit-test
 
-[ vector ] [ vector class-not class-not ] unit-test
-
 [ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
 
 [ f ] [ fixnum class-not integer class-and array class<= ] unit-test
@@ -127,12 +98,80 @@ UNION: z1 b1 c1 ;
 
 [ t ] [ number class-not integer class-not class<= ] unit-test
 
-[ t ] [ vector array class-not class-and vector class= ] unit-test
+[ f ] [ fixnum class-not integer class<= ] unit-test
+
+[ t ] [ object empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection object class<= ] unit-test
+[ t ] [ \ f class-not empty-intersection class<= ] unit-test
+[ f ] [ empty-intersection \ f class-not class<= ] unit-test
+[ t ] [ \ number empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection class-not null class<= ] unit-test
+[ t ] [ null empty-intersection class-not class<= ] unit-test
+
+[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [
+    fixnum class-not
+    fixnum fixnum class-not class-or
+    class<=
+] unit-test
+
+[ t ] [ generic-class generic class<= ] unit-test
+[ t ] [ generic-class \ class class<= ] unit-test
+
+! class-and
+: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
+
+[ t ] [ object  object  object class-and* ] unit-test
+[ t ] [ fixnum  object  fixnum class-and* ] unit-test
+[ t ] [ object  fixnum  fixnum class-and* ] unit-test
+[ t ] [ fixnum  fixnum  fixnum class-and* ] unit-test
+[ t ] [ fixnum  integer fixnum class-and* ] unit-test
+[ t ] [ integer fixnum  fixnum class-and* ] unit-test
+
+[ t ] [ vector    fixnum   null   class-and* ] unit-test
+[ t ] [ number    object   number class-and* ] unit-test
+[ t ] [ object    number   number class-and* ] unit-test
+[ t ] [ slice     reversed null   class-and* ] unit-test
+[ t ] [ \ f class-not \ f      null   class-and* ] unit-test
+
+[ t ] [ vector virtual-sequence null class-and* ] unit-test
+
+[ t ] [ vector array class-not vector class-and* ] unit-test
+
+! class-or
+: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
+
+[ t ] [ \ f class-not \ f      object class-or*  ] unit-test
+
+! class-not
+[ vector ] [ vector class-not class-not ] unit-test
+
+! classes-intersect?
+[ t ] [ both tuple classes-intersect? ] unit-test
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
+
+[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
+
+[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
+
+[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
+
+[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
+
+[ f ] [ integer integer class-not classes-intersect? ] unit-test
 
 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
 
-[ f ] [ fixnum class-not integer class<= ] unit-test
+[ t ] [ \ word generic-class classes-intersect? ] unit-test
+[ f ] [ number generic-class classes-intersect? ] unit-test
 
+[ f ] [ sa sb classes-intersect? ] unit-test
+
+! class=
 [ t ] [ null class-not object class= ] unit-test
 
 [ t ] [ object class-not null class= ] unit-test
@@ -141,13 +180,14 @@ UNION: z1 b1 c1 ;
 
 [ f ] [ null class-not null class= ] unit-test
 
-[ t ] [
+! class<=>
-    fixnum class-not
-    fixnum fixnum class-not class-or
-    class<=
-] unit-test
 
-! Test method inlining
+[ +lt+ ] [ integer sequence class<=> ] unit-test
+[ +lt+ ] [ sequence object class<=> ] unit-test
+[ +gt+ ] [ object sequence class<=> ] unit-test
+[ +eq+ ] [ integer integer class<=> ] unit-test
+
+! smallest-class etc
 [ real ] [ { real sequence } smallest-class ] unit-test
 [ real ] [ { sequence real } smallest-class ] unit-test
 
@@ -266,59 +306,10 @@ TUPLE: xh < xb ;
 
 [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
 
-INTERSECTION: generic-class generic class ;
-
-[ t ] [ generic-class generic class<= ] unit-test
-[ t ] [ generic-class \ class class<= ] unit-test
-
-! Later
-[
-    [ t ] [ \ class generic class-and generic-class class<= ] unit-test
-    [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
-] drop
-
-[ t ] [ \ word generic-class classes-intersect? ] unit-test
-[ f ] [ number generic-class classes-intersect? ] unit-test
-
 [ H{ { word word } } ] [ 
     generic-class flatten-class
 ] unit-test
 
-[ \ + flatten-class ] must-fail
-
-INTERSECTION: empty-intersection ;
-
-[ t ] [ object empty-intersection class<= ] unit-test
-[ t ] [ empty-intersection object class<= ] unit-test
-[ t ] [ \ f class-not empty-intersection class<= ] unit-test
-[ f ] [ empty-intersection \ f class-not class<= ] unit-test
-[ t ] [ \ number empty-intersection class<= ] unit-test
-[ t ] [ empty-intersection class-not null class<= ] unit-test
-[ t ] [ null empty-intersection class-not class<= ] unit-test
-
-[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
-[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
-
-[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
-
-[ ] [ object flatten-builtin-class drop ] unit-test
-
-SINGLETON: sa
-SINGLETON: sb
-SINGLETON: sc
-
 [ sa ] [ sa { sa sb sc } min-class ] unit-test
 
-[ f ] [ sa sb classes-intersect? ] unit-test
+[ \ + flatten-class ] must-fail
-
-[ +lt+ ] [ integer sequence class<=> ] unit-test
-[ +lt+ ] [ sequence object class<=> ] unit-test
-[ +gt+ ] [ object sequence class<=> ] unit-test
-[ +eq+ ] [ integer integer class<=> ] unit-test
-
-! Limitations:
-
-! UNION: u1 sa sb ;
-! UNION: u2 sc ;
-
-! [ f ] [ u1 u2 classes-intersect? ] unit-test

core/classes/algebra/algebra.factor

@@ -5,18 +5,41 @@ vectors assocs namespaces words sorting layouts math hashtables
 kernel.private sets math.order ;
 IN: classes.algebra
 
-TUPLE: anonymous-union members ;
+<PRIVATE
+
+TUPLE: anonymous-union { members read-only } ;
 
 C: <anonymous-union> anonymous-union
 
-TUPLE: anonymous-intersection participants ;
+TUPLE: anonymous-intersection { participants read-only } ;
 
 C: <anonymous-intersection> anonymous-intersection
 
-TUPLE: anonymous-complement class ;
+TUPLE: anonymous-complement { class read-only } ;
 
 C: <anonymous-complement> anonymous-complement
 
+DEFER: (class<=)
+
+DEFER: (class-not)
+
+GENERIC: (classes-intersect?) ( first second -- ? )
+
+DEFER: (class-and)
+
+DEFER: (class-or)
+
+GENERIC: (flatten-class) ( class -- )
+
+: normalize-class ( class -- class' )
+    {
+        { [ dup members ] [ members <anonymous-union> ] }
+        { [ dup participants ] [ participants <anonymous-intersection> ] }
+        [ ]
+    } cond ;
+
+PRIVATE>
+
 GENERIC: valid-class? ( obj -- ? )
 
 M: class valid-class? drop t ;
@@ -25,40 +48,42 @@ M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
 M: anonymous-complement valid-class? class>> valid-class? ;
 M: word valid-class? drop f ;
 
-DEFER: (class<=)
-
 : class<= ( first second -- ? )
     class<=-cache get [ (class<=) ] 2cache ;
 
-DEFER: (class-not)
+: class< ( first second -- ? )
+    {
+        { [ 2dup class<= not ] [ 2drop f ] }
+        { [ 2dup swap class<= not ] [ 2drop t ] }
+        [ [ rank-class ] bi@ < ]
+    } cond ;
+
+: class<=> ( first second -- ? )
+    {
+        { [ 2dup class<= not ] [ 2drop +gt+ ] }
+        { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
+        [ [ rank-class ] bi@ <=> ]
+    } cond ;
+
+: class= ( first second -- ? )
+    [ class<= ] [ swap class<= ] 2bi and ;
 
 : class-not ( class -- complement )
     class-not-cache get [ (class-not) ] cache ;
 
-GENERIC: (classes-intersect?) ( first second -- ? )
-
-: normalize-class ( class -- class' )
-    {
-        { [ dup members ] [ members <anonymous-union> ] }
-        { [ dup participants ] [ participants <anonymous-intersection> ] }
-        [ ]
-    } cond ;
-
 : classes-intersect? ( first second -- ? )
     classes-intersect-cache get [
         normalize-class (classes-intersect?)
     ] 2cache ;
 
-DEFER: (class-and)
-
 : class-and ( first second -- class )
     class-and-cache get [ (class-and) ] 2cache ;
 
-DEFER: (class-or)
-
 : class-or ( first second -- class )
     class-or-cache get [ (class-or) ] 2cache ;
 
+<PRIVATE
+
 : superclass<= ( first second -- ? )
     swap superclass dup [ swap class<= ] [ 2drop f ] if ;
 
@@ -185,22 +210,10 @@ M: anonymous-complement (classes-intersect?)
         [ <anonymous-complement> ]
     } cond ;
 
-: class< ( first second -- ? )
+M: anonymous-union (flatten-class)
-    {
+    members>> [ (flatten-class) ] each ;
-        { [ 2dup class<= not ] [ 2drop f ] }
-        { [ 2dup swap class<= not ] [ 2drop t ] }
-        [ [ rank-class ] bi@ < ]
-    } cond ;
 
-: class<=> ( first second -- ? )
+PRIVATE>
-    {
-        { [ 2dup class<= not ] [ 2drop +gt+ ] }
-        { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
-        [ [ rank-class ] bi@ <=> ]
-    } cond ;
-
-: class= ( first second -- ? )
-    [ class<= ] [ swap class<= ] 2bi and ;
 
 ERROR: topological-sort-failed ;
 
@@ -211,7 +224,7 @@ ERROR: topological-sort-failed ;
 : sort-classes ( seq -- newseq )
     [ name>> ] sort-with >vector
     [ dup empty? not ]
-    [ dup largest-class [ over remove-nth! drop ] dip ]
+    [ dup largest-class [ swap remove-nth! ] dip ]
     produce nip ;
 
 : smallest-class ( classes -- class/f )
@@ -220,22 +233,5 @@ ERROR: topological-sort-failed ;
         [ ] [ [ class<= ] most ] map-reduce
     ] if-empty ;
 
-GENERIC: (flatten-class) ( class -- )
-
-M: anonymous-union (flatten-class)
-    members>> [ (flatten-class) ] each ;
-
 : flatten-class ( class -- assoc )
     [ (flatten-class) ] H{ } make-assoc ;
-
-: flatten-builtin-class ( class -- assoc )
-    flatten-class [
-        dup tuple class<= [ 2drop tuple tuple ] when
-    ] assoc-map ;
-
-: class-types ( class -- seq )
-    flatten-builtin-class keys
-    [ "type" word-prop ] map natural-sort ;
-
-: class-type ( class -- tag/f )
-    class-types dup length 1 = [ first ] [ drop f ] if ;

core/classes/builtin/builtin.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.algebra words kernel
+USING: accessors classes classes.algebra classes.algebra.private
-kernel.private namespaces sequences math math.private
+words kernel kernel.private namespaces sequences math
-combinators assocs quotations ;
+math.private combinators assocs quotations ;
 IN: classes.builtin
 
 SYMBOL: builtins
@@ -36,6 +36,6 @@ M: builtin-class (classes-intersect?)
         [ swap classes-intersect? ]
     } cond ;
 
-: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ;
+: full-cover ( -- ) builtins get [ (flatten-class) ] each ;
 
 M: anonymous-complement (flatten-class) drop full-cover ;

core/classes/intersection/intersection.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words accessors sequences kernel assocs combinators classes
-classes.algebra classes.builtin namespaces arrays math quotations ;
+classes.algebra classes.algebra.private classes.builtin
+namespaces arrays math quotations ;
 IN: classes.intersection
 
 PREDICATE: intersection-class < class

core/classes/predicate/predicate.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra kernel namespaces make words
+USING: classes classes.algebra classes.algebra.private kernel
-sequences quotations arrays kernel.private assocs combinators ;
+namespaces make words sequences quotations arrays kernel.private
+assocs combinators ;
 IN: classes.predicate
 
 PREDICATE: predicate-class < class

core/classes/singleton/singleton.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra classes.predicate kernel
+USING: classes classes.algebra classes.algebra.private
-sequences words ;
+classes.predicate kernel sequences words ;
 IN: classes.singleton
 
 : singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;

core/classes/tuple/tuple.factor

@@ -3,8 +3,9 @@
 USING: arrays definitions hashtables kernel kernel.private math
 namespaces make sequences sequences.private strings vectors
 words quotations memory combinators generic classes
-classes.algebra classes.builtin classes.private slots.private
+classes.algebra classes.algebra.private classes.builtin
-slots math.private accessors assocs effects ;
+classes.private slots.private slots math.private accessors
+assocs effects ;
 IN: classes.tuple
 
 PREDICATE: tuple-class < class

core/classes/union/union.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
-classes.algebra namespaces arrays math quotations ;
+classes.algebra classes.algebra.private namespaces arrays math
+quotations ;
 IN: classes.union
 
 PREDICATE: union-class < class