From 4eab045deb13696f75b01b994f5ac26c4034a022 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 00:24:24 -0500 Subject: [PATCH 1/5] add nth-unsafe to sequences.private, making md5 faster --- basis/checksums/md5/md5.factor | 42 +++++++++++++++++---------------- core/checksums/checksums.factor | 14 ++++++----- core/sequences/sequences.factor | 3 +++ 3 files changed, 33 insertions(+), 26 deletions(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 026df34012..89ff5d46a2 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -4,7 +4,8 @@ USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings sequences byte-arrays locals sequences.private macros fry io.encodings.binary math.bitwise checksums accessors -checksums.common checksums.stream combinators combinators.smart ; +checksums.common checksums.stream combinators combinators.smart +specialized-arrays.uint literals ; IN: checksums.md5 SINGLETON: md5 @@ -16,7 +17,7 @@ TUPLE: md5-state < checksum-state state old-state ; : ( -- md5 ) md5-state new-checksum-state 64 >>block-size - { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } + uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; M: md5 initialize-checksum-state drop ; @@ -29,8 +30,10 @@ M: md5 initialize-checksum-state drop ; [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri [ (>>old-state) ] [ (>>state) ] bi ; inline -: T ( N -- Y ) - sin abs 32 2^ * >integer ; inline +CONSTANT: T + $[ + 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as + ] :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z @@ -70,22 +73,22 @@ CONSTANT: b 1 CONSTANT: c 2 CONSTANT: d 3 -:: (ABCD) ( x V a b c d k s i quot -- ) +:: (ABCD) ( x state a b c d k s i quot -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) - a V [ - b V nth - c V nth - d V nth quot call w+ - k x nth w+ - i T w+ + a state [ + b state nth-unsafe + c state nth-unsafe + d state nth-unsafe quot call w+ + k x nth-unsafe w+ + i T nth-unsafe w+ s bitroll-32 - b V nth w+ - ] change-nth ; inline + b state nth-unsafe w+ 32 bits + ] change-nth-unsafe ; inline MACRO: with-md5-round ( ops quot -- ) '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ; -: (process-md5-block-F) ( block v -- ) +: (process-md5-block-F) ( block state -- ) { [ a b c d 0 S11 1 ] [ d a b c 1 S12 2 ] @@ -105,7 +108,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 15 S14 16 ] } [ F ] with-md5-round ; inline -: (process-md5-block-G) ( block v -- ) +: (process-md5-block-G) ( block state -- ) { [ a b c d 1 S21 17 ] [ d a b c 6 S22 18 ] @@ -125,7 +128,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 12 S24 32 ] } [ G ] with-md5-round ; inline -: (process-md5-block-H) ( block v -- ) +: (process-md5-block-H) ( block state -- ) { [ a b c d 5 S31 33 ] [ d a b c 8 S32 34 ] @@ -145,7 +148,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 2 S34 48 ] } [ H ] with-md5-round ; inline -: (process-md5-block-I) ( block v -- ) +: (process-md5-block-I) ( block state -- ) { [ a b c d 0 S41 49 ] [ d a b c 7 S42 50 ] @@ -167,7 +170,7 @@ MACRO: with-md5-round ( ops quot -- ) M: md5-state checksum-block ( block state -- ) [ - [ 4 [ le> ] map ] [ state>> ] bi* { + [ byte-array>uint-array ] [ state>> ] bi* { [ (process-md5-block-F) ] [ (process-md5-block-G) ] [ (process-md5-block-H) ] @@ -177,8 +180,7 @@ M: md5-state checksum-block ( block state -- ) nip update-md5 ] 2bi ; -: md5>checksum ( md5 -- bytes ) - state>> [ 4 >le ] map B{ } concat-as ; +: md5>checksum ( md5 -- bytes ) state>> underlying>> ; M: md5-state clone ( md5 -- new-md5 ) call-next-method diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 9d40521fc8..0dd808c722 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,17 +1,17 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors io io.backend io.files kernel math math.parser -sequences vectors quotations ; +sequences byte-arrays byte-vectors quotations ; IN: checksums MIXIN: checksum -TUPLE: checksum-state bytes-read block-size bytes ; +TUPLE: checksum-state + { bytes-read integer } { block-size integer } { bytes byte-vector } ; : new-checksum-state ( class -- checksum-state ) new - 0 >>bytes-read - V{ } clone >>bytes ; inline + BV{ } clone >>bytes ; inline M: checksum-state clone call-next-method @@ -27,11 +27,13 @@ GENERIC: get-checksum ( checksum -- value ) over bytes>> [ push-all ] keep [ dup length pick block-size>> >= ] [ - 64 cut-slice [ + 64 cut-slice [ >byte-array ] dip [ over [ checksum-block ] [ [ 64 + ] change-bytes-read drop ] bi ] dip - ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; + ] while + >byte-vector + [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; : add-checksum-stream ( checksum-state stream -- checksum-state ) [ diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 99dddb8aed..9b0f4c1530 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -88,6 +88,9 @@ M: sequence set-nth bounds-check set-nth-unsafe ; M: sequence nth-unsafe nth ; M: sequence set-nth-unsafe set-nth ; +: change-nth-unsafe ( i seq quot -- ) + [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline + ! The f object supports the sequence protocol trivially M: f length drop 0 ; M: f nth-unsafe nip ; From 54cb1b968644e7d4d6b6f783dc8a3bc6aad8f68a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 02:16:03 -0500 Subject: [PATCH 2/5] median used the wrong algorithm. now it runs in O(n) time. add kth-smallest word, used to implement median --- basis/math/statistics/statistics-tests.factor | 18 ++++++ basis/math/statistics/statistics.factor | 58 ++++++++++++++++--- 2 files changed, 67 insertions(+), 9 deletions(-) diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index b6ff421956..c160d57db7 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -13,6 +13,24 @@ IN: math.statistics.tests [ 2 ] [ { 1 2 3 } median ] unit-test [ 5/2 ] [ { 1 2 3 4 } median ] unit-test +[ { } median ] must-fail +[ { } upper-median ] must-fail +[ { } lower-median ] must-fail + +[ 2 ] [ { 1 2 3 4 } lower-median ] unit-test +[ 3 ] [ { 1 2 3 4 } upper-median ] unit-test +[ 3 ] [ { 1 2 3 4 5 } lower-median ] unit-test +[ 3 ] [ { 1 2 3 4 5 } upper-median ] unit-test + + +[ 1 ] [ { 1 } lower-median ] unit-test +[ 1 ] [ { 1 } upper-median ] unit-test +[ 1 ] [ { 1 } median ] unit-test + +[ 1 ] [ { 1 2 } lower-median ] unit-test +[ 2 ] [ { 1 2 } upper-median ] unit-test +[ 3/2 ] [ { 1 2 } median ] unit-test + [ 1 ] [ { 1 2 3 } var ] unit-test [ 1.0 ] [ { 1 2 3 } std ] unit-test [ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 4cd8c5b888..5b0439906c 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman, Michael Judge. ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators kernel math math.analysis -math.functions math.order sequences sorting ; +math.functions math.order sequences sorting locals +sequences.private ; IN: math.statistics : mean ( seq -- n ) @@ -13,13 +14,55 @@ IN: math.statistics : harmonic-mean ( seq -- n ) [ recip ] sigma recip ; -: median ( seq -- n ) +: slow-median ( seq -- n ) natural-sort dup length even? [ [ midpoint@ dup 1 - 2array ] keep nths mean ] [ [ midpoint@ ] keep nth ] if ; +:: kth-smallest ( seq k -- elt ) + #! Wirth's method, Algorithm's + Data structues = Programs p. 84 + #! The algorithm modifiers seq, so we clone it + seq clone :> seq + 0 :> i! + 0 :> j! + 0 :> l! + 0 :> x! + seq length 1 - :> m! + [ l m < ] + [ + k seq nth x! + l i! + m j! + [ i j <= ] + [ + [ i seq nth-unsafe x < ] [ i 1 + i! ] while + [ x j seq nth-unsafe < ] [ j 1 - j! ] while + i j <= [ + i j seq exchange + i 1 + i! + j 1 - j! + ] when + ] do while + + j k < [ i l! ] when + k i < [ j m! ] when + ] while + k seq nth ; inline + +: lower-median ( seq -- elt ) + dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ; + +: upper-median ( seq -- elt ) + dup midpoint@ kth-smallest ; + +: medians ( seq -- lower upper ) + [ lower-median ] [ upper-median ] bi ; + +: median ( seq -- x ) + dup length odd? [ lower-median ] [ medians + 2 / ] if ; + : minmax ( seq -- min max ) #! find the min and max of a seq in one pass [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ; @@ -32,15 +75,13 @@ IN: math.statistics dup length 1 <= [ drop 0 ] [ - [ [ mean ] keep [ - sq ] with sigma ] keep - length 1 - / + [ [ mean ] keep [ - sq ] with sigma ] + [ length 1 - ] bi / ] if ; -: std ( seq -- x ) - var sqrt ; +: std ( seq -- x ) var sqrt ; -: ste ( seq -- x ) - [ std ] [ length ] bi sqrt / ; +: ste ( seq -- x ) [ std ] [ length ] bi sqrt / ; : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) ! finds sigma((xi-mean(x))(yi-mean(y)) @@ -64,4 +105,3 @@ IN: math.statistics [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy swap / * ! stack is mean(x) mean(y) beta [ swapd * - ] keep ; - From c045823182821f8b99540f37045585e7955eeab9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 02:41:58 -0500 Subject: [PATCH 3/5] remove old median, fix docs --- basis/math/statistics/statistics-docs.factor | 10 +++++----- basis/math/statistics/statistics.factor | 15 ++++----------- 2 files changed, 9 insertions(+), 16 deletions(-) diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 7a7eb70dd2..1a29d611f9 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -2,26 +2,26 @@ USING: help.markup help.syntax debugger ; IN: math.statistics HELP: geometric-mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } { $notes "Positive reals only." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: median -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" } @@ -29,7 +29,7 @@ HELP: median { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: range -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" } diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 5b0439906c..3812e79ec5 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -5,22 +5,15 @@ math.functions math.order sequences sorting locals sequences.private ; IN: math.statistics -: mean ( seq -- n ) +: mean ( seq -- x ) [ sum ] [ length ] bi / ; -: geometric-mean ( seq -- n ) +: geometric-mean ( seq -- x ) [ length ] [ product ] bi nth-root ; -: harmonic-mean ( seq -- n ) +: harmonic-mean ( seq -- x ) [ recip ] sigma recip ; -: slow-median ( seq -- n ) - natural-sort dup length even? [ - [ midpoint@ dup 1 - 2array ] keep nths mean - ] [ - [ midpoint@ ] keep nth - ] if ; - :: kth-smallest ( seq k -- elt ) #! Wirth's method, Algorithm's + Data structues = Programs p. 84 #! The algorithm modifiers seq, so we clone it @@ -67,7 +60,7 @@ IN: math.statistics #! find the min and max of a seq in one pass [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ; -: range ( seq -- n ) +: range ( seq -- x ) minmax swap - ; : var ( seq -- x ) From 241c2ea8466dc203f2c1139703194976791c2ec3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 12:27:04 -0500 Subject: [PATCH 4/5] llines was broken. it still probably is -- what if the stream throws an exception? cleanup some old code --- basis/lists/lazy/lazy-tests.factor | 6 +- basis/lists/lazy/lazy.factor | 127 +++++++++++++---------------- basis/promises/promises.factor | 4 +- 3 files changed, 62 insertions(+), 75 deletions(-) diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index f4e55cba19..8fb638b856 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -1,6 +1,7 @@ ! 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 ; +USING: io io.encodings.utf8 io.files kernel lists lists.lazy +math sequences tools.test ; IN: lists.lazy.tests [ { 1 2 3 4 } ] [ @@ -33,3 +34,6 @@ IN: lists.lazy.tests [ [ drop ] foldl ] must-infer [ [ drop ] leach ] must-infer [ lnth ] must-infer + +[ ] [ "resource:license.txt" utf8 llines list>array drop ] unit-test +[ ] [ "resource:license.txt" utf8 lcontents list>array drop ] unit-test diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 49aee471bf..bde26e2fb9 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math vectors arrays namespaces make -quotations promises combinators io lists accessors ; +USING: accessors arrays combinators io kernel lists math +promises quotations sequences summary vectors ; IN: lists.lazy M: promise car ( promise -- car ) @@ -10,16 +10,16 @@ M: promise car ( promise -- car ) M: promise cdr ( promise -- cdr ) force cdr ; -M: promise nil? ( cons -- bool ) +M: promise nil? ( cons -- ? ) force nil? ; - + ! Both 'car' and 'cdr' are promises TUPLE: lazy-cons car cdr ; : lazy-cons ( car cdr -- promise ) - [ promise ] bi@ \ lazy-cons boa - T{ promise f f t f } clone - swap >>value ; + [ T{ promise f f t f } clone ] 2dip + [ promise ] bi@ \ lazy-cons boa + >>value ; M: lazy-cons car ( lazy-cons -- car ) car>> force ; @@ -27,7 +27,7 @@ M: lazy-cons car ( lazy-cons -- car ) M: lazy-cons cdr ( lazy-cons -- cdr ) cdr>> force ; -M: lazy-cons nil? ( lazy-cons -- bool ) +M: lazy-cons nil? ( lazy-cons -- ? ) nil eq? ; : 1lazy-list ( a -- lazy-cons ) @@ -41,11 +41,9 @@ M: lazy-cons nil? ( lazy-cons -- bool ) TUPLE: memoized-cons original car cdr nil? ; -: not-memoized ( -- obj ) - { } ; +: not-memoized ( -- obj ) { } ; -: not-memoized? ( obj -- bool ) - not-memoized eq? ; +: not-memoized? ( obj -- ? ) not-memoized eq? ; : ( cons -- memoized-cons ) not-memoized not-memoized not-memoized @@ -65,7 +63,7 @@ M: memoized-cons cdr ( memoized-cons -- cdr ) cdr>> ] if ; -M: memoized-cons nil? ( memoized-cons -- bool ) +M: memoized-cons nil? ( memoized-cons -- ? ) dup nil?>> not-memoized? [ dup original>> nil? [ >>nil? drop ] keep ] [ @@ -80,14 +78,12 @@ C: lazy-map over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) - [ cons>> car ] keep - quot>> call( old -- new ) ; + [ cons>> car ] [ quot>> call( old -- new ) ] bi ; M: lazy-map cdr ( lazy-map -- cdr ) - [ cons>> cdr ] keep - quot>> lazy-map ; + [ cons>> cdr ] [ quot>> lazy-map ] bi ; -M: lazy-map nil? ( lazy-map -- bool ) +M: lazy-map nil? ( lazy-map -- ? ) cons>> nil? ; TUPLE: lazy-take n cons ; @@ -95,7 +91,7 @@ TUPLE: lazy-take n cons ; C: lazy-take : ltake ( n list -- result ) - over zero? [ 2drop nil ] [ ] if ; + over zero? [ 2drop nil ] [ ] if ; M: lazy-take car ( lazy-take -- car ) cons>> car ; @@ -104,12 +100,8 @@ M: lazy-take cdr ( lazy-take -- cdr ) [ n>> 1- ] keep cons>> cdr ltake ; -M: lazy-take nil? ( lazy-take -- bool ) - dup n>> zero? [ - drop t - ] [ - cons>> nil? - ] if ; +M: lazy-take nil? ( lazy-take -- ? ) + dup n>> zero? [ drop t ] [ cons>> nil? ] if ; TUPLE: lazy-until cons quot ; @@ -125,7 +117,7 @@ M: lazy-until cdr ( lazy-until -- cdr ) [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; -M: lazy-until nil? ( lazy-until -- bool ) +M: lazy-until nil? ( lazy-until -- ? ) drop f ; TUPLE: lazy-while cons quot ; @@ -141,7 +133,7 @@ M: lazy-while car ( lazy-while -- car ) M: lazy-while cdr ( lazy-while -- cdr ) [ cons>> cdr ] keep quot>> lwhile ; -M: lazy-while nil? ( lazy-while -- bool ) +M: lazy-while nil? ( lazy-while -- ? ) [ car ] keep quot>> call( elt -- ? ) not ; TUPLE: lazy-filter cons quot ; @@ -167,7 +159,7 @@ M: lazy-filter cdr ( lazy-filter -- cdr ) dup skip cdr ] if ; -M: lazy-filter nil? ( lazy-filter -- bool ) +M: lazy-filter nil? ( lazy-filter -- ? ) dup cons>> nil? [ drop t ] [ @@ -189,10 +181,9 @@ M: lazy-append car ( lazy-append -- car ) list1>> car ; M: lazy-append cdr ( lazy-append -- cdr ) - [ list1>> cdr ] keep - list2>> lappend ; + [ list1>> cdr ] [ list2>> ] bi lappend ; -M: lazy-append nil? ( lazy-append -- bool ) +M: lazy-append nil? ( lazy-append -- ? ) drop f ; TUPLE: lazy-from-by n quot ; @@ -209,7 +200,7 @@ M: lazy-from-by cdr ( lazy-from-by -- cdr ) [ n>> ] keep quot>> [ call( old -- new ) ] keep lfrom-by ; -M: lazy-from-by nil? ( lazy-from-by -- bool ) +M: lazy-from-by nil? ( lazy-from-by -- ? ) drop f ; TUPLE: lazy-zip list1 list2 ; @@ -226,14 +217,14 @@ M: lazy-zip car ( lazy-zip -- car ) M: lazy-zip cdr ( lazy-zip -- cdr ) [ list1>> cdr ] keep list2>> cdr lzip ; -M: lazy-zip nil? ( lazy-zip -- bool ) +M: lazy-zip nil? ( lazy-zip -- ? ) drop f ; TUPLE: sequence-cons index seq ; C: sequence-cons -: seq>list ( index seq -- list ) +: sequence-tail>list ( index seq -- list ) 2dup length >= [ 2drop nil ] [ @@ -241,21 +232,24 @@ C: sequence-cons ] if ; M: sequence-cons car ( sequence-cons -- car ) - [ index>> ] keep - seq>> nth ; + [ index>> ] [ seq>> nth ] bi ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ index>> 1+ ] keep - seq>> seq>list ; + [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ; -M: sequence-cons nil? ( sequence-cons -- bool ) +M: sequence-cons nil? ( sequence-cons -- ? ) drop f ; +ERROR: list-conversion-error object ; + +M: list-conversion-error summary + drop "Could not convert object to list" ; + : >list ( object -- list ) { - { [ dup sequence? ] [ 0 swap seq>list ] } - { [ dup list? ] [ ] } - [ "Could not convert object to a list" throw ] + { [ dup sequence? ] [ 0 swap sequence-tail>list ] } + { [ dup list? ] [ ] } + [ list-conversion-error ] } cond ; TUPLE: lazy-concat car cdr ; @@ -265,18 +259,10 @@ C: lazy-concat DEFER: lconcat : (lconcat) ( car cdr -- list ) - over nil? [ - nip lconcat - ] [ - - ] if ; + over nil? [ nip lconcat ] [ ] if ; : lconcat ( list -- result ) - dup nil? [ - drop nil - ] [ - uncons (lconcat) - ] if ; + dup nil? [ drop nil ] [ uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) car>> car ; @@ -284,12 +270,8 @@ M: lazy-concat car ( lazy-concat -- car ) M: lazy-concat cdr ( lazy-concat -- cdr ) [ car>> cdr ] keep cdr>> (lconcat) ; -M: lazy-concat nil? ( lazy-concat -- bool ) - dup car>> nil? [ - cdr>> nil? - ] [ - drop f - ] if ; +M: lazy-concat nil? ( lazy-concat -- ? ) + dup car>> nil? [ cdr>> nil? ] [ drop f ] if ; : lcartesian-product ( list1 list2 -- result ) swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; @@ -298,7 +280,9 @@ M: lazy-concat nil? ( lazy-concat -- bool ) dup nil? [ drop nil ] [ - [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ + [ car ] [ cdr ] bi + [ car lcartesian-product ] [ cdr ] bi + list>array swap [ swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat ] reduce ] if ; @@ -322,9 +306,9 @@ DEFER: lmerge : lmerge ( list1 list2 -- result ) { - { [ over nil? ] [ nip ] } - { [ dup nil? ] [ drop ] } - { [ t ] [ (lmerge) ] } + { [ over nil? ] [ nip ] } + { [ dup nil? ] [ drop ] } + { [ t ] [ (lmerge) ] } } cond ; TUPLE: lazy-io stream car cdr quot ; @@ -338,30 +322,29 @@ C: lazy-io f f [ stream-readln ] ; M: lazy-io car ( lazy-io -- car ) - dup car>> dup [ + dup car>> [ nip ] [ - drop dup stream>> over quot>> - call( stream -- value ) - >>car - ] if ; + [ ] [ stream>> ] [ quot>> ] tri + call( stream -- value ) [ >>car ] [ drop nil ] if* + ] if* ; M: lazy-io cdr ( lazy-io -- cdr ) dup cdr>> dup [ nip ] [ drop dup - [ stream>> ] keep - [ quot>> ] keep - car [ + [ stream>> ] + [ quot>> ] + [ car ] tri [ [ f f ] dip [ >>cdr drop ] keep ] [ 3drop nil ] if ] if ; -M: lazy-io nil? ( lazy-io -- bool ) - car not ; +M: lazy-io nil? ( lazy-io -- ? ) + car nil? ; INSTANCE: sequence-cons list INSTANCE: memoized-cons list diff --git a/basis/promises/promises.factor b/basis/promises/promises.factor index c3951f46ba..cd98827206 100755 --- a/basis/promises/promises.factor +++ b/basis/promises/promises.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math arrays namespaces -parser effects generalizations fry words accessors ; +USING: accessors arrays effects fry generalizations kernel math +namespaces parser sequences words ; IN: promises TUPLE: promise quot forced? value ; From f33883658a0e1acc536799f8005c9df5e09bacbc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 16:17:11 -0500 Subject: [PATCH 5/5] fix lazy lists --- basis/lists/lazy/lazy-docs.factor | 8 ++++---- extra/parser-combinators/parser-combinators.factor | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index 0b1bfe2d02..e7401d6af1 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -33,7 +33,7 @@ ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists" { $subsection 1lazy-list } { $subsection 2lazy-list } { $subsection 3lazy-list } -{ $subsection seq>list } +{ $subsection sequence-tail>list } { $subsection >list } { $subsection lfrom } ; @@ -105,15 +105,15 @@ HELP: lfrom { $values { "n" "an integer" } { "list" "a lazy list of integers" } } { $description "Return an infinite lazy list of incrementing integers starting from n." } ; -HELP: seq>list +HELP: sequence-tail>list { $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } } { $description "Convert the sequence into a list, starting from " { $snippet "index" } "." } { $see-also >list } ; HELP: >list { $values { "object" "an object" } { "list" "a 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 } ; +{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link sequence-tail>list } " and other objects cause an error to be thrown." } +{ $see-also sequence-tail>list } ; { leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 030d0a2a73..814821fba9 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -172,7 +172,7 @@ M: or-parser parse ( input parser1 -- list ) #! Return the combined list resulting from the parses #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. - parsers>> 0 swap seq>list + parsers>> sequence>list [ parse ] with lazy-map lconcat ; : trim-head-slice ( string -- string )