core/classes/intersection/intersection.factor

   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 words ;
   6 IN: classes.intersection
   7
   8 PREDICATE: intersection-class < class
   9     "metaclass" word-prop intersection-class eq? ;
  10
  11 <PRIVATE
  12
  13 : intersection-predicate-quot ( members -- quot )
  14     [
  15         [ drop t ]
  16     ] [
  17         unclip predicate-def swap [
  18             predicate-def [ dup ] [ not ] surround
  19             [ drop f ]
  20         ] { } map>assoc alist>quot
  21     ] if-empty ;
  22
  23 : define-intersection-predicate ( class -- )
  24     dup class-participants intersection-predicate-quot define-predicate ;
  25
  26 M: intersection-class update-class define-intersection-predicate ;
  27
  28 M: intersection-class rank-class drop 5 ;
  29
  30 M: intersection-class instance?
  31     "participants" word-prop [ instance? ] with all? ;
  32
  33 M: anonymous-intersection instance?
  34     participants>> [ instance? ] with all? ;
  35
  36 M: intersection-class normalize-class
  37     class-participants <anonymous-intersection> normalize-class ;
  38
  39 M: intersection-class (flatten-class)
  40     class-participants <anonymous-intersection> (flatten-class) ;
  41
  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 ;
  46
  47 M: anonymous-intersection (flatten-class)
  48     participants>> [ full-cover ] [
  49         [ flatten-class ]
  50         [ intersect-flattened-classes ] map-reduce
  51         %
  52     ] if-empty ;
  53
  54 M: anonymous-intersection class-name
  55     participants>> [ class-name ] map " " join ;
  56
  57 PRIVATE>
  58
  59 : define-intersection-class ( class participants -- )
  60     [ [ f f ] dip intersection-class define-class ]
  61     [ drop update-classes ]
  62     2bi ;