1 ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences math vectors arrays namespaces make
4 quotations promises combinators io lists accessors ;
7 M: promise car ( promise -- car )
10 M: promise cdr ( promise -- cdr )
13 M: promise nil? ( cons -- bool )
16 ! Both 'car' and 'cdr' are promises
17 TUPLE: lazy-cons car cdr ;
19 : lazy-cons ( car cdr -- promise )
20 [ promise ] bi@ \ lazy-cons boa
21 T{ promise f f t f } clone
24 M: lazy-cons car ( lazy-cons -- car )
27 M: lazy-cons cdr ( lazy-cons -- cdr )
30 M: lazy-cons nil? ( lazy-cons -- bool )
33 : 1lazy-list ( a -- lazy-cons )
36 : 2lazy-list ( a b -- lazy-cons )
37 1lazy-list 1quotation lazy-cons ;
39 : 3lazy-list ( a b c -- lazy-cons )
40 2lazy-list 1quotation lazy-cons ;
42 TUPLE: memoized-cons original car cdr nil? ;
44 : not-memoized ( -- obj )
47 : not-memoized? ( obj -- bool )
50 : <memoized-cons> ( cons -- memoized-cons )
51 not-memoized not-memoized not-memoized
54 M: memoized-cons car ( memoized-cons -- car )
55 dup car>> not-memoized? [
56 dup original>> car [ >>car drop ] keep
61 M: memoized-cons cdr ( memoized-cons -- cdr )
62 dup cdr>> not-memoized? [
63 dup original>> cdr [ >>cdr drop ] keep
68 M: memoized-cons nil? ( memoized-cons -- bool )
69 dup nil?>> not-memoized? [
70 dup original>> nil? [ >>nil? drop ] keep
75 TUPLE: lazy-map cons quot ;
77 C: <lazy-map> lazy-map
79 : lazy-map ( list quot -- result )
80 over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
82 M: lazy-map car ( lazy-map -- car )
84 quot>> call( old -- new ) ;
86 M: lazy-map cdr ( lazy-map -- cdr )
90 M: lazy-map nil? ( lazy-map -- bool )
93 TUPLE: lazy-take n cons ;
95 C: <lazy-take> lazy-take
97 : ltake ( n list -- result )
98 over zero? [ 2drop nil ] [ <lazy-take> ] if ;
100 M: lazy-take car ( lazy-take -- car )
103 M: lazy-take cdr ( lazy-take -- cdr )
107 M: lazy-take nil? ( lazy-take -- bool )
114 TUPLE: lazy-until cons quot ;
116 C: <lazy-until> lazy-until
118 : luntil ( list quot -- result )
119 over nil? [ drop ] [ <lazy-until> ] if ;
121 M: lazy-until car ( lazy-until -- car )
124 M: lazy-until cdr ( lazy-until -- cdr )
125 [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
126 [ 2drop nil ] [ luntil ] if ;
128 M: lazy-until nil? ( lazy-until -- bool )
131 TUPLE: lazy-while cons quot ;
133 C: <lazy-while> lazy-while
135 : lwhile ( list quot -- result )
136 over nil? [ drop ] [ <lazy-while> ] if ;
138 M: lazy-while car ( lazy-while -- car )
141 M: lazy-while cdr ( lazy-while -- cdr )
142 [ cons>> cdr ] keep quot>> lwhile ;
144 M: lazy-while nil? ( lazy-while -- bool )
145 [ car ] keep quot>> call( elt -- ? ) not ;
147 TUPLE: lazy-filter cons quot ;
149 C: <lazy-filter> lazy-filter
151 : lfilter ( list quot -- result )
152 over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
154 : car-filter? ( lazy-filter -- ? )
155 [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
157 : skip ( lazy-filter -- )
158 dup cons>> cdr >>cons drop ;
160 M: lazy-filter car ( lazy-filter -- car )
161 dup car-filter? [ cons>> ] [ dup skip ] if car ;
163 M: lazy-filter cdr ( lazy-filter -- cdr )
165 [ cons>> cdr ] [ quot>> ] bi lfilter
170 M: lazy-filter nil? ( lazy-filter -- bool )
181 : list>vector ( list -- vector )
182 [ [ , ] leach ] V{ } make ;
184 : list>array ( list -- array )
185 [ [ , ] leach ] { } make ;
187 TUPLE: lazy-append list1 list2 ;
189 C: <lazy-append> lazy-append
191 : lappend ( list1 list2 -- result )
192 over nil? [ nip ] [ <lazy-append> ] if ;
194 M: lazy-append car ( lazy-append -- car )
197 M: lazy-append cdr ( lazy-append -- cdr )
201 M: lazy-append nil? ( lazy-append -- bool )
204 TUPLE: lazy-from-by n quot ;
206 C: lfrom-by lazy-from-by
208 : lfrom ( n -- list )
211 M: lazy-from-by car ( lazy-from-by -- car )
214 M: lazy-from-by cdr ( lazy-from-by -- cdr )
216 quot>> [ call( old -- new ) ] keep lfrom-by ;
218 M: lazy-from-by nil? ( lazy-from-by -- bool )
221 TUPLE: lazy-zip list1 list2 ;
223 C: <lazy-zip> lazy-zip
225 : lzip ( list1 list2 -- lazy-zip )
226 over nil? over nil? or
227 [ 2drop nil ] [ <lazy-zip> ] if ;
229 M: lazy-zip car ( lazy-zip -- car )
230 [ list1>> car ] keep list2>> car 2array ;
232 M: lazy-zip cdr ( lazy-zip -- cdr )
233 [ list1>> cdr ] keep list2>> cdr lzip ;
235 M: lazy-zip nil? ( lazy-zip -- bool )
238 TUPLE: sequence-cons index seq ;
240 C: <sequence-cons> sequence-cons
242 : seq>list ( index seq -- list )
249 M: sequence-cons car ( sequence-cons -- car )
253 M: sequence-cons cdr ( sequence-cons -- cdr )
257 M: sequence-cons nil? ( sequence-cons -- bool )
260 : >list ( object -- list )
262 { [ dup sequence? ] [ 0 swap seq>list ] }
263 { [ dup list? ] [ ] }
264 [ "Could not convert object to a list" throw ]
267 TUPLE: lazy-concat car cdr ;
269 C: <lazy-concat> lazy-concat
273 : (lconcat) ( car cdr -- list )
280 : lconcat ( list -- result )
287 M: lazy-concat car ( lazy-concat -- car )
290 M: lazy-concat cdr ( lazy-concat -- cdr )
291 [ car>> cdr ] keep cdr>> (lconcat) ;
293 M: lazy-concat nil? ( lazy-concat -- bool )
300 : lcartesian-product ( list1 list2 -- result )
301 swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ;
303 : lcartesian-product* ( lists -- result )
307 [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
308 swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat
312 : lcomp ( list quot -- result )
313 [ lcartesian-product* ] dip lazy-map ;
315 : lcomp* ( list guards quot -- result )
316 [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
320 : (lmerge) ( list1 list2 -- result )
321 over [ car ] curry -rot
323 dup [ car ] curry -rot
329 : lmerge ( list1 list2 -- result )
331 { [ over nil? ] [ nip ] }
332 { [ dup nil? ] [ drop ] }
333 { [ t ] [ (lmerge) ] }
336 TUPLE: lazy-io stream car cdr quot ;
340 : lcontents ( stream -- result )
341 f f [ stream-read1 ] <lazy-io> ;
343 : llines ( stream -- result )
344 f f [ stream-readln ] <lazy-io> ;
346 M: lazy-io car ( lazy-io -- car )
350 drop dup stream>> over quot>>
351 call( stream -- value )
355 M: lazy-io cdr ( lazy-io -- cdr )
363 [ f f ] dip <lazy-io> [ >>cdr drop ] keep
369 M: lazy-io nil? ( lazy-io -- bool )
372 INSTANCE: sequence-cons list
373 INSTANCE: memoized-cons list
374 INSTANCE: promise list
375 INSTANCE: lazy-io list
376 INSTANCE: lazy-concat list
377 INSTANCE: lazy-cons list
378 INSTANCE: lazy-map list
379 INSTANCE: lazy-take list
380 INSTANCE: lazy-append list
381 INSTANCE: lazy-from-by list
382 INSTANCE: lazy-zip list
383 INSTANCE: lazy-while list
384 INSTANCE: lazy-until list
385 INSTANCE: lazy-filter list