steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Changing indentation from 2 spaces to 4

db4
James Cash 2008-06-03 03:42:13 -04:00
parent 5361928f15
commit 684dde97df
1 changed files with 166 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

330
extra/lazy-lists/lazy-lists.factor
View File

@ -9,13 +9,13 @@ quotations promises combinators io lists accessors ;
IN: lazy-lists IN: lazy-lists
M: promise car ( promise -- car ) M: promise car ( promise -- car )
force car ; force car ;
M: promise cdr ( promise -- cdr ) M: promise cdr ( promise -- cdr )
force cdr ; force cdr ;
M: promise nil? ( cons -- bool ) M: promise nil? ( cons -- bool )
force nil? ; force nil? ;
! Both 'car' and 'cdr' are promises ! Both 'car' and 'cdr' are promises
TUPLE: lazy-cons car cdr ; TUPLE: lazy-cons car cdr ;
@ -35,258 +35,258 @@ M: lazy-cons nil? ( lazy-cons -- bool )
nil eq? ; nil eq? ;
: 1lazy-list ( a -- lazy-cons ) : 1lazy-list ( a -- lazy-cons )
[ nil ] lazy-cons ; [ nil ] lazy-cons ;
: 2lazy-list ( a b -- lazy-cons ) : 2lazy-list ( a b -- lazy-cons )
1lazy-list 1quotation lazy-cons ; 1lazy-list 1quotation lazy-cons ;
: 3lazy-list ( a b c -- lazy-cons ) : 3lazy-list ( a b c -- lazy-cons )
2lazy-list 1quotation lazy-cons ; 2lazy-list 1quotation lazy-cons ;
: lnth ( n list -- elt ) : lnth ( n list -- elt )
swap [ cdr ] times car ; swap [ cdr ] times car ;
: (llength) ( list acc -- n ) : (llength) ( list acc -- n )
over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
: llength ( list -- n ) : llength ( list -- n )
0 (llength) ; 0 (llength) ;
: leach ( list quot -- ) : leach ( list quot -- )
over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline
: lreduce ( list identity quot -- result ) : lreduce ( list identity quot -- result )
swapd leach ; inline swapd leach ; inline
TUPLE: memoized-cons original car cdr nil? ; TUPLE: memoized-cons original car cdr nil? ;
: not-memoized ( -- obj ) : not-memoized ( -- obj )
{ } ; { } ;
: not-memoized? ( obj -- bool ) : not-memoized? ( obj -- bool )
not-memoized eq? ; not-memoized eq? ;
: <memoized-cons> ( cons -- memoized-cons ) : <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized not-memoized not-memoized not-memoized
memoized-cons boa ; memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car ) M: memoized-cons car ( memoized-cons -- car )
dup car>> not-memoized? [ dup car>> not-memoized? [
dup original>> car [ >>car drop ] keep dup original>> car [ >>car drop ] keep
] [ ] [
car>> car>>
] if ; ] if ;
M: memoized-cons cdr ( memoized-cons -- cdr ) M: memoized-cons cdr ( memoized-cons -- cdr )
dup cdr>> not-memoized? [ dup cdr>> not-memoized? [
dup original>> cdr [ >>cdr drop ] keep dup original>> cdr [ >>cdr drop ] keep
] [ ] [
cdr>> cdr>>
] if ; ] if ;
M: memoized-cons nil? ( memoized-cons -- bool ) M: memoized-cons nil? ( memoized-cons -- bool )
dup nil?>> not-memoized? [ dup nil?>> not-memoized? [
dup original>> nil? [ >>nil? drop ] keep dup original>> nil? [ >>nil? drop ] keep
] [ ] [
nil?>> nil?>>
] if ; ] if ;
TUPLE: lazy-map cons quot ; TUPLE: lazy-map cons quot ;
C: <lazy-map> lazy-map C: <lazy-map> lazy-map
: lmap ( list quot -- result ) : lmap ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ; over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
M: lazy-map car ( lazy-map -- car ) M: lazy-map car ( lazy-map -- car )
[ cons>> car ] keep [ cons>> car ] keep
quot>> call ; quot>> call ;
M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map cdr ( lazy-map -- cdr )
[ cons>> cdr ] keep [ cons>> cdr ] keep
quot>> lmap ; quot>> lmap ;
M: lazy-map nil? ( lazy-map -- bool ) M: lazy-map nil? ( lazy-map -- bool )
cons>> nil? ; cons>> nil? ;
: lmap-with ( value list quot -- result ) : lmap-with ( value list quot -- result )
with lmap ; with lmap ;
TUPLE: lazy-take n cons ; TUPLE: lazy-take n cons ;
C: <lazy-take> lazy-take C: <lazy-take> lazy-take
: ltake ( n list -- result ) : ltake ( n list -- result )
over zero? [ 2drop nil ] [ <lazy-take> ] if ; over zero? [ 2drop nil ] [ <lazy-take> ] if ;
M: lazy-take car ( lazy-take -- car ) M: lazy-take car ( lazy-take -- car )
cons>> car ; cons>> car ;
M: lazy-take cdr ( lazy-take -- cdr ) M: lazy-take cdr ( lazy-take -- cdr )
[ n>> 1- ] keep [ n>> 1- ] keep
cons>> cdr ltake ; cons>> cdr ltake ;
M: lazy-take nil? ( lazy-take -- bool ) M: lazy-take nil? ( lazy-take -- bool )
dup n>> zero? [ dup n>> zero? [
drop t drop t
] [ ] [
cons>> nil? cons>> nil?
] if ; ] if ;
TUPLE: lazy-until cons quot ; TUPLE: lazy-until cons quot ;
C: <lazy-until> lazy-until C: <lazy-until> lazy-until
: luntil ( list quot -- result ) : luntil ( list quot -- result )
over nil? [ drop ] [ <lazy-until> ] if ; over nil? [ drop ] [ <lazy-until> ] if ;
M: lazy-until car ( lazy-until -- car ) M: lazy-until car ( lazy-until -- car )
cons>> car ; cons>> car ;
M: lazy-until cdr ( lazy-until -- cdr ) M: lazy-until cdr ( lazy-until -- cdr )
[ cons>> uncons ] keep quot>> tuck call [ cons>> uncons ] keep quot>> tuck call
[ 2drop nil ] [ luntil ] if ; [ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- bool ) M: lazy-until nil? ( lazy-until -- bool )
drop f ; drop f ;
TUPLE: lazy-while cons quot ; TUPLE: lazy-while cons quot ;
C: <lazy-while> lazy-while C: <lazy-while> lazy-while
: lwhile ( list quot -- result ) : lwhile ( list quot -- result )
over nil? [ drop ] [ <lazy-while> ] if ; over nil? [ drop ] [ <lazy-while> ] if ;
M: lazy-while car ( lazy-while -- car ) M: lazy-while car ( lazy-while -- car )
cons>> car ; cons>> car ;
M: lazy-while cdr ( lazy-while -- cdr ) M: lazy-while cdr ( lazy-while -- cdr )
[ cons>> cdr ] keep quot>> lwhile ; [ cons>> cdr ] keep quot>> lwhile ;
M: lazy-while nil? ( lazy-while -- bool ) M: lazy-while nil? ( lazy-while -- bool )
[ car ] keep quot>> call not ; [ car ] keep quot>> call not ;
TUPLE: lazy-filter cons quot ; TUPLE: lazy-filter cons quot ;
C: <lazy-filter> lazy-filter C: <lazy-filter> lazy-filter
: lfilter ( list quot -- result ) : lfilter ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ; over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
: car-filter? ( lazy-filter -- ? ) : car-filter? ( lazy-filter -- ? )
[ cons>> car ] keep [ cons>> car ] keep
quot>> call ; quot>> call ;
: skip ( lazy-filter -- ) : skip ( lazy-filter -- )
dup cons>> cdr >>cons ; dup cons>> cdr >>cons ;
M: lazy-filter car ( lazy-filter -- car ) M: lazy-filter car ( lazy-filter -- car )
dup car-filter? [ cons>> ] [ dup skip ] if car ; dup car-filter? [ cons>> ] [ dup skip ] if car ;
M: lazy-filter cdr ( lazy-filter -- cdr ) M: lazy-filter cdr ( lazy-filter -- cdr )
dup car-filter? [ dup car-filter? [
[ cons>> cdr ] keep [ cons>> cdr ] keep
quot>> lfilter quot>> lfilter
] [ ] [
dup skip cdr dup skip cdr
] if ; ] if ;
M: lazy-filter nil? ( lazy-filter -- bool ) M: lazy-filter nil? ( lazy-filter -- bool )
dup cons>> nil? [ dup cons>> nil? [
drop t drop t
] [
dup car-filter? [
drop f
] [ ] [
dup skip nil? dup car-filter? [
] if drop f
] if ; ] [
dup skip nil?
] if
] if ;
: list>vector ( list -- vector ) : list>vector ( list -- vector )
[ [ , ] leach ] V{ } make ; [ [ , ] leach ] V{ } make ;
: list>array ( list -- array ) : list>array ( list -- array )
[ [ , ] leach ] { } make ; [ [ , ] leach ] { } make ;
TUPLE: lazy-append list1 list2 ; TUPLE: lazy-append list1 list2 ;
C: <lazy-append> lazy-append C: <lazy-append> lazy-append
: lappend ( list1 list2 -- result ) : lappend ( list1 list2 -- result )
over nil? [ nip ] [ <lazy-append> ] if ; over nil? [ nip ] [ <lazy-append> ] if ;
M: lazy-append car ( lazy-append -- car ) M: lazy-append car ( lazy-append -- car )
list1>> car ; list1>> car ;
M: lazy-append cdr ( lazy-append -- cdr ) M: lazy-append cdr ( lazy-append -- cdr )
[ list1>> cdr ] keep [ list1>> cdr ] keep
list2>> lappend ; list2>> lappend ;
M: lazy-append nil? ( lazy-append -- bool ) M: lazy-append nil? ( lazy-append -- bool )
drop f ; drop f ;
TUPLE: lazy-from-by n quot ; TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list ) C: lfrom-by lazy-from-by ( n quot -- list )
: lfrom ( n -- list ) : lfrom ( n -- list )
[ 1+ ] lfrom-by ; [ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by car ( lazy-from-by -- car )
n>> ; n>> ;
M: lazy-from-by cdr ( lazy-from-by -- cdr ) M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ n>> ] keep [ n>> ] keep
quot>> dup slip lfrom-by ; quot>> dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool ) M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ; drop f ;
TUPLE: lazy-zip list1 list2 ; TUPLE: lazy-zip list1 list2 ;
C: <lazy-zip> lazy-zip C: <lazy-zip> lazy-zip
: lzip ( list1 list2 -- lazy-zip ) : lzip ( list1 list2 -- lazy-zip )
over nil? over nil? or over nil? over nil? or
[ 2drop nil ] [ <lazy-zip> ] if ; [ 2drop nil ] [ <lazy-zip> ] if ;
M: lazy-zip car ( lazy-zip -- car ) M: lazy-zip car ( lazy-zip -- car )
[ list1>> car ] keep list2>> car 2array ; [ list1>> car ] keep list2>> car 2array ;
M: lazy-zip cdr ( lazy-zip -- cdr ) M: lazy-zip cdr ( lazy-zip -- cdr )
[ list1>> cdr ] keep list2>> cdr lzip ; [ list1>> cdr ] keep list2>> cdr lzip ;
M: lazy-zip nil? ( lazy-zip -- bool ) M: lazy-zip nil? ( lazy-zip -- bool )
drop f ; drop f ;
TUPLE: sequence-cons index seq ; TUPLE: sequence-cons index seq ;
C: <sequence-cons> sequence-cons C: <sequence-cons> sequence-cons
: seq>list ( index seq -- list ) : seq>list ( index seq -- list )
2dup length >= [ 2dup length >= [
2drop nil 2drop nil
] [ ] [
<sequence-cons> <sequence-cons>
] if ; ] if ;
M: sequence-cons car ( sequence-cons -- car ) M: sequence-cons car ( sequence-cons -- car )
[ index>> ] keep [ index>> ] keep
seq>> nth ; seq>> nth ;
M: sequence-cons cdr ( sequence-cons -- cdr ) M: sequence-cons cdr ( sequence-cons -- cdr )
[ index>> 1+ ] keep [ index>> 1+ ] keep
seq>> seq>list ; seq>> seq>list ;
M: sequence-cons nil? ( sequence-cons -- bool ) M: sequence-cons nil? ( sequence-cons -- bool )
drop f ; drop f ;
: >list ( object -- list ) : >list ( object -- list )
{ {
{ [ dup sequence? ] [ 0 swap seq>list ] } { [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] } { [ dup list? ] [ ] }
[ "Could not convert object to a list" throw ] [ "Could not convert object to a list" throw ]
} cond ; } cond ;
TUPLE: lazy-concat car cdr ; TUPLE: lazy-concat car cdr ;
@ -295,102 +295,102 @@ C: <lazy-concat> lazy-concat
DEFER: lconcat DEFER: lconcat
: (lconcat) ( car cdr -- list ) : (lconcat) ( car cdr -- list )
over nil? [ over nil? [
nip lconcat nip lconcat
] [ ] [
<lazy-concat> <lazy-concat>
] if ; ] if ;
: lconcat ( list -- result ) : lconcat ( list -- result )
dup nil? [ dup nil? [
drop nil drop nil
] [ ] [
uncons swap (lconcat) uncons swap (lconcat)
] if ; ] if ;
M: lazy-concat car ( lazy-concat -- car ) M: lazy-concat car ( lazy-concat -- car )
car>> car ; car>> car ;
M: lazy-concat cdr ( lazy-concat -- cdr ) M: lazy-concat cdr ( lazy-concat -- cdr )
[ car>> cdr ] keep cdr>> (lconcat) ; [ car>> cdr ] keep cdr>> (lconcat) ;
M: lazy-concat nil? ( lazy-concat -- bool ) M: lazy-concat nil? ( lazy-concat -- bool )
dup car>> nil? [ dup car>> nil? [
cdr>> nil? cdr>> nil?
] [ ] [
drop f drop f
] if ; ] if ;
: lcartesian-product ( list1 list2 -- result ) : lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ; swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
: lcartesian-product* ( lists -- result ) : lcartesian-product* ( lists -- result )
dup nil? [ dup nil? [
drop nil drop nil
] [ ] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
swap [ swap [ suffix ] lmap-with ] lmap-with lconcat swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
] reduce ] reduce
] if ; ] if ;
: lcomp ( list quot -- result ) : lcomp ( list quot -- result )
[ lcartesian-product* ] dip lmap ; [ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result ) : lcomp* ( list guards quot -- result )
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
DEFER: lmerge DEFER: lmerge
: (lmerge) ( list1 list2 -- result ) : (lmerge) ( list1 list2 -- result )
over [ car ] curry -rot over [ car ] curry -rot
[
dup [ car ] curry -rot
[ [
[ cdr ] bi@ lmerge dup [ car ] curry -rot
] 2curry lazy-cons [
] 2curry lazy-cons ; [ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
: lmerge ( list1 list2 -- result ) : lmerge ( list1 list2 -- result )
{ {
{ [ over nil? ] [ nip ] } { [ over nil? ] [ nip ] }
{ [ dup nil? ] [ drop ] } { [ dup nil? ] [ drop ] }
{ [ t ] [ (lmerge) ] } { [ t ] [ (lmerge) ] }
} cond ; } cond ;
TUPLE: lazy-io stream car cdr quot ; TUPLE: lazy-io stream car cdr quot ;
C: <lazy-io> lazy-io C: <lazy-io> lazy-io
: lcontents ( stream -- result ) : lcontents ( stream -- result )
f f [ stream-read1 ] <lazy-io> ; f f [ stream-read1 ] <lazy-io> ;
: llines ( stream -- result ) : llines ( stream -- result )
f f [ stream-readln ] <lazy-io> ; f f [ stream-readln ] <lazy-io> ;
M: lazy-io car ( lazy-io -- car ) M: lazy-io car ( lazy-io -- car )
dup car>> dup [ dup car>> dup [
nip nip
] [ ] [
drop dup stream>> over quot>> call drop dup stream>> over quot>> call
swap dupd set-lazy-io-car swap dupd set-lazy-io-car
] if ; ] if ;
M: lazy-io cdr ( lazy-io -- cdr ) M: lazy-io cdr ( lazy-io -- cdr )
dup cdr>> dup [ dup cdr>> dup [
nip nip
] [
drop dup
[ stream>> ] keep
[ quot>> ] keep
car [
[ f f ] dip <lazy-io> [ >>cdr drop ] keep
] [ ] [
3drop nil drop dup
] if [ stream>> ] keep
] if ; [ quot>> ] keep
car [
[ f f ] dip <lazy-io> [ >>cdr drop ] keep
] [
3drop nil
] if
] if ;
M: lazy-io nil? ( lazy-io -- bool ) M: lazy-io nil? ( lazy-io -- bool )
car not ; car not ;
INSTANCE: sequence-cons list INSTANCE: sequence-cons list
INSTANCE: memoized-cons list INSTANCE: memoized-cons list