ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists"
"The following combinators create lazy lists from other lazy lists:"
{ $subsections
- lazy-map
+ lmap-lazy
lfilter
luntil
lwhile
"To make new lazy lists from old ones:"
{ $subsections
<memoized-cons>
- lappend
+ lappend-lazy
lconcat
lcartesian-product
lcartesian-product*
{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
{ $see-also cons car cdr nil nil? } ;
-{ lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+{ lmap-lazy ltake lfilter lappend-lazy lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
-HELP: lazy-map
+HELP: lmap-lazy
{ $values { "list" "a cons object" } { "quot" { $quotation ( obj -- X ) } } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map-state> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link lazy-map } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: ltake
{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link lazy-take } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lfilter
{ $values { "list" "a cons object" } { "quot" { $quotation ( -- X ) } } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link lazy-filter } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lwhile
{ $values { "list" "a cons object" } { "quot" { $quotation ( x -- ? ) } } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link lazy-while } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: luntil
{ $values { "list" "a cons object" } { "quot" { $quotation ( x -- ? ) } } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link lazy-while } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-HELP: lappend
+HELP: lappend-lazy
{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
-{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
+{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link lazy-append } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
HELP: lfrom-by
{ $values { "n" integer } { "quot" { $quotation ( n -- o ) } } { "lazy-from-by" "a lazy list of integers" } }
{ $description "Convert the sequence into a list, starting from " { $snippet "index" } "." }
{ $see-also >list } ;
-{ leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+{ leach foldl lmap-lazy ltake lfilter lappend-lazy lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
HELP: lconcat
{ $values { "list" "a list of lists" } { "result" "a list" } }
promises quotations sequences ;
IN: lists.lazy
-M: promise car ( promise -- car )
- force car ;
+M: promise car force car ;
-M: promise cdr ( promise -- cdr )
- force cdr ;
+M: promise cdr force cdr ;
-M: promise nil? ( cons -- ? )
- force nil? ;
+M: promise nil? force nil? ;
-! Both 'car' and 'cdr' are promises
-TUPLE: lazy-cons-state car cdr ;
+TUPLE: lazy-cons-state
+ { car promise }
+ { cdr promise } ;
+
+C: <lazy-cons-state> lazy-cons-state
: lazy-cons ( car cdr -- promise )
- [ T{ promise f f t f } clone ] 2dip
- [ <promise> ] bi@ \ lazy-cons-state boa
- >>value ;
+ [ <promise> ] bi@ <lazy-cons-state>
+ [ f t ] dip promise boa ;
-M: lazy-cons-state car ( lazy-cons -- car )
- car>> force ;
+M: lazy-cons-state car car>> force ;
-M: lazy-cons-state cdr ( lazy-cons -- cdr )
- cdr>> force ;
+M: lazy-cons-state cdr cdr>> force ;
-M: lazy-cons-state nil? ( lazy-cons -- ? )
- nil eq? ;
+M: lazy-cons-state nil? nil eq? ;
: 1lazy-list ( a -- lazy-cons )
[ nil ] lazy-cons ;
TUPLE: memoized-cons original car cdr nil? ;
-: not-memoized ( -- obj ) { } ;
-
-: not-memoized? ( obj -- ? ) not-memoized eq? ;
+SYMBOL: +not-memoized+
: <memoized-cons> ( cons -- memoized-cons )
- not-memoized not-memoized not-memoized
+ +not-memoized+ +not-memoized+ +not-memoized+
memoized-cons boa ;
-M: memoized-cons car ( memoized-cons -- car )
- dup car>> not-memoized? [
+M: memoized-cons car
+ dup car>> +not-memoized+ eq? [
dup original>> car [ >>car drop ] keep
] [
car>>
] if ;
-M: memoized-cons cdr ( memoized-cons -- cdr )
- dup cdr>> not-memoized? [
+M: memoized-cons cdr
+ dup cdr>> +not-memoized+ eq? [
dup original>> cdr [ >>cdr drop ] keep
] [
cdr>>
] if ;
-M: memoized-cons nil? ( memoized-cons -- ? )
- dup nil?>> not-memoized? [
- dup original>> nil? [ >>nil? drop ] keep
+M: memoized-cons nil?
+ dup nil?>> +not-memoized+ eq? [
+ dup original>> nil? [ >>nil? drop ] keep
] [
nil?>>
] if ;
-TUPLE: lazy-map-state cons quot ;
+TUPLE: lazy-map cons quot ;
-C: <lazy-map-state> lazy-map-state
+C: <lazy-map> lazy-map
-: lazy-map ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-map-state> <memoized-cons> ] if ;
+: lmap-lazy ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
-M: lazy-map-state car ( lazy-map -- car )
+M: lazy-map car
[ cons>> car ] [ quot>> call( old -- new ) ] bi ;
-M: lazy-map-state cdr ( lazy-map -- cdr )
- [ cons>> cdr ] [ quot>> lazy-map ] bi ;
+M: lazy-map cdr
+ [ cons>> cdr ] [ quot>> lmap-lazy ] bi ;
-M: lazy-map-state nil? ( lazy-map -- ? )
+M: lazy-map nil?
cons>> nil? ;
TUPLE: lazy-take n cons ;
: ltake ( n list -- result )
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
-M: lazy-take car ( lazy-take -- car )
+M: lazy-take car
cons>> car ;
-M: lazy-take cdr ( lazy-take -- cdr )
- [ n>> 1 - ] keep
- cons>> cdr ltake ;
+M: lazy-take cdr
+ [ n>> 1 - ] [ cons>> cdr ltake ] bi ;
-M: lazy-take nil? ( lazy-take -- ? )
+M: lazy-take nil?
dup n>> zero? [ drop t ] [ cons>> nil? ] if ;
TUPLE: lazy-until cons quot ;
: luntil ( list quot -- result )
over nil? [ drop ] [ <lazy-until> ] if ;
-M: lazy-until car ( lazy-until -- car )
+M: lazy-until car
cons>> car ;
-M: lazy-until cdr ( lazy-until -- cdr )
+M: lazy-until cdr
[ [ cons>> cdr ] [ quot>> ] bi ]
[ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ] bi
[ 2drop nil ] [ luntil ] if ;
-M: lazy-until nil? ( lazy-until -- ? )
+M: lazy-until nil?
drop f ;
TUPLE: lazy-while cons quot ;
: lwhile ( list quot -- result )
over nil? [ drop ] [ <lazy-while> ] if ;
-M: lazy-while car ( lazy-while -- car )
+M: lazy-while car
cons>> car ;
-M: lazy-while cdr ( lazy-while -- cdr )
+M: lazy-while cdr
[ cons>> cdr ] keep quot>> lwhile ;
-M: lazy-while nil? ( lazy-while -- ? )
+M: lazy-while nil?
[ car ] keep quot>> call( elt -- ? ) not ;
TUPLE: lazy-filter cons quot ;
: lfilter ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
+<PRIVATE
+
: car-filter? ( lazy-filter -- ? )
[ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
: skip ( lazy-filter -- )
dup cons>> cdr >>cons drop ;
-M: lazy-filter car ( lazy-filter -- car )
+PRIVATE>
+
+M: lazy-filter car
dup car-filter? [ cons>> ] [ dup skip ] if car ;
-M: lazy-filter cdr ( lazy-filter -- cdr )
+M: lazy-filter cdr
dup car-filter? [
[ cons>> cdr ] [ quot>> ] bi lfilter
] [
dup skip cdr
] if ;
-M: lazy-filter nil? ( lazy-filter -- ? )
- dup cons>> nil? [
- drop t
- ] [
- dup car-filter? [
- drop f
- ] [
- dup skip nil?
- ] if
- ] if ;
+M: lazy-filter nil?
+ {
+ { [ dup cons>> nil? ] [ drop t ] }
+ { [ dup car-filter? ] [ drop f ] }
+ [ dup skip nil? ]
+ } cond ;
TUPLE: lazy-append list1 list2 ;
C: <lazy-append> lazy-append
-: lappend ( list1 list2 -- result )
+: lappend-lazy ( list1 list2 -- result )
over nil? [ nip ] [ <lazy-append> ] if ;
-M: lazy-append car ( lazy-append -- car )
+M: lazy-append car
list1>> car ;
-M: lazy-append cdr ( lazy-append -- cdr )
- [ list1>> cdr ] [ list2>> ] bi lappend ;
+M: lazy-append cdr
+ [ list1>> cdr ] [ list2>> ] bi lappend-lazy ;
-M: lazy-append nil? ( lazy-append -- ? )
+M: lazy-append nil?
drop f ;
TUPLE: lazy-from-by n quot ;
: lfrom ( n -- list )
[ 1 + ] lfrom-by ;
-M: lazy-from-by car ( lazy-from-by -- car )
+M: lazy-from-by car
n>> ;
-M: lazy-from-by cdr ( lazy-from-by -- cdr )
- [ n>> ] keep
- quot>> [ call( old -- new ) ] keep lfrom-by ;
+M: lazy-from-by cdr
+ [ n>> ] [ quot>> ] bi [ call( old -- new ) ] keep lfrom-by ;
-M: lazy-from-by nil? ( lazy-from-by -- ? )
+M: lazy-from-by nil?
drop f ;
TUPLE: lazy-zip list1 list2 ;
C: <lazy-zip> lazy-zip
: lzip ( list1 list2 -- lazy-zip )
- over nil? over nil? or
- [ 2drop nil ] [ <lazy-zip> ] if ;
+ over nil? over nil? or
+ [ 2drop nil ] [ <lazy-zip> ] if ;
-M: lazy-zip car ( lazy-zip -- car )
- [ list1>> car ] keep list2>> car 2array ;
+M: lazy-zip car
+ [ list1>> car ] keep list2>> car 2array ;
-M: lazy-zip cdr ( lazy-zip -- cdr )
- [ list1>> cdr ] keep list2>> cdr lzip ;
+M: lazy-zip cdr
+ [ list1>> cdr ] keep list2>> cdr lzip ;
-M: lazy-zip nil? ( lazy-zip -- ? )
- drop f ;
+M: lazy-zip nil?
+ drop f ;
TUPLE: sequence-cons index seq ;
<sequence-cons>
] if ;
-M: sequence-cons car ( sequence-cons -- car )
+M: sequence-cons car
[ index>> ] [ seq>> nth ] bi ;
-M: sequence-cons cdr ( sequence-cons -- cdr )
+M: sequence-cons cdr
[ index>> 1 + ] [ seq>> sequence-tail>list ] bi ;
-M: sequence-cons nil? ( sequence-cons -- ? )
+M: sequence-cons nil?
drop f ;
M: sequence >list 0 swap sequence-tail>list ;
: lconcat ( list -- result )
dup nil? [ drop nil ] [ uncons (lconcat) ] if ;
-M: lazy-concat car ( lazy-concat -- car )
+M: lazy-concat car
car>> car ;
-M: lazy-concat cdr ( lazy-concat -- cdr )
+M: lazy-concat cdr
[ car>> cdr ] keep cdr>> (lconcat) ;
-M: lazy-concat nil? ( lazy-concat -- ? )
+M: lazy-concat nil?
dup car>> nil? [ cdr>> nil? ] [ drop f ] if ;
: lcartesian-product ( list1 list2 -- result )
- swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ;
+ swap [ swap [ 2array ] with lmap-lazy ] with lmap-lazy lconcat ;
: lcartesian-product* ( lists -- result )
dup nil? [
uncons
[ car lcartesian-product ] [ cdr ] bi
list>array swap [
- swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat
+ swap [ swap [ suffix ] with lmap-lazy ] with lmap-lazy lconcat
] reduce
] if ;
: lcomp ( list quot -- result )
- [ lcartesian-product* ] dip lazy-map ;
+ [ lcartesian-product* ] dip lmap-lazy ;
: lcomp* ( list guards quot -- result )
- [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
+ [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap-lazy ;
DEFER: lmerge
: llines ( stream -- result )
f f [ stream-readln ] <lazy-io> ;
-M: lazy-io car ( lazy-io -- car )
+M: lazy-io car
dup car>> [
nip
] [
call( stream -- value ) [ >>car ] [ drop nil ] if*
] if* ;
-M: lazy-io cdr ( lazy-io -- cdr )
+M: lazy-io cdr
dup cdr>> dup [
nip
] [
- drop dup
- [ stream>> ]
- [ quot>> ]
- [ car ] tri [
+ drop dup [ stream>> ] [ quot>> ] [ car ] tri
+ [
[ f f ] dip <lazy-io> [ >>cdr drop ] keep
] [
3drop nil
] if
] if ;
-M: lazy-io nil? ( lazy-io -- ? )
+M: lazy-io nil?
car nil? ;
INSTANCE: sequence-cons list
INSTANCE: lazy-io list
INSTANCE: lazy-concat list
INSTANCE: lazy-cons-state list
-INSTANCE: lazy-map-state list
+INSTANCE: lazy-map list
INSTANCE: lazy-take list
INSTANCE: lazy-append list
INSTANCE: lazy-from-by list
projects / factor.git / commitdiff