core/classes/predicate/predicate.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: classes classes.algebra kernel namespaces make words
   4 sequences quotations arrays kernel.private assocs combinators ;
   5 IN: classes.predicate
   6
   7 PREDICATE: predicate-class < class
   8     "metaclass" word-prop predicate-class eq? ;
   9
  10 DEFER: predicate-instance? ( object class -- ? )
  11
  12 : update-predicate-instance ( -- )
  13     \ predicate-instance? bootstrap-word
  14     classes [ predicate-class? ] filter [
  15         [ literalize ]
  16         [
  17             [ superclass 1array [ declare ] curry ]
  18             [ "predicate-definition" word-prop ]
  19             bi compose
  20         ]
  21         bi
  22     ] { } map>assoc [ case ] curry
  23     define ;
  24
  25 : predicate-quot ( class -- quot )
  26     [
  27         \ dup ,
  28         dup superclass "predicate" word-prop %
  29         "predicate-definition" word-prop , [ drop f ] , \ if ,
  30     ] [ ] make ;
  31
  32 : define-predicate-class ( class superclass definition -- )
  33     [ drop f f predicate-class define-class ]
  34     [ nip "predicate-definition" set-word-prop ]
  35     [
  36         2drop
  37         [ dup predicate-quot define-predicate ]
  38         [ update-classes ]
  39         bi
  40     ]
  41     3tri
  42     update-predicate-instance ;
  43
  44 M: predicate-class reset-class
  45     [ call-next-method ]
  46     [ { "predicate-definition" } reset-props ]
  47     bi ;
  48
  49 M: predicate-class rank-class drop 1 ;
  50
  51 M: predicate-class instance?
  52     2dup superclass instance?
  53     [ predicate-instance? ] [ 2drop f ] if ;
  54
  55 M: predicate-class (flatten-class)
  56     superclass (flatten-class) ;
  57
  58 M: predicate-class (classes-intersect?)
  59     superclass classes-intersect? ;