1 ! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
2 ! Doug Coleman, Eduardo Cavazos,
4 ! See http://factorcode.org/license.txt for BSD license.
5 USING: kernel combinators fry namespaces quotations hashtables
6 sequences assocs arrays stack-checker effects math math.ranges
7 generalizations macros continuations random locals accessors ;
11 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
12 ! Currying cleave combinators
13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : bi, ( obj quot quot -- quot' quot' )
16 [ [ curry ] curry ] bi@ bi ; inline
17 : tri, ( obj quot quot quot -- quot' quot' quot' )
18 [ [ curry ] curry ] tri@ tri ; inline
20 : bi*, ( obj obj quot quot -- quot' quot' )
21 [ [ curry ] curry ] bi@ bi* ; inline
22 : tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
23 [ [ curry ] curry ] tri@ tri* ; inline
25 : bi@, ( obj obj quot -- quot' quot' )
26 [ curry ] curry bi@ ; inline
27 : tri@, ( obj obj obj quot -- quot' quot' quot' )
28 [ curry ] curry tri@ ; inline
30 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
31 ! Generalized versions of core combinators
32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
34 : quad ( x p q r s -- ) >r >r >r keep r> keep r> keep r> call ; inline
36 : 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
38 : 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
40 : 2with ( param1 param2 obj quot -- obj curry )
43 : 3with ( param1 param2 param3 obj quot -- obj curry )
44 with with with ; inline
46 : with* ( obj assoc quot -- assoc curry )
47 swapd [ [ -rot ] dip call ] 2curry ; inline
49 : 2with* ( obj1 obj2 assoc quot -- assoc curry )
52 : 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
53 with* with* with* ; inline
55 : assoc-each-with ( obj assoc quot -- )
56 with* assoc-each ; inline
58 : assoc-map-with ( obj assoc quot -- assoc )
59 with* assoc-map ; inline
61 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
65 MACRO: preserving ( predicate -- quot )
68 '[ , , nkeep , nrot ] ;
70 MACRO: ifte ( quot quot quot -- )
71 '[ , preserving , , if ] ;
73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
75 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
77 MACRO: switch ( quot -- )
78 [ [ [ preserving ] curry ] dip ] assoc-map
81 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
83 ! Conceptual implementation:
85 ! : pcall ( seq quots -- seq ) [ call ] 2map ;
87 MACRO: parallel-call ( quots -- )
88 [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
89 '[ V{ } clone @ nip >array ] ;
91 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
92 ! map-call and friends
93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
95 : (make-call-with) ( quots -- quot )
96 [ [ keep ] curry ] map concat [ drop ] append ;
98 MACRO: map-call-with ( quots -- )
99 [ (make-call-with) ] keep length [ narray ] curry compose ;
101 : (make-call-with2) ( quots -- quot )
102 [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
105 MACRO: map-call-with2 ( quots -- )
107 [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
109 ] keep length [ narray ] curry append ;
111 MACRO: map-exec-with ( words -- )
112 [ 1quotation ] map [ map-call-with ] curry ;
114 MACRO: construct-slots ( assoc tuple-class -- tuple )
116 [ dip ] curry swap 1quotation [ keep ] curry compose
117 ] { } assoc>map concat compose ;
119 : either ( object first second -- ? )
120 >r keep swap [ r> drop ] [ r> call ] ?if ; inline
122 : 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
123 >r pick >r with r> r> swapd with ;
125 : or? ( obj quot1 quot2 -- ? )
126 >r keep r> rot [ 2nip ] [ call ] if* ; inline
128 : and? ( obj quot1 quot2 -- ? )
129 >r keep r> rot [ call ] [ 2drop f ] if ; inline
131 MACRO: multikeep ( word out-indexes -- ... )
133 dup >r [ \ npick \ >r 3array % ] each
135 r> [ drop \ r> , ] each
138 : retry ( quot n -- )
139 [ drop ] rot compose attempt-all ; inline
141 : do-while ( pred body tail -- )
142 >r tuck 2slip r> while ; inline
144 : generate ( generator predicate -- obj )
145 [ dup ] swap [ dup [ nip ] unless not ] 3compose
148 MACRO: predicates ( seq -- quot/f )
149 dup [ 1quotation [ drop ] prepend ] map
150 >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
153 : %chance ( quot n -- ) 100 random > swap when ; inline