1 ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators io kernel lists math
4 promises quotations sequences summary vectors ;
7 M: promise car ( promise -- car )
10 M: promise cdr ( promise -- cdr )
13 M: promise nil? ( cons -- ? )
16 ! Both 'car' and 'cdr' are promises
17 TUPLE: lazy-cons car cdr ;
19 : lazy-cons ( car cdr -- promise )
20 [ T{ promise f f t f } clone ] 2dip
21 [ promise ] bi@ \ lazy-cons boa
24 M: lazy-cons car ( lazy-cons -- car )
27 M: lazy-cons cdr ( lazy-cons -- cdr )
30 M: lazy-cons nil? ( lazy-cons -- ? )
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 ) { } ;
46 : not-memoized? ( obj -- ? ) not-memoized eq? ;
48 : <memoized-cons> ( cons -- memoized-cons )
49 not-memoized not-memoized not-memoized
52 M: memoized-cons car ( memoized-cons -- car )
53 dup car>> not-memoized? [
54 dup original>> car [ >>car drop ] keep
59 M: memoized-cons cdr ( memoized-cons -- cdr )
60 dup cdr>> not-memoized? [
61 dup original>> cdr [ >>cdr drop ] keep
66 M: memoized-cons nil? ( memoized-cons -- ? )
67 dup nil?>> not-memoized? [
68 dup original>> nil? [ >>nil? drop ] keep
73 TUPLE: lazy-map cons quot ;
75 C: <lazy-map> lazy-map
77 : lazy-map ( list quot -- result )
78 over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
80 M: lazy-map car ( lazy-map -- car )
81 [ cons>> car ] [ quot>> call( old -- new ) ] bi ;
83 M: lazy-map cdr ( lazy-map -- cdr )
84 [ cons>> cdr ] [ quot>> lazy-map ] bi ;
86 M: lazy-map nil? ( lazy-map -- ? )
89 TUPLE: lazy-take n cons ;
91 C: <lazy-take> lazy-take
93 : ltake ( n list -- result )
94 over zero? [ 2drop nil ] [ <lazy-take> ] if ;
96 M: lazy-take car ( lazy-take -- car )
99 M: lazy-take cdr ( lazy-take -- cdr )
103 M: lazy-take nil? ( lazy-take -- ? )
104 dup n>> zero? [ drop t ] [ cons>> nil? ] if ;
106 TUPLE: lazy-until cons quot ;
108 C: <lazy-until> lazy-until
110 : luntil ( list quot -- result )
111 over nil? [ drop ] [ <lazy-until> ] if ;
113 M: lazy-until car ( lazy-until -- car )
116 M: lazy-until cdr ( lazy-until -- cdr )
117 [ [ cons>> cdr ] [ quot>> ] bi ]
118 [ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ] bi
119 [ 2drop nil ] [ luntil ] if ;
121 M: lazy-until nil? ( lazy-until -- ? )
124 TUPLE: lazy-while cons quot ;
126 C: <lazy-while> lazy-while
128 : lwhile ( list quot -- result )
129 over nil? [ drop ] [ <lazy-while> ] if ;
131 M: lazy-while car ( lazy-while -- car )
134 M: lazy-while cdr ( lazy-while -- cdr )
135 [ cons>> cdr ] keep quot>> lwhile ;
137 M: lazy-while nil? ( lazy-while -- ? )
138 [ car ] keep quot>> call( elt -- ? ) not ;
140 TUPLE: lazy-filter cons quot ;
142 C: <lazy-filter> lazy-filter
144 : lfilter ( list quot -- result )
145 over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
147 : car-filter? ( lazy-filter -- ? )
148 [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
150 : skip ( lazy-filter -- )
151 dup cons>> cdr >>cons drop ;
153 M: lazy-filter car ( lazy-filter -- car )
154 dup car-filter? [ cons>> ] [ dup skip ] if car ;
156 M: lazy-filter cdr ( lazy-filter -- cdr )
158 [ cons>> cdr ] [ quot>> ] bi lfilter
163 M: lazy-filter nil? ( lazy-filter -- ? )
174 TUPLE: lazy-append list1 list2 ;
176 C: <lazy-append> lazy-append
178 : lappend ( list1 list2 -- result )
179 over nil? [ nip ] [ <lazy-append> ] if ;
181 M: lazy-append car ( lazy-append -- car )
184 M: lazy-append cdr ( lazy-append -- cdr )
185 [ list1>> cdr ] [ list2>> ] bi lappend ;
187 M: lazy-append nil? ( lazy-append -- ? )
190 TUPLE: lazy-from-by n quot ;
192 C: lfrom-by lazy-from-by
194 : lfrom ( n -- list )
197 M: lazy-from-by car ( lazy-from-by -- car )
200 M: lazy-from-by cdr ( lazy-from-by -- cdr )
202 quot>> [ call( old -- new ) ] keep lfrom-by ;
204 M: lazy-from-by nil? ( lazy-from-by -- ? )
207 TUPLE: lazy-zip list1 list2 ;
209 C: <lazy-zip> lazy-zip
211 : lzip ( list1 list2 -- lazy-zip )
212 over nil? over nil? or
213 [ 2drop nil ] [ <lazy-zip> ] if ;
215 M: lazy-zip car ( lazy-zip -- car )
216 [ list1>> car ] keep list2>> car 2array ;
218 M: lazy-zip cdr ( lazy-zip -- cdr )
219 [ list1>> cdr ] keep list2>> cdr lzip ;
221 M: lazy-zip nil? ( lazy-zip -- ? )
224 TUPLE: sequence-cons index seq ;
226 C: <sequence-cons> sequence-cons
228 : sequence-tail>list ( index seq -- list )
235 M: sequence-cons car ( sequence-cons -- car )
236 [ index>> ] [ seq>> nth ] bi ;
238 M: sequence-cons cdr ( sequence-cons -- cdr )
239 [ index>> 1 + ] [ seq>> sequence-tail>list ] bi ;
241 M: sequence-cons nil? ( sequence-cons -- ? )
244 ERROR: list-conversion-error object ;
246 M: list-conversion-error summary
247 drop "Could not convert object to list" ;
249 : >list ( object -- list )
251 { [ dup sequence? ] [ 0 swap sequence-tail>list ] }
252 { [ dup list? ] [ ] }
253 [ list-conversion-error ]
256 TUPLE: lazy-concat car cdr ;
258 C: <lazy-concat> lazy-concat
262 : (lconcat) ( car cdr -- list )
263 over nil? [ nip lconcat ] [ <lazy-concat> ] if ;
265 : lconcat ( list -- result )
266 dup nil? [ drop nil ] [ uncons (lconcat) ] if ;
268 M: lazy-concat car ( lazy-concat -- car )
271 M: lazy-concat cdr ( lazy-concat -- cdr )
272 [ car>> cdr ] keep cdr>> (lconcat) ;
274 M: lazy-concat nil? ( lazy-concat -- ? )
275 dup car>> nil? [ cdr>> nil? ] [ drop f ] if ;
277 : lcartesian-product ( list1 list2 -- result )
278 swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ;
280 : lcartesian-product* ( lists -- result )
285 [ car lcartesian-product ] [ cdr ] bi
287 swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat
291 : lcomp ( list quot -- result )
292 [ lcartesian-product* ] dip lazy-map ;
294 : lcomp* ( list guards quot -- result )
295 [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
299 : (lmerge) ( list1 list2 -- result )
300 over [ car ] curry -rot
302 dup [ car ] curry -rot
308 : lmerge ( list1 list2 -- result )
310 { [ over nil? ] [ nip ] }
311 { [ dup nil? ] [ drop ] }
312 { [ t ] [ (lmerge) ] }
315 TUPLE: lazy-io stream car cdr quot ;
319 : lcontents ( stream -- result )
320 f f [ stream-read1 ] <lazy-io> ;
322 : llines ( stream -- result )
323 f f [ stream-readln ] <lazy-io> ;
325 M: lazy-io car ( lazy-io -- car )
329 [ ] [ stream>> ] [ quot>> ] tri
330 call( stream -- value ) [ >>car ] [ drop nil ] if*
333 M: lazy-io cdr ( lazy-io -- cdr )
341 [ f f ] dip <lazy-io> [ >>cdr drop ] keep
347 M: lazy-io nil? ( lazy-io -- ? )
350 INSTANCE: sequence-cons list
351 INSTANCE: memoized-cons list
352 INSTANCE: promise list
353 INSTANCE: lazy-io list
354 INSTANCE: lazy-concat list
355 INSTANCE: lazy-cons list
356 INSTANCE: lazy-map list
357 INSTANCE: lazy-take list
358 INSTANCE: lazy-append list
359 INSTANCE: lazy-from-by list
360 INSTANCE: lazy-zip list
361 INSTANCE: lazy-while list
362 INSTANCE: lazy-until list
363 INSTANCE: lazy-filter list