From c4aa14b9d96d0a55b6c94e2441d952cf056ddfcc Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sun, 8 Feb 2009 23:06:03 -0600
Subject: [PATCH] Making lazy lists compile, and using them where applicable

---
 basis/persistent/deques/deques.factor | 14 ++--
 basis/wrap/wrap-docs.factor           | 26 +++----
 basis/wrap/wrap-tests.factor          | 84 +++++++++++------------
 basis/wrap/wrap.factor                | 97 ++++++++++++---------------
 extra/lists/lazy/lazy-tests.factor    |  8 ++-
 extra/lists/lazy/lazy.factor          | 22 +++---
 extra/lists/lists.factor              |  5 +-
 extra/promises/promises.factor        | 10 +--
 8 files changed, 125 insertions(+), 141 deletions(-)

diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor
index be63d807b9..ece1cda772 100644
--- a/basis/persistent/deques/deques.factor
+++ b/basis/persistent/deques/deques.factor
@@ -1,6 +1,6 @@
 ! Copyback (C) 2008 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math ;
+USING: kernel accessors math lists ;
 QUALIFIED: sequences
 IN: persistent.deques
 
@@ -9,25 +9,23 @@ IN: persistent.deques
 !   same source, it could take O(m) amortized time per update.
 
 <PRIVATE
-TUPLE: cons { car read-only } { cdr read-only } ;
-C: <cons> cons
 
 : each ( list quot: ( elt -- ) -- )
     over
-    [ [ [ car>> ] dip call ] [ [ cdr>> ] dip ] 2bi each ]
+    [ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi each ]
     [ 2drop ] if ; inline recursive
 
 : reduce ( list start quot -- end )
     swapd each ; inline
 
 : reverse ( list -- reversed )
-    f [ swap <cons> ] reduce ;
+    f [ swap cons ] reduce ;
 
 : length ( list -- length )
     0 [ drop 1+ ] reduce ;
 
 : cut ( list index -- back front-reversed )
-    f swap [ [ [ cdr>> ] [ car>> ] bi ] dip <cons> ] times ;
+    f swap [ [ [ cdr ] [ car ] bi ] dip cons ] times ;
 
 : split-reverse ( list -- back-reversed front )
     dup length 2/ cut [ reverse ] bi@ ;
@@ -49,7 +47,7 @@ PRIVATE>
 
 <PRIVATE
 : push ( item deque -- newdeque )
-    [ front>> <cons> ] [ back>> ] bi deque boa ; inline
+    [ front>> cons ] [ back>> ] bi deque boa ; inline
 PRIVATE>
 
 : push-front ( deque item -- newdeque )
@@ -60,7 +58,7 @@ PRIVATE>
 
 <PRIVATE
 : remove ( deque -- item newdeque )
