factor/extra/lazy-lists/lazy-lists.factor

446 lines
9.3 KiB
Factor

! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
! Updated by Matthew Willis, July 2006
! Updated by Chris Double, September 2006
!
USING: kernel sequences math vectors arrays namespaces
quotations promises combinators io ;
IN: lazy-lists
! Lazy List Protocol
MIXIN: list
GENERIC: car ( cons -- car )
GENERIC: cdr ( cons -- cdr )
GENERIC: nil? ( cons -- ? )
M: promise car ( promise -- car )
force car ;
M: promise cdr ( promise -- cdr )
force cdr ;
M: promise nil? ( cons -- bool )
force nil? ;
TUPLE: cons car cdr ;
C: cons cons
M: cons car ( cons -- car )
cons-car ;
M: cons cdr ( cons -- cdr )
cons-cdr ;
: nil ( -- cons )
T{ cons f f f } ;
M: cons nil? ( cons -- bool )
nil eq? ;
: 1list ( obj -- cons )
nil cons ;
: 2list ( a b -- cons )
nil cons cons ;
: 3list ( a b c -- cons )
nil cons cons cons ;
! Both 'car' and 'cdr' are promises
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
[ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
M: lazy-cons car ( lazy-cons -- car )
lazy-cons-car force ;
M: lazy-cons cdr ( lazy-cons -- cdr )
lazy-cons-cdr force ;
M: lazy-cons nil? ( lazy-cons -- bool )
nil eq? ;
: 1lazy-list ( a -- lazy-cons )
[ nil ] lazy-cons ;
: 2lazy-list ( a b -- lazy-cons )
1lazy-list 1quotation lazy-cons ;
: 3lazy-list ( a b c -- lazy-cons )
2lazy-list 1quotation lazy-cons ;
: lnth ( n list -- elt )
swap [ cdr ] times car ;
: (llength) ( list acc -- n )
over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
: llength ( list -- n )
0 (llength) ;
: uncons ( cons -- car cdr )
#! Return the car and cdr of the lazy list
dup car swap cdr ;
: leach ( list quot -- )
swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
: lreduce ( list identity quot -- result )
swapd leach ; inline
TUPLE: memoized-cons original car cdr nil? ;
: not-memoized ( -- obj )
{ } ;
: not-memoized? ( obj -- bool )
not-memoized eq? ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car )
dup memoized-cons-car not-memoized? [
dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
] [
memoized-cons-car
] if ;
M: memoized-cons cdr ( memoized-cons -- cdr )
dup memoized-cons-cdr not-memoized? [
dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
] [
memoized-cons-cdr
] if ;
M: memoized-cons nil? ( memoized-cons -- bool )
dup memoized-cons-nil? not-memoized? [
dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
] [
memoized-cons-nil?
] if ;
TUPLE: lazy-map cons quot ;
C: <lazy-map> lazy-map
: lmap ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
M: lazy-map car ( lazy-map -- car )
[ lazy-map-cons car ] keep
lazy-map-quot call ;
M: lazy-map cdr ( lazy-map -- cdr )
[ lazy-map-cons cdr ] keep
lazy-map-quot lmap ;
M: lazy-map nil? ( lazy-map -- bool )
lazy-map-cons nil? ;
: lmap-with ( value list quot -- result )
with lmap ;
TUPLE: lazy-take n cons ;
C: <lazy-take> lazy-take
: ltake ( n list -- result )
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
M: lazy-take car ( lazy-take -- car )
lazy-take-cons car ;
M: lazy-take cdr ( lazy-take -- cdr )
[ lazy-take-n 1- ] keep
lazy-take-cons cdr ltake ;
M: lazy-take nil? ( lazy-take -- bool )
dup lazy-take-n zero? [
drop t
] [
lazy-take-cons nil?
] if ;
TUPLE: lazy-until cons quot ;
C: <lazy-until> lazy-until
: luntil ( list quot -- result )
over nil? [ drop ] [ <lazy-until> ] if ;
M: lazy-until car ( lazy-until -- car )
lazy-until-cons car ;
M: lazy-until cdr ( lazy-until -- cdr )
[ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
[ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- bool )
drop f ;
TUPLE: lazy-while cons quot ;
C: <lazy-while> lazy-while
: lwhile ( list quot -- result )
over nil? [ drop ] [ <lazy-while> ] if ;
M: lazy-while car ( lazy-while -- car )
lazy-while-cons car ;
M: lazy-while cdr ( lazy-while -- cdr )
[ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
M: lazy-while nil? ( lazy-while -- bool )
[ car ] keep lazy-while-quot call not ;
TUPLE: lazy-filter cons quot ;
C: <lazy-filter> lazy-filter
: lfilter ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
: car-filter? ( lazy-filter -- ? )
[ lazy-filter-cons car ] keep
lazy-filter-quot call ;
: skip ( lazy-filter -- )
[ lazy-filter-cons cdr ] keep
set-lazy-filter-cons ;
M: lazy-filter car ( lazy-filter -- car )
dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
M: lazy-filter cdr ( lazy-filter -- cdr )
dup car-filter? [
[ lazy-filter-cons cdr ] keep
lazy-filter-quot lfilter
] [
dup skip cdr
] if ;
M: lazy-filter nil? ( lazy-filter -- bool )
dup lazy-filter-cons nil? [
drop t
] [
dup car-filter? [
drop f
] [
dup skip nil?
] if
] if ;
: list>vector ( list -- vector )
[ [ , ] leach ] V{ } make ;
: list>array ( list -- array )
[ [ , ] leach ] { } make ;
TUPLE: lazy-append list1 list2 ;
C: <lazy-append> lazy-append
: lappend ( list1 list2 -- result )
over nil? [ nip ] [ <lazy-append> ] if ;
M: lazy-append car ( lazy-append -- car )
lazy-append-list1 car ;
M: lazy-append cdr ( lazy-append -- cdr )
[ lazy-append-list1 cdr ] keep
lazy-append-list2 lappend ;
M: lazy-append nil? ( lazy-append -- bool )
drop f ;
TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list )
: lfrom ( n -- list )
[ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
lazy-from-by-n ;
M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ lazy-from-by-n ] keep
lazy-from-by-quot dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool )
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 ;
M: lazy-zip car ( lazy-zip -- car )
[ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
M: lazy-zip cdr ( lazy-zip -- cdr )
[ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
M: lazy-zip nil? ( lazy-zip -- bool )
drop f ;
TUPLE: sequence-cons index seq ;
C: <sequence-cons> sequence-cons
: seq>list ( index seq -- list )
2dup length >= [
2drop nil
] [
<sequence-cons>
] if ;
M: sequence-cons car ( sequence-cons -- car )
[ sequence-cons-index ] keep
sequence-cons-seq nth ;
M: sequence-cons cdr ( sequence-cons -- cdr )
[ sequence-cons-index 1+ ] keep
sequence-cons-seq seq>list ;
M: sequence-cons nil? ( sequence-cons -- bool )
drop f ;
: >list ( object -- list )
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] }
[ "Could not convert object to a list" throw ]
} cond ;
TUPLE: lazy-concat car cdr ;
C: <lazy-concat> lazy-concat
DEFER: lconcat
: (lconcat) ( car cdr -- list )
over nil? [
nip lconcat
] [
<lazy-concat>
] if ;
: lconcat ( list -- result )
dup nil? [
drop nil
] [
uncons (lconcat)
] if ;
M: lazy-concat car ( lazy-concat -- car )
lazy-concat-car car ;
M: lazy-concat cdr ( lazy-concat -- cdr )
[ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
M: lazy-concat nil? ( lazy-concat -- bool )
dup lazy-concat-car nil? [
lazy-concat-cdr nil?
] [
drop f
] if ;
: lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
: lcartesian-product* ( lists -- result )
dup nil? [
drop nil
] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
] reduce
] if ;
: lcomp ( list quot -- result )
[ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result )
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
DEFER: lmerge
: (lmerge) ( list1 list2 -- result )
over [ car ] curry -rot
[
dup [ car ] curry -rot
[
[ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
: lmerge ( list1 list2 -- result )
{
{ [ over nil? ] [ nip ] }
{ [ dup nil? ] [ drop ] }
{ [ t ] [ (lmerge) ] }
} cond ;
TUPLE: lazy-io stream car cdr quot ;
C: <lazy-io> lazy-io
: lcontents ( stream -- result )
f f [ stream-read1 ] <lazy-io> ;
: llines ( stream -- result )
f f [ stream-readln ] <lazy-io> ;
M: lazy-io car ( lazy-io -- car )
dup lazy-io-car dup [
nip
] [
drop dup lazy-io-stream over lazy-io-quot call
swap dupd set-lazy-io-car
] if ;
M: lazy-io cdr ( lazy-io -- cdr )
dup lazy-io-cdr dup [
nip
] [
drop dup
[ lazy-io-stream ] keep
[ lazy-io-quot ] keep
car [
[ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
] [
3drop nil
] if
] if ;
M: lazy-io nil? ( lazy-io -- bool )
car not ;
INSTANCE: cons list
INSTANCE: sequence-cons list
INSTANCE: memoized-cons list
INSTANCE: promise list
INSTANCE: lazy-io list
INSTANCE: lazy-concat list
INSTANCE: lazy-cons list
INSTANCE: lazy-map list
INSTANCE: lazy-take list
INSTANCE: lazy-append list
INSTANCE: lazy-from-by list
INSTANCE: lazy-zip list
INSTANCE: lazy-while list
INSTANCE: lazy-until list
INSTANCE: lazy-filter list