60 lines
1.6 KiB
Factor
Executable File
60 lines
1.6 KiB
Factor
Executable File
! Copyright (C) 2004, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: classes classes.algebra kernel namespaces words sequences
|
|
quotations arrays kernel.private assocs combinators ;
|
|
IN: classes.predicate
|
|
|
|
PREDICATE: predicate-class < class
|
|
"metaclass" word-prop predicate-class eq? ;
|
|
|
|
DEFER: predicate-instance? ( object class -- ? )
|
|
|
|
: update-predicate-instance ( -- )
|
|
\ predicate-instance? bootstrap-word
|
|
classes [ predicate-class? ] filter [
|
|
[ literalize ]
|
|
[
|
|
[ superclass 1array [ declare ] curry ]
|
|
[ "predicate-definition" word-prop ]
|
|
bi compose
|
|
]
|
|
bi
|
|
] { } map>assoc [ case ] curry
|
|
define ;
|
|
|
|
: predicate-quot ( class -- quot )
|
|
[
|
|
\ dup ,
|
|
dup superclass "predicate" word-prop %
|
|
"predicate-definition" word-prop , [ drop f ] , \ if ,
|
|
] [ ] make ;
|
|
|
|
: define-predicate-class ( class superclass definition -- )
|
|
[ drop f f predicate-class define-class ]
|
|
[ nip "predicate-definition" set-word-prop ]
|
|
[
|
|
2drop
|
|
[ dup predicate-quot define-predicate ]
|
|
[ update-classes ]
|
|
bi
|
|
]
|
|
3tri
|
|
update-predicate-instance ;
|
|
|
|
M: predicate-class reset-class
|
|
[ call-next-method ]
|
|
[ { "predicate-definition" } reset-props ]
|
|
bi ;
|
|
|
|
M: predicate-class rank-class drop 1 ;
|
|
|
|
M: predicate-class instance?
|
|
2dup superclass instance?
|
|
[ predicate-instance? ] [ 2drop f ] if ;
|
|
|
|
M: predicate-class (flatten-class)
|
|
superclass (flatten-class) ;
|
|
|
|
M: predicate-class (classes-intersect?)
|
|
superclass classes-intersect? ;
|