-    [ front>> car>> ] [ [ front>> cdr>> ] [ back>> ] bi deque boa ] bi ; inline
+    [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline
 
 : transfer ( deque -- item newdeque )
     back>> [ split-reverse deque boa remove ]
diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor
index 09ddec36ed..59c0352bc7 100644
--- a/basis/wrap/wrap-docs.factor
+++ b/basis/wrap/wrap-docs.factor
@@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping"
 { $subsection wrap-lines }
 { $subsection wrap-string }
 { $subsection wrap-indented-string }
-"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called elements."
-{ $subsection wrap-elements }
-{ $subsection element }
-{ $subsection <element> } ;
+"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments."
+{ $subsection wrap-segments }
+{ $subsection segment }
+{ $subsection <segment> } ;
 
 HELP: wrap-lines
 { $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
@@ -27,15 +27,15 @@ HELP: wrap-indented-string
 { $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
 { $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
 
-HELP: wrap-elements
-{ $values { "elements" { "a sequence of " { $instance element } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } }
+HELP: wrap-segments
+{ $values { "segments" { "a sequence of " { $instance segment } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } }
 { $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
 
-HELP: element
-{ $class-description "An element is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link <element> } "." }
-{ $see-also wrap-elements } ;
+HELP: segment
+{ $class-description "A segment is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link <segment> } "." }
+{ $see-also wrap-segments } ;
 
-HELP: <element>
-{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "element" element } }
-{ $description "Creates an " { $link element } " object with the given parameters." }
-{ $see-also wrap-elements } ;
+HELP: <segment>
+{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } }
+{ $description "Creates a " { $link segment } " object with the given parameters." }
+{ $see-also wrap-segments } ;
diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor
index 933238fddc..eeea3850d5 100644
--- a/basis/wrap/wrap-tests.factor
+++ b/basis/wrap/wrap-tests.factor
@@ -6,77 +6,77 @@ IN: wrap.tests
 [
     {
         {
-            T{ element f 1 10 f }
-            T{ element f 2 10 f }
-            T{ element f 3 2 t }
+            T{ segment f 1 10 f }
+            T{ segment f 2 10 f }
+            T{ segment f 3 2 t }
         }
         {
-            T{ element f 4 10 f }
-            T{ element f 5 10 f }
+            T{ segment f 4 10 f }
+            T{ segment f 5 10 f }
         }
     }
 ] [
     {
-        T{ element f 1 10 f }
-        T{ element f 2 10 f }
-        T{ element f 3 2 t }
-        T{ element f 4 10 f }
-        T{ element f 5 10 f }
-    } 35 35 wrap-elements [ { } like ] map
+        T{ segment f 1 10 f }
+        T{ segment f 2 10 f }
+        T{ segment f 3 2 t }
+        T{ segment f 4 10 f }
+        T{ segment f 5 10 f }
+    } 35 35 wrap-segments [ { } like ] map
 ] unit-test
 
 [
     {
         {
-            T{ element f 1 10 f }
-            T{ element f 2 10 f }
-            T{ element f 3 9 t }
-            T{ element f 3 9 t }
-            T{ element f 3 9 t }
+            T{ segment f 1 10 f }
+            T{ segment f 2 10 f }
+            T{ segment f 3 9 t }
+            T{ segment f 3 9 t }
+            T{ segment f 3 9 t }
         }
         {
-            T{ element f 4 10 f }
-            T{ element f 5 10 f }
+            T{ segment f 4 10 f }
+            T{ segment f 5 10 f }
         }
     }
 ] [
     {
-        T{ element f 1 10 f }
-        T{ element f 2 10 f }
-        T{ element f 3 9 t }
-        T{ element f 3 9 t }
-        T{ element f 3 9 t }
-        T{ element f 4 10 f }
-        T{ element f 5 10 f }
-    } 35 35 wrap-elements [ { } like ] map
+        T{ segment f 1 10 f }
+        T{ segment f 2 10 f }
+        T{ segment f 3 9 t }
+        T{ segment f 3 9 t }
+        T{ segment f 3 9 t }
+        T{ segment f 4 10 f }
+        T{ segment f 5 10 f }
+    } 35 35 wrap-segments [ { } like ] map
 ] unit-test
 
 [
     {
         {
-            T{ element f 1 10 t }
-            T{ element f 1 10 f }
-            T{ element f 3 9 t }
+            T{ segment f 1 10 t }
+            T{ segment f 1 10 f }
+            T{ segment f 3 9 t }
         }
         {
-            T{ element f 2 10 f }
-            T{ element f 3 9 t }
+            T{ segment f 2 10 f }
+            T{ segment f 3 9 t }
         }
         {
-            T{ element f 4 10 f }
-            T{ element f 5 10 f }
+            T{ segment f 4 10 f }
+            T{ segment f 5 10 f }
         }
     }
 ] [
     {
-        T{ element f 1 10 t }
-        T{ element f 1 10 f }
-        T{ element f 3 9 t }
-        T{ element f 2 10 f }
-        T{ element f 3 9 t }
-        T{ element f 4 10 f }
-        T{ element f 5 10 f }
-    } 35 35 wrap-elements [ { } like ] map
+        T{ segment f 1 10 t }
+        T{ segment f 1 10 f }
+        T{ segment f 3 9 t }
+        T{ segment f 2 10 f }
+        T{ segment f 3 9 t }
+        T{ segment f 4 10 f }
+        T{ segment f 5 10 f }
+    } 35 35 wrap-segments [ { } like ] map
 ] unit-test
 
 [
@@ -115,4 +115,4 @@ word wrap.">
 [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
 
 \ wrap-string must-infer
-\ wrap-elements must-infer
+\ wrap-segments must-infer
diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor
index 458d2f86d1..f54c858bf4 100644
--- a/basis/wrap/wrap.factor
+++ b/basis/wrap/wrap.factor
@@ -1,39 +1,28 @@
-USING: kernel sequences math arrays locals fry accessors splitting
-make combinators.short-circuit namespaces grouping splitting.monotonic ;
+USING: kernel sequences math arrays locals fry accessors
+lists splitting call make combinators.short-circuit namespaces
+grouping splitting.monotonic ;
 IN: wrap
 
 <PRIVATE
 
 ! black is the text length, white is the whitespace length
-TUPLE: word contents black white ;
-C: <word> word
+TUPLE: element contents black white ;
+C: <element> element
 
-: word-length ( word -- n )
+: element-length ( element -- n )
     [ black>> ] [ white>> ] bi + ;
 
-TUPLE: cons cdr car ; ! This order works out better
-C: <cons> cons
+: swons ( cdr car -- cons )
+    swap cons ;
 
-: >cons< ( cons -- cdr car )
-    [ cdr>> ] [ car>> ] bi ;
+: unswons ( cons -- cdr car )
+    [ cdr ] [ car ] bi ;
 
-: list-each ( list quot -- )
-    over [
-        [ [ car>> ] dip call ]
-        [ [ cdr>> ] dip list-each ] 2bi
-    ] [ 2drop ] if ; inline recursive
-
-: singleton? ( list -- ? )
-    { [ ] [ cdr>> not ] } 1&& ;
-
-: <singleton> ( elt -- list )
-    f swap <cons> ;
-
-: list>array ( list -- array )
-    [ [ , ] list-each ] { } make ;
+: 1list? ( list -- ? )
+    { [ ] [ cdr +nil+ = ] } 1&& ;
 
 : lists>arrays ( lists -- arrays )
-    [ [ list>array , ] list-each ] { } make ;
+    [ list>seq ] lmap>array ;
 
 TUPLE: paragraph lines head-width tail-cost ;
 C: <paragraph> paragraph
@@ -46,11 +35,11 @@ SYMBOL: line-ideal
 
 : top-fits? ( paragraph -- ? )
     [ head-width>> ]
-    [ lines>> singleton? line-ideal line-max ? get ] bi <= ;
+    [ lines>> 1list? line-ideal line-max ? get ] bi <= ;
 
 : fits? ( paragraph -- ? )
     ! Make this not count spaces at end
-    { [ lines>> car>> singleton? ] [ top-fits? ] } 1|| ;
+    { [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
 
 :: min-by ( seq quot -- elt )
     f 1.0/0.0 seq [| key value new |
@@ -65,26 +54,26 @@ SYMBOL: line-ideal
 : min-cost ( paragraphs -- paragraph )
     [ paragraph-cost ] min-by ;
 
-: new-line ( paragraph word -- paragraph )
-    [ [ lines>> ] [ <singleton> ] bi* <cons> ]
+: new-line ( paragraph element -- paragraph )
+    [ [ lines>> ] [ 1list ] bi* swons ]
     [ nip black>> ]
     [ drop paragraph-cost ] 2tri
     <paragraph> ;
 
-: glue ( paragraph word -- paragraph )
-    [ [ lines>> >cons< ] dip <cons> <cons> ]
-    [ [ head-width>> ] [ word-length ] bi* + ]
+: glue ( paragraph element -- paragraph )
+    [ [ lines>> unswons ] dip swons swons ]
+    [ [ head-width>> ] [ element-length ] bi* + ]
     [ drop tail-cost>> ] 2tri
     <paragraph> ;
 
-: wrap-step ( paragraphs word -- paragraphs )
+: wrap-step ( paragraphs element -- paragraphs )
     [ '[ _ glue ] map ]
     [ [ min-cost ] dip new-line ]
     2bi prefix
     [ fits? ] filter ;
 
-: 1paragraph ( word -- paragraph )
-    [ <singleton> <singleton> ]
+: 1paragraph ( element -- paragraph )
+    [ 1list 1list ]
     [ black>> ] bi
     0 <paragraph> ;
 
@@ -92,10 +81,10 @@ SYMBOL: line-ideal
     lines>> lists>arrays
     [ [ contents>> ] map ] map ;
 
-: initialize ( words -- words paragraph )
+: initialize ( elements -- elements paragraph )
     <reversed> unclip-slice 1paragraph 1array ;
 
-: wrap ( words line-max line-ideal -- paragraph )
+: wrap ( elements line-max line-ideal -- paragraph )
     [
         line-ideal set
         line-max set
@@ -107,50 +96,50 @@ SYMBOL: line-ideal
 
 PRIVATE>
 
-TUPLE: element key width break? ;
-C: <element> element
+TUPLE: segment key width break? ;
+C: <segment> segment
 
 <PRIVATE
 
-: elements-length ( elements -- length )
+: segments-length ( segments -- length )
     [ width>> ] map sum ;
 
-: make-word ( whites blacks -- word )
-    [ append ] [ [ elements-length ] bi@ ] 2bi <word> ;
+: make-element ( whites blacks -- element )
+    [ append ] [ [ segments-length ] bi@ ] 2bi <element> ;
  
 : ?first2 ( seq -- first/f second/f )
     [ 0 swap ?nth ]
     [ 1 swap ?nth ] bi ;
 
-: split-elements ( seq -- half-words )
+: split-segments ( seq -- half-elements )
     [ [ break?>> ] bi@ = ] monotonic-split ;
 
-: ?first-break ( seq -- newseq f/word )
+: ?first-break ( seq -- newseq f/element )
     dup first first break?>>
-    [ unclip-slice f swap make-word ]
+    [ unclip-slice f swap make-element ]
     [ f ] if ;
 
-: make-words ( seq f/word -- words )
-    [ 2 <groups> [ ?first2 make-word ] map ] dip
+: make-elements ( seq f/element -- elements )
+    [ 2 <groups> [ ?first2 make-element ] map ] dip
     [ prefix ] when* ;
 
-: elements>words ( seq -- newseq )
-    split-elements ?first-break make-words ;
+: segments>elements ( seq -- newseq )
+    split-segments ?first-break make-elements ;
 
 PRIVATE>
 
-: wrap-elements ( elements line-max line-ideal -- lines )
-    [ elements>words ] 2dip wrap [ concat ] map ;
+: wrap-segments ( segments line-max line-ideal -- lines )
+    [ segments>elements ] 2dip wrap [ concat ] map ;
 
 <PRIVATE
 
-: split-lines ( string -- words-lines )
+: split-lines ( string -- elements-lines )
     string-lines [
         " \t" split harvest
-        [ dup length 1 <word> ] map
+        [ dup length 1 <element> ] map
     ] map ;
 
-: join-words ( wrapped-lines -- lines )
+: join-elements ( wrapped-lines -- lines )
     [ " " join ] map ;
 
 : join-lines ( strings -- string )
@@ -159,7 +148,7 @@ PRIVATE>
 PRIVATE>
 
 : wrap-lines ( lines width -- newlines )
-    [ split-lines ] dip '[ _ dup wrap join-words ] map concat ;
+    [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ;
 
 : wrap-string ( string width -- newstring )
     wrap-lines join-lines ;
diff --git a/extra/lists/lazy/lazy-tests.factor b/extra/lists/lazy/lazy-tests.factor
index 5749f94364..03221841c1 100644
--- a/extra/lists/lazy/lazy-tests.factor
+++ b/extra/lists/lazy/lazy-tests.factor
@@ -1,6 +1,5 @@
 ! Copyright (C) 2006 Matthew Willis and Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-!
 USING: lists lists.lazy tools.test kernel math io sequences ;
 IN: lists.lazy.tests
 
@@ -27,3 +26,10 @@ IN: lists.lazy.tests
 [ { 4 5 6 } ] [ 
     3 { 1 2 3 } >list [ + ] lazy-map-with list>array
 ] unit-test
+
+[ [ ] lmap ] must-infer
+[ [ ] lmap>array ] must-infer
+[ [ drop ] foldr ] must-infer
+[ [ drop ] foldl ] must-infer
+[ [ drop ] leach ] must-infer
+[ lnth ] must-infer
diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor
index e60fcbaadf..213285e643 100644
--- a/extra/lists/lazy/lazy.factor
+++ b/extra/lists/lazy/lazy.factor
@@ -1,12 +1,7 @@
-! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
 ! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-! Updated by James Cash, June 2008
-!
 USING: kernel sequences math vectors arrays namespaces make
-quotations promises combinators io lists accessors ;
+quotations promises combinators io lists accessors call ;
 IN: lists.lazy
 
 M: promise car ( promise -- car )
@@ -86,7 +81,7 @@ C: <lazy-map> lazy-map
 
 M: lazy-map car ( lazy-map -- car )
     [ cons>> car ] keep
-    quot>> call ;
+    quot>> call( old -- new ) ;
 
 M: lazy-map cdr ( lazy-map -- cdr )
     [ cons>> cdr ] keep
@@ -130,7 +125,7 @@ M: lazy-until car ( lazy-until -- car )
      cons>> car ;
 
 M: lazy-until cdr ( lazy-until -- cdr )
-     [ cons>> uncons ] keep quot>> tuck call
+     [ cons>> uncons ] keep quot>> tuck call( elt -- ? )
      [ 2drop nil ] [ luntil ] if ;
 
 M: lazy-until nil? ( lazy-until -- bool )
@@ -150,7 +145,7 @@ M: lazy-while cdr ( lazy-while -- cdr )
      [ cons>> cdr ] keep quot>> lwhile ;
 
 M: lazy-while nil? ( lazy-while -- bool )
-     [ car ] keep quot>> call not ;
+     [ car ] keep quot>> call( elt -- ? ) not ;
 
 TUPLE: lazy-filter cons quot ;
 
@@ -160,7 +155,7 @@ C: <lazy-filter> lazy-filter
     over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
 
 : car-filter? ( lazy-filter -- ? )
-    [ cons>> car ] [ quot>> ] bi call ;
+    [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
 
 : skip ( lazy-filter -- )
     dup cons>> cdr >>cons drop ;
@@ -221,7 +216,7 @@ M: lazy-from-by car ( lazy-from-by -- car )
 
 M: lazy-from-by cdr ( lazy-from-by -- cdr )
     [ n>> ] keep
-    quot>> dup slip lfrom-by ;
+    quot>> [ call( old -- new ) ] keep lfrom-by ;
 
 M: lazy-from-by nil? ( lazy-from-by -- bool )
     drop f ;
@@ -355,7 +350,8 @@ M: lazy-io car ( lazy-io -- car )
     dup car>> dup [
         nip
     ] [
-        drop dup stream>> over quot>> call
+        drop dup stream>> over quot>>
+        call( stream -- value )
         >>car
     ] if ;
 
diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor
index bf822889e3..5568b9d53e 100644
--- a/extra/lists/lists.factor
+++ b/extra/lists/lists.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors math arrays vectors classes words locals ;
-
 IN: lists
 
 ! List Protocol
@@ -46,7 +45,7 @@ M: object nil? drop f ;
 : 2car ( cons -- car caar )    
     [ car ] [ cdr car ] bi ;
     
-: 3car ( cons -- car caar caaar )    
+: 3car ( cons -- car cadr caddr )    
     [ car ] [ cdr car ] [ cdr cdr car ] tri ;
 
 : lnth ( n list -- elt )
@@ -109,4 +108,4 @@ M: object nil? drop f ;
     [ 2over call [ tuck [ call ] 2dip ] when
       pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive
     
-INSTANCE: cons list
\ No newline at end of file
+INSTANCE: cons list
diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor
index 38366697ea..bec2761e53 100755
--- a/extra/promises/promises.factor
+++ b/extra/promises/promises.factor
@@ -1,10 +1,6 @@
-! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-
-USING: arrays kernel sequences math vectors arrays namespaces
+USING: arrays kernel sequences math vectors arrays namespaces call
 make quotations parser effects stack-checker words accessors ;
 IN: promises
 
@@ -24,7 +20,7 @@ TUPLE: promise quot forced? value ;
     #! promises quotation on the stack. Re-forcing the promise
     #! will return the same value and not recall the quotation.
     dup forced?>> [
-        dup quot>> call >>value
+        dup quot>> call( -- value ) >>value
         t >>forced?
     ] unless
     value>> ;