Making lazy lists compile, and using them where applicable

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 ]

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."
+"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments."
-{ $subsection wrap-elements }
+{ $subsection wrap-segments }
-{ $subsection element }
+{ $subsection segment }
-{ $subsection <element> } ;
+{ $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
+HELP: wrap-segments
-{ $values { "elements" { "a sequence of " { $instance element } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } }
+{ $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
+HELP: segment
-{ $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> } "." }
+{ $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-elements } ;
+{ $see-also wrap-segments } ;
 
-HELP: <element>
+HELP: <segment>
-{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "element" element } }
+{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } }
-{ $description "Creates an " { $link element } " object with the given parameters." }
+{ $description "Creates a " { $link segment } " object with the given parameters." }
-{ $see-also wrap-elements } ;
+{ $see-also wrap-segments } ;

basis/wrap/wrap-tests.factor

@@ -6,77 +6,77 @@ IN: wrap.tests
 [
     {
         {
-            T{ element f 1 10 f }
+            T{ segment f 1 10 f }
-            T{ element f 2 10 f }
+            T{ segment f 2 10 f }
-            T{ element f 3 2 t }
+            T{ segment f 3 2 t }
         }
         {
-            T{ element f 4 10 f }
+            T{ segment f 4 10 f }
-            T{ element f 5 10 f }
+            T{ segment f 5 10 f }
         }
     }
 ] [
     {
-        T{ element f 1 10 f }
+        T{ segment f 1 10 f }
-        T{ element f 2 10 f }
+        T{ segment f 2 10 f }
-        T{ element f 3 2 t }
+        T{ segment f 3 2 t }
-        T{ element f 4 10 f }
+        T{ segment f 4 10 f }
-        T{ element f 5 10 f }
+        T{ segment f 5 10 f }
-    } 35 35 wrap-elements [ { } like ] map
+    } 35 35 wrap-segments [ { } like ] map
 ] unit-test
 
 [
     {
         {
-            T{ element f 1 10 f }
+            T{ segment f 1 10 f }
-            T{ element f 2 10 f }
+            T{ segment f 2 10 f }
-            T{ element f 3 9 t }
+            T{ segment f 3 9 t }
-            T{ element f 3 9 t }
+            T{ segment f 3 9 t }
-            T{ element f 3 9 t }
+            T{ segment f 3 9 t }
         }
         {
-            T{ element f 4 10 f }
+            T{ segment f 4 10 f }
-            T{ element f 5 10 f }
+            T{ segment f 5 10 f }
         }
     }
 ] [
     {
-        T{ element f 1 10 f }
+        T{ segment f 1 10 f }
-        T{ element f 2 10 f }
+        T{ segment f 2 10 f }
-        T{ element f 3 9 t }
+        T{ segment f 3 9 t }
-        T{ element f 3 9 t }
+        T{ segment f 3 9 t }
-        T{ element f 3 9 t }
+        T{ segment f 3 9 t }
-        T{ element f 4 10 f }
+        T{ segment f 4 10 f }
-        T{ element f 5 10 f }
+        T{ segment f 5 10 f }
-    } 35 35 wrap-elements [ { } like ] map
+    } 35 35 wrap-segments [ { } like ] map
 ] unit-test
 
 [
     {
         {
-            T{ element f 1 10 t }
+            T{ segment f 1 10 t }
-            T{ element f 1 10 f }
+            T{ segment f 1 10 f }
-            T{ element f 3 9 t }
+            T{ segment f 3 9 t }
         }
         {
-            T{ element f 2 10 f }
+            T{ segment f 2 10 f }
-            T{ element f 3 9 t }
+            T{ segment f 3 9 t }
         }
         {
-            T{ element f 4 10 f }
+            T{ segment f 4 10 f }
-            T{ element f 5 10 f }
+            T{ segment f 5 10 f }
         }
     }
 ] [
     {
-        T{ element f 1 10 t }
+        T{ segment f 1 10 t }
-        T{ element f 1 10 f }
+        T{ segment f 1 10 f }
-        T{ element f 3 9 t }
+        T{ segment f 3 9 t }
-        T{ element f 2 10 f }
+        T{ segment f 2 10 f }
-        T{ element f 3 9 t }
+        T{ segment f 3 9 t }
-        T{ element f 4 10 f }
+        T{ segment f 4 10 f }
-        T{ element f 5 10 f }
+        T{ segment f 5 10 f }
-    } 35 35 wrap-elements [ { } like ] map
+    } 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

basis/wrap/wrap.factor

@@ -1,39 +1,28 @@
-USING: kernel sequences math arrays locals fry accessors splitting
+USING: kernel sequences math arrays locals fry accessors
-make combinators.short-circuit namespaces grouping splitting.monotonic ;
+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 ;
+TUPLE: element contents black white ;
-C: <word> word
+C: <element> element
 
-: word-length ( word -- n )
+: element-length ( element -- n )
     [ black>> ] [ white>> ] bi + ;
 
-TUPLE: cons cdr car ; ! This order works out better
+: swons ( cdr car -- cons )
-C: <cons> cons
+    swap cons ;
 
-: >cons< ( cons -- cdr car )
+: unswons ( cons -- cdr car )
-    [ cdr>> ] [ car>> ] bi ;
+    [ cdr ] [ car ] bi ;
 
-: list-each ( list quot -- )
+: 1list? ( list -- ? )
-    over [
+    { [ ] [ cdr +nil+ = ] } 1&& ;
-        [ [ 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 ;
 
 : 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 )
+: new-line ( paragraph element -- paragraph )
-    [ [ lines>> ] [ <singleton> ] bi* <cons> ]
+    [ [ lines>> ] [ 1list ] bi* swons ]
     [ nip black>> ]
     [ drop paragraph-cost ] 2tri
     <paragraph> ;
 
-: glue ( paragraph word -- paragraph )
+: glue ( paragraph element -- paragraph )
-    [ [ lines>> >cons< ] dip <cons> <cons> ]
+    [ [ lines>> unswons ] dip swons swons ]
-    [ [ head-width>> ] [ word-length ] bi* + ]
+    [ [ 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 )
+: 1paragraph ( element -- paragraph )
-    [ <singleton> <singleton> ]
+    [ 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? ;
+TUPLE: segment key width break? ;
-C: <element> element
+C: <segment> segment
 
 <PRIVATE
 
-: elements-length ( elements -- length )
+: segments-length ( segments -- length )
     [ width>> ] map sum ;
 
-: make-word ( whites blacks -- word )
+: make-element ( whites blacks -- element )
-    [ append ] [ [ elements-length ] bi@ ] 2bi <word> ;
+    [ 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 )
+: make-elements ( seq f/element -- elements )
-    [ 2 <groups> [ ?first2 make-word ] map ] dip
+    [ 2 <groups> [ ?first2 make-element ] map ] dip
     [ prefix ] when* ;
 
-: elements>words ( seq -- newseq )
+: segments>elements ( seq -- newseq )
-    split-elements ?first-break make-words ;
+    split-segments ?first-break make-elements ;
 
 PRIVATE>
 
-: wrap-elements ( elements line-max line-ideal -- lines )
+: wrap-segments ( segments line-max line-ideal -- lines )
-    [ elements>words ] 2dip wrap [ concat ] map ;
+    [ 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 ;

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

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 ;
 

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 )

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.
-!
+USING: arrays kernel sequences math vectors arrays namespaces call
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-
-USING: arrays kernel sequences math vectors arrays namespaces
 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>> ;