core/generic/classes.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: generic
   4 USING: arrays definitions errors hashtables kernel
   5 kernel-internals namespaces sequences strings words
   6 vectors math parser ;
   7
   8 PREDICATE: word class ( obj -- ? ) "class" word-prop ;
   9
  10 SYMBOL: typemap
  11 SYMBOL: class<map
  12 SYMBOL: builtins
  13
  14 PREDICATE: word builtin ( obj -- ? ) builtins get memq? ;
  15
  16 : classes ( -- seq ) class<map get hash-keys ;
  17
  18 : type>class ( n -- class ) builtins get nth ;
  19
  20 : predicate-word ( word -- predicate )
  21     word-name "?" append create-in ;
  22
  23 : predicate-effect 1 1 <effect> ;
  24
  25 : define-predicate ( class predicate quot -- )
  26     over [
  27         over predicate-effect "declared-effect" set-word-prop
  28         dupd define-compound
  29         2dup unit "predicate" set-word-prop
  30         swap "predicating" set-word-prop
  31     ] [
  32         3drop
  33     ] if ;
  34
  35 : superclass ( class -- super ) "superclass" word-prop ;
  36
  37 : members ( class -- seq ) "members" word-prop ;
  38
  39 : (flatten-class) ( class -- )
  40     dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
  41
  42 : flatten-class ( class -- seq )
  43     [ (flatten-class) ] make-hash ;
  44
  45 : (types) ( class -- )
  46     flatten-class [
  47         drop dup superclass
  48         [ (types) ] [ "type" word-prop dup set ] ?if
  49     ] hash-each ;
  50
  51 : types ( class -- seq )
  52     [ (types) ] make-hash hash-keys natural-sort ;
  53
  54 DEFER: (class<)
  55
  56 : superclass< ( cls1 cls2 -- ? )
  57     >r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
  58
  59 : union-class< ( cls1 cls2 -- ? )
  60     [ flatten-class ] 2apply hash-keys swap
  61     [ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
  62
  63 : class-empty? ( class -- ? )
  64     members dup [ empty? ] when ;
  65
  66 : (class<) ( class1 class2 -- ? )
  67     {
  68         { [ 2dup eq? ] [ 2drop t ] }
  69         { [ over class-empty? ] [ 2drop t ] }
  70         { [ 2dup superclass< ] [ 2drop t ] }
  71         { [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
  72         { [ t ] [ union-class< ] }
  73     } cond ;
  74
  75 : class< ( class1 class2 -- ? )
  76     class<map get hash hash-member? ;
  77
  78 : class-compare ( class1 class2 -- n )
  79     2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
  80
  81 : lookup-union ( classes -- class )
  82     typemap get hash [ object ] unless* ;
  83
  84 : types* ( class -- classes )
  85     types [ type>class dup ] map>hash ;
  86
  87 : (class-or) ( class class -- class )
  88     [ types* ] 2apply hash-union lookup-union ;
  89
  90 : class-or ( class1 class2 -- class )
  91     {
  92         { [ 2dup class< ] [ nip ] }
  93         { [ 2dup swap class< ] [ drop ] }
  94         { [ t ] [ (class-or) ] }
  95     } cond ;
  96
  97 : (class-and) ( class class -- class )
  98     [ types* ] 2apply hash-intersect lookup-union ;
  99
 100 : class-and ( class1 class2 -- class )
 101     {
 102         { [ 2dup class< ] [ drop ] }
 103         { [ 2dup swap class< ] [ nip ] }
 104         { [ t ] [ (class-and) ] }
 105     } cond ;
 106
 107 : classes-intersect? ( class1 class2 -- ? )
 108     class-and class-empty? not ;
 109
 110 : min-class ( class seq -- class/f )
 111     [ dupd classes-intersect? ] subset dup empty? [
 112         2drop f
 113     ] [
 114         tuck [ class< ] all-with? [ peek ] [ drop f ] if
 115     ] if ;
 116
 117 : smaller-classes ( class -- seq )
 118     classes [ swap (class<) ] subset-with ;
 119
 120 : smaller-classes+ ( class -- )
 121     [ smaller-classes [ dup ] map>hash ] keep
 122     class<map get set-hash ;
 123
 124 : bigger-classes ( class -- seq )
 125     classes [ (class<) ] subset-with ;
 126
 127 : bigger-classes+ ( class -- )
 128     dup bigger-classes
 129     [ dupd class<map get hash set-hash ] each-with ;
 130
 131 : define-class ( class -- )
 132     dup t "class" set-word-prop
 133     dup dup flatten-class typemap get set-hash
 134     dup smaller-classes+ bigger-classes+ ;
 135
 136 ! Predicate classes for generalized predicate dispatch.
 137 : define-predicate-class ( class predicate definition -- )
 138     pick define-class
 139     3dup nip "definition" set-word-prop
 140     pick superclass "predicate" word-prop
 141     [ \ dup , % , [ drop f ] , \ if , ] [ ] make
 142     define-predicate ;
 143
 144 PREDICATE: class predicate "definition" word-prop ;
 145
 146 ! Union classes for dispatch on multiple classes.
 147 : union-predicate ( seq -- quot )
 148     [ dup ] swap [ "predicate" word-prop append ] map-with
 149     [ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;
 150
 151 : set-members ( class members -- )
 152     [ bootstrap-word ] map "members" set-word-prop ;
 153
 154 : define-union ( class predicate members -- )
 155     3dup nip set-members pick define-class
 156     union-predicate define-predicate ;
 157
 158 PREDICATE: class union members ;
 159
 160 ! Definition protocol
 161 : smaller-classes- ( class -- )
 162     class<map get remove-hash ;
 163
 164 : bigger-classes- ( class -- )
 165     classes [ class<map get hash remove-hash ] each-with ;
 166
 167 : forget-class ( class -- )
 168     dup subdefs [ forget ] each
 169     dup "predicate" word-prop [ forget ] each
 170     dup dup flatten-class typemap get remove-hash forget-word
 171     dup smaller-classes- bigger-classes- ;
 172
 173 M: class forget forget-class ;