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

llines was broken. it still probably is -- what if the stream throws an exception? cleanup some old code

db4
Doug Coleman 2009-05-18 12:27:04 -05:00
parent 8175d6fe2b
commit 241c2ea846
3 changed files with 62 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/lists/lazy/lazy-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006 Matthew Willis and Chris Double. ! Copyright (C) 2006 Matthew Willis and Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: lists lists.lazy tools.test kernel math io sequences ; USING: io io.encodings.utf8 io.files kernel lists lists.lazy
math sequences tools.test ;
IN: lists.lazy.tests IN: lists.lazy.tests
[ { 1 2 3 4 } ] [ [ { 1 2 3 4 } ] [
@ -33,3 +34,6 @@ IN: lists.lazy.tests
[ [ drop ] foldl ] must-infer [ [ drop ] foldl ] must-infer
[ [ drop ] leach ] must-infer [ [ drop ] leach ] must-infer
[ lnth ] must-infer [ lnth ] must-infer
[ ] [ "resource:license.txt" utf8 <file-reader> llines list>array drop ] unit-test
[ ] [ "resource:license.txt" utf8 <file-reader> lcontents list>array drop ] unit-test

127
basis/lists/lazy/lazy.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math vectors arrays namespaces make USING: accessors arrays combinators io kernel lists math
quotations promises combinators io lists accessors ; promises quotations sequences summary vectors ;
IN: lists.lazy IN: lists.lazy
M: promise car ( promise -- car ) M: promise car ( promise -- car )
@ -10,16 +10,16 @@ M: promise car ( promise -- car )
M: promise cdr ( promise -- cdr ) M: promise cdr ( promise -- cdr )
force cdr ; force cdr ;
M: promise nil? ( cons -- bool ) M: promise nil? ( cons -- ? )
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 ;
: lazy-cons ( car cdr -- promise ) : lazy-cons ( car cdr -- promise )
[ promise ] bi@ \ lazy-cons boa [ T{ promise f f t f } clone ] 2dip
T{ promise f f t f } clone [ promise ] bi@ \ lazy-cons boa
swap >>value ; >>value ;
M: lazy-cons car ( lazy-cons -- car ) M: lazy-cons car ( lazy-cons -- car )
car>> force ; car>> force ;
@ -27,7 +27,7 @@ M: lazy-cons car ( lazy-cons -- car )
M: lazy-cons cdr ( lazy-cons -- cdr ) M: lazy-cons cdr ( lazy-cons -- cdr )
cdr>> force ; cdr>> force ;
M: lazy-cons nil? ( lazy-cons -- bool ) M: lazy-cons nil? ( lazy-cons -- ? )
nil eq? ; nil eq? ;
: 1lazy-list ( a -- lazy-cons ) : 1lazy-list ( a -- lazy-cons )
@ -41,11 +41,9 @@ M: lazy-cons nil? ( lazy-cons -- bool )
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 -- ? ) 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
@ -65,7 +63,7 @@ M: memoized-cons cdr ( memoized-cons -- cdr )
cdr>> cdr>>
] if ; ] if ;
M: memoized-cons nil? ( memoized-cons -- bool ) M: memoized-cons nil? ( memoized-cons -- ? )
dup nil?>> not-memoized? [ dup nil?>> not-memoized? [
dup original>> nil? [ >>nil? drop ] keep dup original>> nil? [ >>nil? drop ] keep
] [ ] [
@ -80,14 +78,12 @@ C: <lazy-map> lazy-map
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 ] [ quot>> call( old -- new ) ] bi ;
quot>> call( old -- new ) ;
M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map cdr ( lazy-map -- cdr )
[ cons>> cdr ] keep [ cons>> cdr ] [ quot>> lazy-map ] bi ;
quot>> lazy-map ;
M: lazy-map nil? ( lazy-map -- bool ) M: lazy-map nil? ( lazy-map -- ? )
cons>> nil? ; cons>> nil? ;
TUPLE: lazy-take n cons ; TUPLE: lazy-take n cons ;
@ -95,7 +91,7 @@ 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 ;
@ -104,12 +100,8 @@ 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 -- ? )
dup n>> zero? [ dup n>> zero? [ drop t ] [ cons>> nil? ] if ;
drop t
] [
cons>> nil?
] if ;
TUPLE: lazy-until cons quot ; TUPLE: lazy-until cons quot ;
@ -125,7 +117,7 @@ M: lazy-until cdr ( lazy-until -- cdr )
[ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
[ 2drop nil ] [ luntil ] if ; [ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- bool ) M: lazy-until nil? ( lazy-until -- ? )
drop f ; drop f ;
TUPLE: lazy-while cons quot ; TUPLE: lazy-while cons quot ;
@ -141,7 +133,7 @@ M: lazy-while car ( lazy-while -- 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 -- ? )
[ car ] keep quot>> call( elt -- ? ) not ; [ car ] keep quot>> call( elt -- ? ) not ;
TUPLE: lazy-filter cons quot ; TUPLE: lazy-filter cons quot ;
@ -167,7 +159,7 @@ M: lazy-filter cdr ( lazy-filter -- cdr )
dup skip cdr dup skip cdr
] if ; ] if ;
M: lazy-filter nil? ( lazy-filter -- bool ) M: lazy-filter nil? ( lazy-filter -- ? )
dup cons>> nil? [ dup cons>> nil? [
drop t drop t
] [ ] [
@ -189,10 +181,9 @@ 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 ] [ list2>> ] bi lappend ;
list2>> lappend ;
M: lazy-append nil? ( lazy-append -- bool ) M: lazy-append nil? ( lazy-append -- ? )
drop f ; drop f ;
TUPLE: lazy-from-by n quot ; TUPLE: lazy-from-by n quot ;
@ -209,7 +200,7 @@ M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ n>> ] keep [ n>> ] keep
quot>> [ call( old -- new ) ] keep lfrom-by ; quot>> [ call( old -- new ) ] keep lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool ) M: lazy-from-by nil? ( lazy-from-by -- ? )
drop f ; drop f ;
TUPLE: lazy-zip list1 list2 ; TUPLE: lazy-zip list1 list2 ;
@ -226,14 +217,14 @@ M: lazy-zip car ( lazy-zip -- car )
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 -- ? )
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 ) : sequence-tail>list ( index seq -- list )
2dup length >= [ 2dup length >= [
2drop nil 2drop nil
] [ ] [
@ -241,21 +232,24 @@ C: <sequence-cons> sequence-cons
] if ; ] if ;
M: sequence-cons car ( sequence-cons -- car ) M: sequence-cons car ( sequence-cons -- car )
[ index>> ] keep [ index>> ] [ seq>> nth ] bi ;
seq>> nth ;
M: sequence-cons cdr ( sequence-cons -- cdr ) M: sequence-cons cdr ( sequence-cons -- cdr )
[ index>> 1+ ] keep [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ;
seq>> seq>list ;
M: sequence-cons nil? ( sequence-cons -- bool ) M: sequence-cons nil? ( sequence-cons -- ? )
drop f ; drop f ;
ERROR: list-conversion-error object ;
M: list-conversion-error summary
drop "Could not convert object to list" ;
: >list ( object -- list ) : >list ( object -- list )
{ {
{ [ dup sequence? ] [ 0 swap seq>list ] } { [ dup sequence? ] [ 0 swap sequence-tail>list ] }
{ [ dup list? ] [ ] } { [ dup list? ] [ ] }
[ "Could not convert object to a list" throw ] [ list-conversion-error ]
} cond ; } cond ;
TUPLE: lazy-concat car cdr ; TUPLE: lazy-concat car cdr ;
@ -265,18 +259,10 @@ C: <lazy-concat> lazy-concat
DEFER: lconcat DEFER: lconcat
: (lconcat) ( car cdr -- list ) : (lconcat) ( car cdr -- list )
over nil? [ over nil? [ nip lconcat ] [ <lazy-concat> ] if ;
nip lconcat
] [
<lazy-concat>
] if ;
: lconcat ( list -- result ) : lconcat ( list -- result )
dup nil? [ dup nil? [ drop nil ] [ uncons (lconcat) ] if ;
drop nil
] [
uncons (lconcat)
] if ;
M: lazy-concat car ( lazy-concat -- car ) M: lazy-concat car ( lazy-concat -- car )
car>> car ; car>> car ;
@ -284,12 +270,8 @@ M: lazy-concat car ( lazy-concat -- 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 -- ? )
dup car>> nil? [ dup car>> nil? [ cdr>> nil? ] [ drop f ] if ;
cdr>> nil?
] [
drop f
] if ;
: lcartesian-product ( list1 list2 -- result ) : lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ;
@ -298,7 +280,9 @@ M: lazy-concat nil? ( lazy-concat -- bool )
dup nil? [ dup nil? [
drop nil drop nil
] [ ] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ [ car ] [ cdr ] bi
[ car lcartesian-product ] [ cdr ] bi
list>array swap [
swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat
] reduce ] reduce
] if ; ] if ;
@ -322,9 +306,9 @@ DEFER: lmerge
: 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 ;
@ -338,30 +322,29 @@ C: <lazy-io> lazy-io
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>> [
nip nip
] [ ] [
drop dup stream>> over quot>> [ ] [ stream>> ] [ quot>> ] tri
call( stream -- value ) call( stream -- value ) [ >>car ] [ drop nil ] if*
>>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 drop dup
[ stream>> ] keep [ stream>> ]
[ quot>> ] keep [ quot>> ]
car [ [ car ] tri [
[ f f ] dip <lazy-io> [ >>cdr drop ] keep [ f f ] dip <lazy-io> [ >>cdr drop ] keep
] [ ] [
3drop nil 3drop nil
] if ] if
] if ; ] if ;
M: lazy-io nil? ( lazy-io -- bool ) M: lazy-io nil? ( lazy-io -- ? )
car not ; car nil? ;
INSTANCE: sequence-cons list INSTANCE: sequence-cons list
INSTANCE: memoized-cons list INSTANCE: memoized-cons list

4
basis/promises/promises.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math arrays namespaces USING: accessors arrays effects fry generalizations kernel math
parser effects generalizations fry words accessors ; namespaces parser sequences words ;
IN: promises IN: promises
TUPLE: promise quot forced? value ; TUPLE: promise quot forced? value ;