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

Fixing some bugs/oddities in lists implementations

db4
James Cash 2008-06-03 23:39:45 -04:00
parent ed0468b8f5
commit f63e6f1e35
1 changed files with 10 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
extra/lists/lists.factor
View File

@ -23,8 +23,11 @@ M: cons cdr ( cons -- cdr )
: nil ( -- cons ) : nil ( -- cons )
T{ cons f f f } ; T{ cons f f f } ;
M: cons nil? ( cons -- bool ) : uncons ( cons -- cdr car )
nil eq? ; [ cdr ] [ car ] bi ;
M: cons nil? ( cons -- ? )
uncons and not ;
: 1list ( obj -- cons ) : 1list ( obj -- cons )
nil cons ; nil cons ;
@ -41,9 +44,6 @@ M: cons nil? ( cons -- bool )
: 3car ( cons -- car caar caaar ) : 3car ( cons -- car caar caaar )
[ car ] [ cdr car ] [ cdr cdr car ] tri ; [ car ] [ cdr car ] [ cdr cdr car ] tri ;
: uncons ( cons -- cdr car )
[ cdr ] [ car ] bi ;
: lnth ( n list -- elt ) : lnth ( n list -- elt )
swap [ cdr ] times car ; swap [ cdr ] times car ;
@ -57,14 +57,15 @@ M: cons nil? ( cons -- bool )
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 pick nil? [ drop nip ]
[ [ uncons ] 2dip swapd [ call ] keep lreduce ] if ; inline
: (lmap) ( acc cons quot -- seq ) : (lmap) ( acc cons quot -- seq )
over nil? [ 2drop ] over nil? [ 2drop ]
[ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline
: lmap ( cons quot -- seq ) : lmap ( cons quot -- seq )
[ { } clone ] 2dip (lmap) ; inline { } -rot (lmap) ; inline
: lmap-as ( cons quot exemplar -- seq ) : lmap-as ( cons quot exemplar -- seq )
[ lmap ] dip like ; [ lmap ] dip like ;
@ -76,6 +77,6 @@ M: cons nil? ( cons -- bool )
[ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
: cons>seq ( cons -- array ) : cons>seq ( cons -- array )
[ ] lmap ; [ dup cons? [ cons>seq ] when ] lmap ;
INSTANCE: cons list INSTANCE: cons list