Re-implementing and renaming several words in lists

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" } }

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." } ;
+    

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
+{ 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

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 )    
+    <reversed> nil [ swap cons ] reduce ;
+    
+: same? ( obj1 obj2 -- ? ) 
+    [ class ] bi@ = ;
+    
+: seq>cons ( seq -- cons )
+    [ <reversed> ] 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 <reversed> nil [ swap cons ] reduce ;
-    
-: same? ( obj1 obj2 -- ? ) 
-    [ class ] bi@ = ;
-    
-: seq>cons ( seq -- cons )
-    [ <reversed> ] 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