1 ! Copyright (C) 2013 Doug Coleman, John Benediktsson.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs combinators combinators.smart
4 generalizations kernel math math.order namespaces quotations
5 sequences sequences.generalizations sequences.private
6 stack-checker.transforms system words ;
9 : once ( quot -- ) call ; inline
10 : twice ( quot -- ) dup [ call ] dip call ; inline
11 : thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
12 : forever ( quot -- ) [ t ] compose loop ; inline
14 MACRO: cond-case ( assoc -- quot )
17 [ first [ dup ] prepose ]
18 [ second [ drop ] prepose ] bi 2array
20 ] map [ cond ] curry ;
22 MACRO: cleave-array ( quots -- quot )
23 [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
25 : 3bi* ( u v w x y z p q -- )
26 [ 3dip ] dip call ; inline
28 : 3bi@ ( u v w x y z quot -- )
31 : 4bi ( w x y z p q -- )
32 [ 4keep ] dip call ; inline
34 : 4bi* ( s t u v w x y z p q -- )
35 [ 4dip ] dip call ; inline
37 : 4tri* ( o p q r s t u v w x y z p q r -- )
42 : 4bi@ ( s t u v w x y z quot -- )
45 : 4tri@ ( a b c d e f g h i j k l quot -- )
46 dup dup 4tri* ; inline
48 : 4tri ( w x y z p q r -- )
49 [ [ 4keep ] dip 4keep ] dip call ; inline
51 : 4quad ( w x y z p q r s -- )
52 [ [ [ 4keep ] dip 4keep ] dip 4keep ] dip call ; inline
54 : quad* ( w x y z p q r s -- ) [ [ [ 3dip ] dip 2dip ] dip dip ] dip call ; inline
56 : quad@ ( w x y z quot -- ) dup dup dup quad* ; inline
58 : plox ( ... x/f quot: ( ... x -- ... y ) -- ... y/f )
61 : plox-if ( ... x quot: ( ... x -- ... ? ) quot: ( ... x -- ... y ) -- ... y/f )
62 [ keep swap ] dip when ; inline
64 MACRO: smart-plox ( true -- quot )
65 [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
66 '[ _ _ [ _ ndrop f ] smart-if ] ;
68 : throttle ( quot millis -- quot' )
70 _ nano-count { 0 } 2dup first-unsafe _ + >=
71 [ 0 swap set-nth-unsafe call ] [ 3drop ] if
74 : swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
75 '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
78 ! ?1arg-result-falsify
80 : 1falsify ( obj/f -- obj/f ) ; inline
81 : 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline
82 : 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline
84 MACRO: n-and ( n -- quot )
85 1 [-] [ and ] n*quot ;
87 MACRO: n*obj ( n obj -- quot )
90 MACRO:: n-falsify ( n -- quot )
91 [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ;
94 : ?1res ( ..a obj/f quot -- ..b )
97 ! when both args are true, call quot. otherwise dont
98 : ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b )
99 [ 2dup and ] dip [ 2drop f ] if ; inline
101 ! try the quot, keep the original arg if quot is true
102 : ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
103 [ ?1res ] keepd '[ _ ] [ f ] if ; inline
105 : ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
106 [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
109 : alist>quot* ( default assoc -- quot )
110 [ rot \ if* 3array append [ ] like ] assoc-each ;
112 : cond*>quot ( assoc -- quot )
113 [ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
114 reverse! [ no-cond ] swap alist>quot* ;
117 \ cond* [ cond*>quot ] 1 define-transform
118 \ cond* t "no-compile" set-word-prop
121 [ dup callable? [ drop t ] [ first call ] if ] map-find
122 [ dup callable? [ nip call ] [ second call ] if ]
125 MACRO: chain ( quots -- quot )
126 <reversed> [ ] [ swap '[ [ @ @ ] [ f ] if* ] ] reduce ;
128 : with-output-variable ( value variable quot -- value )
129 over [ get ] curry compose with-variable ; inline
131 : loop1 ( ..a quot: ( ..a -- ..a obj ? ) -- ..a obj )
132 [ call ] keep '[ drop _ loop1 ] when ; inline recursive
135 : keep-1up ( quot -- quot ) keep 1 2 0 nrotated ; inline
136 : keep-2up ( quot -- quot ) keep 2 3 0 nrotated ; inline
137 : keep-3up ( quot -- quot ) keep 3 4 0 nrotated ; inline
139 : 2keep-1up ( quot -- quot ) 2keep 1 3 0 nrotated ; inline
140 : 2keep-2up ( quot -- quot ) 2keep 2 4 0 nrotated ; inline
141 : 2keep-3up ( quot -- quot ) 2keep 3 5 0 nrotated ; inline
143 : 3keep-1up ( quot -- quot ) 3keep 1 4 0 nrotated ; inline
144 : 3keep-2up ( quot -- quot ) 3keep 2 5 0 nrotated ; inline
145 : 3keep-3up ( quot -- quot ) 3keep 3 6 0 nrotated ; inline
147 ! d is dummy, o is object to save notation space
148 : dip-1up ( ..a d quot: ( ..a -- ..b o d ) -- ..b d o )
150 : dip-2up ( ..a d quot: ( ..a -- ..b o1 o2 d ) -- ..b d o1 o2 )
153 : 2dip-1up ( ..a d1 d2 quot: ( ..a -- ..b o d1 d2 ) -- ..b d1 d2 o )
155 : 2dip-2up ( ..a d1 d2 quot: ( ..a -- ..b o1 o2 d1 d2 ) -- ..b d1 d2 o1 o2 )
156 2dip roll roll ; inline
158 : 3dip-1up ( ..a d1 d2 d3 quot: ( ..a -- ..b o d1 d2 d3 ) -- ..b d1 d2 d3 o )
160 : 3dip-2up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 )
161 3dip 2 5 0 nrotated ; inline
162 : 3dip-3up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 o3 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 o3 )
163 3dip 3 6 0 nrotated ; inline
166 : 2craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) -- ..c o1 o2 )
167 [ call ] dip [ dip-1up ] call ; inline
169 : 3craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) -- ..d o1 o2 o3 )
170 [ call ] 2dip [ dip-1up ] dip [ 2dip-1up ] call ; inline
172 : 4craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) quot4: ( ..d -- ..e o4 ) -- ..e o1 o2 o3 o4 )
173 [ call ] 3dip [ dip-1up ] 2dip [ 2dip-1up ] dip [ 3dip-1up ] call ; inline
175 : 3and ( a b c -- ? ) and and ; inline
176 : 4and ( a b c d -- ? ) and and and ; inline
178 : 3or ( a b c -- ? ) or or ; inline
179 : 4or ( a b c d -- ? ) or or or ; inline
181 ! The kept values are on the bottom of the stack
182 MACRO: keep-under ( quot -- quot' )
183 dup outputs 1 + '[ _ keep 1 _ 0 -nrotated ] ;
185 MACRO: 2keep-under ( quot -- quot' )
186 dup outputs 2 + '[ _ 2keep 2 _ 0 -nrotated ] ;
188 MACRO: 3keep-under ( quot -- quot' )
189 dup outputs 3 + '[ _ 3keep 3 _ 0 -nrotated ] ;
191 MACRO: 4keep-under ( quot -- quot' )
192 dup outputs 4 + '[ _ 4keep 4 _ 0 -nrotated ] ;
194 ! for use with assoc-map etc
195 : 1temp1d ( quot: ( a b c -- d e f ) -- quot ) '[ swap @ swap ] ; inline
196 : 1temp2d ( quot: ( a b c -- d e f ) -- quot ) '[ rot @ -rot ] ; inline
197 : 2temp2d ( quot: ( a b c d -- e f g h ) -- quot ) '[ 2 4 0 nrotated @ 2 4 0 -nrotated ] ; inline