1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs classes classes.algebra
4 classes.algebra.private classes.builtin classes.private
5 combinators kernel make sequences splitting words ;
6 IN: classes.intersection
8 PREDICATE: intersection-class < class
9 "metaclass" word-prop intersection-class eq? ;
13 : intersection-predicate-quot ( members -- quot )
17 unclip predicate-def swap [
18 predicate-def [ dup ] [ not ] surround
20 ] { } map>assoc alist>quot
23 : define-intersection-predicate ( class -- )
24 dup class-participants intersection-predicate-quot define-predicate ;
26 M: intersection-class update-class define-intersection-predicate ;
28 M: intersection-class rank-class drop 5 ;
30 M: intersection-class instance?
31 "participants" word-prop [ instance? ] with all? ;
33 M: anonymous-intersection instance?
34 participants>> [ instance? ] with all? ;
36 M: intersection-class normalize-class
37 class-participants <anonymous-intersection> normalize-class ;
39 M: intersection-class (flatten-class)
40 class-participants <anonymous-intersection> (flatten-class) ;
42 ! Horribly inefficient and inaccurate
43 : intersect-flattened-classes ( seq1 seq2 -- seq3 )
44 ! Only keep those in seq1 that intersect something in seq2.
45 [ [ classes-intersect? ] with any? ] curry filter ;
47 M: anonymous-intersection (flatten-class)
48 participants>> [ full-cover ] [
50 [ intersect-flattened-classes ] map-reduce
54 M: anonymous-intersection class-name
55 participants>> [ class-name ] map unwords ;
59 : define-intersection-class ( class participants -- )
60 [ [ f f ] dip intersection-class define-class ]
61 [ drop update-classes ]