Making lazy lists compile, and using them where applicable
Daniel Ehrenberg
parent
af9f5112d4
commit
c4aa14b9d9
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
INSTANCE: cons list
|
||||
|
|
|
|||
|
|
@ -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>> ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue