diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index f2b03fe108..8d457ba2e1 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -86,7 +86,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach lreduce lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words +{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 51b068d979..6b22e77121 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -17,7 +17,7 @@ HELP: car HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } ; - + HELP: nil { $values { "cons" "An empty cons" } } { $description "Returns a representation of an empty list" } ; @@ -55,16 +55,50 @@ HELP: llength { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } { $description "Put the head and tail of the list on the stack." } ; -{ leach lreduce lmap>array } related-words +{ leach foldl lmap>array } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } { $description "Call the quotation for each item in the list." } ; -HELP: lreduce +HELP: foldl { $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } -{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; +{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ; +HELP: foldr +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ; + +HELP: lmap +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } } +{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; + +HELP: lreverse +{ $values { "list" "a cons object" } { "newlist" "a new cons object" } } +{ $description "Reverses the input list, outputing a new, reversed list" } ; + +HELP: list>seq +{ $values { "list" "a cons object" } { "array" "an array object" } } +{ $description "Turns the given cons object into an array, maintaing order." } ; + +HELP: seq>list +{ $values { "array" "an array object" } { "list" "a cons object" } } +{ $description "Turns the given array into a cons object, maintaing order." } ; + +HELP: cons>seq +{ $values { "cons" "a cons object" } { "array" "an array object" } } +{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; + +HELP: seq>cons +{ $values { "seq" "a sequence object" } { "cons" "a cons object" } } +{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; + +HELP: traverse +{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } + { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } +{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that " { $snippet pred } + " returns true for with the result of applying " { $snippet quot } " to." } ; + diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 0abb8befeb..1f86379fab 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -4,6 +4,10 @@ USING: tools.test lists math ; IN: lists.tests +{ { 3 4 5 6 7 } } [ + { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq +] unit-test + { { 3 4 5 6 } } [ T{ cons f 1 T{ cons f 2 @@ -17,7 +21,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - +nil+ } } } } 0 [ + ] lreduce + +nil+ } } } } 0 [ + ] foldl ] unit-test { T{ cons f @@ -38,13 +42,21 @@ IN: lists.tests ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } seq>cons cons>seq ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ { 1 2 3 4 } seq>cons [ 1+ ] lmap ] unit-test -! { { 3 4 { 5 6 { 7 } } } } [ -! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq -! ] unit-test \ No newline at end of file +{ 15 } [ + { 1 2 3 4 5 } seq>list 0 [ + ] foldr +] unit-test + +{ { 5 4 3 2 1 } } [ + { 1 2 3 4 5 } seq>list lreverse list>seq +] unit-test + +{ { 3 4 { 5 6 { 7 } } } } [ + { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq +] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index b0fd41fe75..a04a728ffc 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words ; +USING: kernel sequences accessors math arrays vectors classes words locals ; IN: lists @@ -23,6 +23,8 @@ M: cons cdr ( cons -- cdr ) SYMBOL: +nil+ M: word nil? +nil+ eq? ; M: object nil? drop f ; + +: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; : nil ( -- +nil+ ) +nil+ ; @@ -38,6 +40,9 @@ M: object nil? drop f ; : 3list ( a b c -- cons ) nil cons cons cons ; +: cadr ( cons -- elt ) + cdr car ; + : 2car ( cons -- car caar ) [ car ] [ cdr car ] bi ; @@ -52,12 +57,38 @@ M: object nil? drop f ; : llength ( list -- n ) 0 (llength) ; + +: (leach) ( list quot -- cdr quot ) + [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline : leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons swap ] dip tuck [ call ] 2dip leach ] if ; inline + over nil? [ 2drop ] [ (leach) leach ] if ; inline + +: lmap ( list quot -- result ) + over nil? [ drop ] [ (leach) lmap cons ] if ; inline + +: foldl ( list ident quot -- result ) swapd leach ; inline + +: foldr ( list ident quot -- result ) + pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ + [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi + call + ] if ; inline -: lreduce ( list identity quot -- result ) - swapd leach ; inline +: lreverse ( list -- newlist ) + nil [ swap cons ] foldl ; + +: lappend ( list1 list2 -- newlist ) + ; + +: seq>list ( seq -- list ) + nil [ swap cons ] reduce ; + +: same? ( obj1 obj2 -- ? ) + [ class ] bi@ = ; + +: seq>cons ( seq -- cons ) + [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : (lmap>array) ( acc cons quot -- newcons ) over nil? [ 2drop ] @@ -69,19 +100,14 @@ M: object nil? drop f ; : lmap-as ( cons quot exemplar -- seq ) [ lmap>array ] dip like ; -: lmap ( list quot -- newlist ) - lmap>array nil [ swap cons ] reduce ; - -: same? ( obj1 obj2 -- ? ) - [ class ] bi@ = ; - -: seq>cons ( seq -- cons ) - [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; - : cons>seq ( cons -- array ) [ dup cons? [ cons>seq ] when ] lmap>array ; -: traverse ( list quot -- newlist ) - [ over list? [ traverse ] [ call ] if ] curry lmap ; +: list>seq ( list -- array ) + [ ] lmap>array ; + +: traverse ( list pred quot -- result ) + [ 2over call [ tuck [ call ] 2dip ] when + pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; INSTANCE: cons list \ No newline at end of file