63 lines
1.8 KiB
Factor
63 lines
1.8 KiB
Factor
! Copyright (C) 2004, 2010 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors assocs classes classes.algebra
|
|
classes.algebra.private classes.builtin classes.private
|
|
combinators kernel make sequences words ;
|
|
IN: classes.intersection
|
|
|
|
PREDICATE: intersection-class < class
|
|
"metaclass" word-prop intersection-class eq? ;
|
|
|
|
<PRIVATE
|
|
|
|
: intersection-predicate-quot ( members -- quot )
|
|
[
|
|
[ drop t ]
|
|
] [
|
|
unclip predicate-def swap [
|
|
predicate-def [ dup ] [ not ] surround
|
|
[ drop f ]
|
|
] { } map>assoc alist>quot
|
|
] if-empty ;
|
|
|
|
: define-intersection-predicate ( class -- )
|
|
dup class-participants intersection-predicate-quot define-predicate ;
|
|
|
|
M: intersection-class update-class define-intersection-predicate ;
|
|
|
|
M: intersection-class rank-class drop 5 ;
|
|
|
|
M: intersection-class instance?
|
|
"participants" word-prop [ instance? ] with all? ;
|
|
|
|
M: anonymous-intersection instance?
|
|
participants>> [ instance? ] with all? ;
|
|
|
|
M: intersection-class normalize-class
|
|
class-participants <anonymous-intersection> normalize-class ;
|
|
|
|
M: intersection-class (flatten-class)
|
|
class-participants <anonymous-intersection> (flatten-class) ;
|
|
|
|
! Horribly inefficient and inaccurate
|
|
: intersect-flattened-classes ( seq1 seq2 -- seq3 )
|
|
! Only keep those in seq1 that intersect something in seq2.
|
|
[ [ classes-intersect? ] with any? ] curry filter ;
|
|
|
|
M: anonymous-intersection (flatten-class)
|
|
participants>> [ full-cover ] [
|
|
[ flatten-class keys ]
|
|
[ intersect-flattened-classes ] map-reduce
|
|
[ dup ,, ] each
|
|
] if-empty ;
|
|
|
|
M: anonymous-intersection class-name
|
|
participants>> [ class-name ] map " " join ;
|
|
|
|
PRIVATE>
|
|
|
|
: define-intersection-class ( class participants -- )
|
|
[ [ f f ] dip intersection-class define-class ]
|
|
[ drop update-classes ]
|
|
2bi ;
|