steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

classes.algebra: cleanup

db4
Slava Pestov 2009-11-10 17:41:47 -06:00
parent 19283ed83d
commit c693587018
9 changed files with 168 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
core/classes/algebra/algebra-docs.factor
View File

@ -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" } "." }

217
core/classes/algebra/algebra-tests.factor
View File

@ -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
[ t ] [ vector virtual-sequence null class-and* ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
PREDICATE: no-docs < word "documentation" word-prop not ;
[ 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 ] [
growable tuple sequence class-and class<=
] unit-test
[ t ] [
growable assoc class-and tuple 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 ] [
fixnum class-not
fixnum fixnum class-not class-or
class<=
] unit-test
! class<=>
! 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
[ +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
[ \ + flatten-class ] must-fail

100
core/classes/algebra/algebra.factor
View File

@ -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 -- ? )
{
{ [ 2dup class<= not ] [ 2drop f ] }
{ [ 2dup swap class<= not ] [ 2drop t ] }
[ [ rank-class ] bi@ < ]
} cond ;
M: anonymous-union (flatten-class)
members>> [ (flatten-class) ] each ;
: 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 ;
PRIVATE>
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 ;

8
core/classes/builtin/builtin.factor
View File

@ -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
kernel.private namespaces sequences math math.private
combinators assocs quotations ;
USING: accessors classes classes.algebra classes.algebra.private
words kernel kernel.private namespaces sequences math
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 ;

3
core/classes/intersection/intersection.factor
View File

@ -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

5
core/classes/predicate/predicate.factor
View File

@ -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
sequences quotations arrays kernel.private assocs combinators ;
USING: classes classes.algebra classes.algebra.private kernel
namespaces make words sequences quotations arrays kernel.private
assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class

4
core/classes/singleton/singleton.factor
View File

@ -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
sequences words ;
USING: classes classes.algebra classes.algebra.private
classes.predicate kernel sequences words ;
IN: classes.singleton
: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;

5
core/classes/tuple/tuple.factor
View File

@ -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
slots math.private accessors assocs effects ;
classes.algebra classes.algebra.private classes.builtin
classes.private slots.private slots math.private accessors
assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class

3
core/classes/union/union.factor
View File

@ -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