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

lists: more cleanup.

locals-and-roots
John Benediktsson 2016-04-18 09:46:29 -07:00
parent da65402ee8
commit 0add9190c2
4 changed files with 59 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
basis/lists/lazy/lazy-docs.factor
View File

@ -23,8 +23,8 @@ ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists
luntil
lwhile
lfrom-by
lcomp
lcomp*
lcartesian-map
lcartesian-map*
} ;
ARTICLE: { "lists.lazy" "io" } "Lazy list I/O"
@ -82,7 +82,7 @@ HELP: <memoized-cons>
{ $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? } ;
{ lmap-lazy ltake lfilter lappend-lazy 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* lcartesian-map lcartesian-map* lmerge lwhile luntil } related-words
HELP: lmap-lazy
{ $values { "list" "a cons object" } { "quot" { $quotation ( obj -- X ) } } { "result" "resulting cons object" } }
@ -93,15 +93,15 @@ HELP: ltake
{ $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" } }
{ $values { "list" "a cons object" } { "quot" { $quotation ( elt -- ? ) } } { "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." } ;
HELP: lwhile
{ $values { "list" "a cons object" } { "quot" { $quotation ( x -- ? ) } } { "result" "resulting cons object" } }
{ $values { "list" "a cons object" } { "quot" { $quotation ( elt -- ? ) } } { "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." } ;
HELP: luntil
{ $values { "list" "a cons object" } { "quot" { $quotation ( x -- ? ) } } { "result" "resulting cons object" } }
{ $values { "list" "a cons object" } { "quot" { $quotation ( elt -- ? ) } } { "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." } ;
HELP: lappend-lazy
@ -121,7 +121,7 @@ HELP: sequence-tail>list
{ $description "Convert the sequence into a list, starting from " { $snippet "index" } "." }
{ $see-also >list } ;
{ leach foldl lmap-lazy ltake lfilter lappend-lazy 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* lcartesian-map lcartesian-map* lmerge lwhile luntil } related-words
HELP: lconcat
{ $values { "list" "a list of lists" } { "result" "a list" } }
@ -135,15 +135,15 @@ HELP: lcartesian-product*
{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
HELP: lcomp
{ $values { "list" "a list of lists" } { "quot" { $quotation ( seq -- X ) } } { "result" "the resulting list" } }
HELP: lcartesian-map
{ $values { "list" "a list of lists" } { "quot" { $quotation ( elt1 elt2 -- newelt ) } } { "result" "the resulting list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
HELP: lcomp*
{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation ( seq -- X ) } } { "result" "a list" } }
HELP: lcartesian-map*
{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( elt1 elt2 -- ? )" } { "quot" { $quotation ( elt1 elt2 -- newelt ) } } { "result" "a list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
{ $examples
{ $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
{ $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ drop odd? ] } [ + ] lcartesian-map*" }
} ;
HELP: lmerge

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

@ -17,11 +17,11 @@ IN: lists.lazy.tests
] unit-test
{ { 5 6 6 7 7 8 } } [
{ 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
{ 1 2 3 } >list { 4 5 } >list 2list [ + ] lcartesian-map list>array
] unit-test
{ { 5 6 7 8 } } [
{ 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
{ 1 2 3 } >list { 4 5 } >list 2list { [ drop odd? ] } [ + ] lcartesian-map* list>array
] unit-test
{ { 4 5 6 } } [

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

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io kernel lists math
USING: accessors arrays combinators io kernel lists locals math
promises quotations sequences ;
IN: lists.lazy
@ -10,9 +10,7 @@ M: promise cdr force cdr ;
M: promise nil? force nil? ;
TUPLE: lazy-cons-state
{ car promise }
{ cdr promise } ;
TUPLE: lazy-cons-state { car promise } { cdr promise } ;
C: <lazy-cons-state> lazy-cons-state
@ -24,7 +22,7 @@ M: lazy-cons-state car car>> force ;
M: lazy-cons-state cdr cdr>> force ;
M: lazy-cons-state nil? nil eq? ;
M: lazy-cons-state nil? car nil? ;
: 1lazy-list ( a -- lazy-cons )
[ nil ] lazy-cons ;
@ -100,7 +98,7 @@ TUPLE: lazy-until cons quot ;
C: <lazy-until> lazy-until
: luntil ( list quot -- result )
: luntil ( list quot: ( elt -- ? ) -- result )
over nil? [ drop ] [ <lazy-until> ] if ;
M: lazy-until car
@ -118,7 +116,7 @@ TUPLE: lazy-while cons quot ;
C: <lazy-while> lazy-while
: lwhile ( list quot -- result )
: lwhile ( list quot: ( elt -- ? ) -- result )
over nil? [ drop ] [ <lazy-while> ] if ;
M: lazy-while car
@ -134,34 +132,34 @@ TUPLE: lazy-filter cons quot ;
C: <lazy-filter> lazy-filter
: lfilter ( list quot -- result )
: lfilter ( list quot: ( elt -- ? ) -- result )
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
<PRIVATE
: car-filter? ( lazy-filter -- ? )
: car-filtered? ( lazy-filter -- ? )
[ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
: skip ( lazy-filter -- )
dup cons>> cdr >>cons drop ;
: skip ( lazy-filter -- lazy-filter )
[ cdr ] change-cons ;
PRIVATE>
M: lazy-filter car
dup car-filter? [ cons>> ] [ dup skip ] if car ;
dup car-filtered? [ cons>> ] [ skip ] if car ;
M: lazy-filter cdr
dup car-filter? [
dup car-filtered? [
[ cons>> cdr ] [ quot>> ] bi lfilter
] [
dup skip cdr
skip cdr
] if ;
M: lazy-filter nil?
{
{ [ dup cons>> nil? ] [ drop t ] }
{ [ dup car-filter? ] [ drop f ] }
[ dup skip nil? ]
{ [ dup car-filtered? ] [ drop f ] }
[ skip nil? ]
} cond ;
TUPLE: lazy-append list1 list2 ;
@ -182,9 +180,9 @@ M: lazy-append nil?
TUPLE: lazy-from-by n quot ;
: lfrom-by ( n quot: ( n -- o ) -- lazy-from-by ) lazy-from-by boa ; inline
: lfrom-by ( n quot: ( n -- o ) -- result ) lazy-from-by boa ; inline
: lfrom ( n -- list )
: lfrom ( n -- result )
[ 1 + ] lfrom-by ;
M: lazy-from-by car
@ -200,8 +198,8 @@ TUPLE: lazy-zip list1 list2 ;
C: <lazy-zip> lazy-zip
: lzip ( list1 list2 -- lazy-zip )
over nil? over nil? or
: lzip ( list1 list2 -- result )
2dup [ nil? ] either?
[ 2drop nil ] [ <lazy-zip> ] if ;
M: lazy-zip car
@ -241,9 +239,13 @@ C: <lazy-concat> lazy-concat
DEFER: lconcat
<PRIVATE
: (lconcat) ( car cdr -- list )
over nil? [ nip lconcat ] [ <lazy-concat> ] if ;
PRIVATE>
: lconcat ( list -- result )
dup nil? [ drop nil ] [ uncons (lconcat) ] if ;
@ -257,7 +259,7 @@ M: lazy-concat nil?
dup car>> nil? [ cdr>> nil? ] [ drop f ] if ;
: lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] with lmap-lazy ] with lmap-lazy lconcat ;
swap [ swap [ 2array ] with lmap-lazy ] with lmap-lazy lconcat ;
: lcartesian-product* ( lists -- result )
dup nil? [
@ -270,28 +272,32 @@ M: lazy-concat nil?
] reduce
] if ;
: lcomp ( list quot -- result )
[ lcartesian-product* ] dip lmap-lazy ;
: lcartesian-map ( list quot: ( elt1 elt2 -- newelt ) -- result )
[ lcartesian-product* ] dip [ first2 ] prepose lmap-lazy ;
: lcomp* ( list guards quot -- result )
: lcartesian-map* ( list guards quot: ( elt1 elt2 -- newelt ) -- result )
[ [ [ first2 ] prepose ] map ] [ [ first2 ] prepose ] bi*
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap-lazy ;
DEFER: lmerge
: (lmerge) ( list1 list2 -- result )
over [ car ] curry -rot
<PRIVATE
:: (lmerge) ( list1 list2 -- result )
[ list1 car ]
[
dup [ car ] curry -rot
[
[ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
[ list2 car ]
[ list1 cdr list2 cdr lmerge ]
lazy-cons
] lazy-cons ;
PRIVATE>
: lmerge ( list1 list2 -- result )
{
{ [ over nil? ] [ nip ] }
{ [ dup nil? ] [ drop ] }
{ [ t ] [ (lmerge) ] }
[ (lmerge) ]
} cond ;
TUPLE: lazy-io stream car cdr quot ;
@ -308,7 +314,7 @@ M: lazy-io car
dup car>> [
nip
] [
[ ] [ stream>> ] [ quot>> ] tri
dup [ stream>> ] [ quot>> ] bi
call( stream -- value ) [ >>car ] [ drop nil ] if*
] if* ;

12
basis/lists/lists.factor
View File

@ -42,9 +42,9 @@ M: object nil? drop f ;
: cadr ( list -- elt ) cdr car ; inline
: 2car ( list -- car cadr ) [ car ] [ cadr ] bi ; inline
: 2car ( list -- car cadr ) uncons car ; inline
: 3car ( list -- car cadr caddr ) [ car ] [ cadr ] [ cdr cadr ] tri ; inline
: 3car ( list -- car cadr caddr ) uncons uncons car ; inline
: lnth ( n list -- elt ) swap [ cdr ] times car ; inline
@ -62,7 +62,9 @@ PRIVATE>
swapd leach ; inline
:: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
list nil? [ identity ] [
list nil? [
identity
] [
list cdr identity quot foldr
list car quot call
] if ; inline recursive
@ -80,9 +82,7 @@ PRIVATE>
[ lreverse ] dip [ swons ] foldl ;
: lcut ( list index -- before after )
[ nil ] dip
[ [ unswons ] dip cons ] times
lreverse swap ;
[ nil ] dip [ [ unswons ] dip cons ] times lreverse swap ;
: sequence>list ( sequence -- list )
<reversed> nil [ swons ] reduce ;