From 0add9190c26e3fe82d48a3a7fa090fc1d9a7ba1f Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 18 Apr 2016 09:46:29 -0700 Subject: [PATCH] lists: more cleanup. --- basis/lists/lazy/lazy-docs.factor | 24 +++++----- basis/lists/lazy/lazy-tests.factor | 4 +- basis/lists/lazy/lazy.factor | 72 ++++++++++++++++-------------- basis/lists/lists.factor | 12 ++--- 4 files changed, 59 insertions(+), 53 deletions(-) diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index 24f3aa31e3..ac9e053985 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -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: { $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 diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 499c945944..d73c557d3d 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -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 } } [ diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index d6f7004d66..07fa35b0a0 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -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 @@ -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 -: luntil ( list quot -- result ) +: luntil ( list quot: ( elt -- ? ) -- result ) over nil? [ drop ] [ ] if ; M: lazy-until car @@ -118,7 +116,7 @@ TUPLE: lazy-while cons quot ; C: lazy-while -: lwhile ( list quot -- result ) +: lwhile ( list quot: ( elt -- ? ) -- result ) over nil? [ drop ] [ ] if ; M: lazy-while car @@ -134,34 +132,34 @@ TUPLE: lazy-filter cons quot ; C: lazy-filter -: lfilter ( list quot -- result ) +: lfilter ( list quot: ( elt -- ? ) -- result ) over nil? [ 2drop nil ] [ ] if ; > 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 -: lzip ( list1 list2 -- lazy-zip ) - over nil? over nil? or +: lzip ( list1 list2 -- result ) + 2dup [ nil? ] either? [ 2drop nil ] [ ] if ; M: lazy-zip car @@ -241,9 +239,13 @@ C: lazy-concat DEFER: lconcat + ] 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 + : 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* ; diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 29181a9da4..8bb8b73ea6 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -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 ) nil [ swons ] reduce ;