From 35b526cc7a034fb945342ab53c247a04abc4791c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 14:29:09 -0600 Subject: [PATCH 1/3] Docs for lists, consolidating list functionality in lists, minor API changes --- basis/lists/lazy/lazy.factor | 4 +- basis/lists/lists-docs.factor | 133 ++++++++++++++---- basis/lists/lists-tests.factor | 20 +-- basis/lists/lists.factor | 123 ++++++++++------ basis/persistent/deques/deques-docs.factor | 2 + basis/persistent/deques/deques.factor | 47 +++---- basis/urls/urls-docs.factor | 4 +- basis/wrap/wrap.factor | 14 +- core/math/math-docs.factor | 2 +- .../parser-combinators.factor | 2 +- extra/project-euler/134/134.factor | 2 +- 11 files changed, 221 insertions(+), 132 deletions(-) diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 213285e643..5adb7a8be5 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -125,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( elt -- ? ) + [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -284,7 +284,7 @@ DEFER: lconcat dup nil? [ drop nil ] [ - uncons swap (lconcat) + uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 8807c8cf8a..8494d7c352 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -1,15 +1,68 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel help.markup help.syntax ; - +USING: kernel help.markup help.syntax arrays sequences math quotations ; IN: lists -{ car cons cdr nil nil? list? uncons } related-words +ABOUT: "lists" + +ARTICLE: "lists" "Lists" +"The " { $vocab-link "lists" } " vocabulary implements linked lists. There are simple strict linked lists, but a generic list protocol allows the implementation of lazy lists as well." +{ $subsection { "lists" "protocol" } } +{ $subsection { "lists" "strict" } } +{ $subsection { "lists" "manipulation" } } +{ $subsection { "lists" "combinators" } } +{ $vocab-subsection "Lazy lists" "lists.lazy" } ; + +ARTICLE: { "lists" "protocol" } "The list protocol" +"Lists are instances of a mixin class" +{ $subsection list } +"Instances of the mixin must implement the following words:" +{ $subsection car } +{ $subsection cdr } +{ $subsection nil? } ; + +ARTICLE: { "lists" "strict" } "Strict lists" +"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:" +{ $subsection cons } +{ $subsection swons } +{ $subsection sequence>cons } +{ $subsection deep-sequence>cons } +{ $subsection 1list } +{ $subsection 2list } +{ $subsection 3list } ; + +ARTICLE: { "lists" "combinators" } "Combinators for lists" +"Several combinators exist for list traversal." +{ $subsection leach } +{ $subsection lmap } +{ $subsection foldl } +{ $subsection foldr } +{ $subsection lmap>array } +{ $subsection lmap-as } +{ $subsection traverse } ; + +ARTICLE: { "lists" "manipulation" } "Manipulating lists" +"To get at the contents of a list:" +{ $subsection uncons } +{ $subsection unswons } +{ $subsection lnth } +{ $subsection cadr } +{ $subsection llength } +"To get a new list from an old one:" +{ $subsection lreverse } +{ $subsection lappend } +{ $subsection lcut } ; HELP: cons -{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" "a cons object" } } { $description "Constructs a cons cell." } ; +HELP: swons +{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } ; + +{ cons swons uncons unswons } related-words + HELP: car { $values { "cons" "a cons object" } { "car" "the first item in the list" } } { $description "Returns the first item in the list." } ; @@ -17,7 +70,9 @@ HELP: car HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } ; - + +{ car cdr } related-words + HELP: nil { $values { "symbol" "The empty cons (+nil+)" } } { $description "Returns a symbol representing the empty list" } ; @@ -26,6 +81,8 @@ HELP: nil? { $values { "object" object } { "?" "a boolean" } } { $description "Return true if the cons object is the nil cons." } ; +{ nil nil? } related-words + HELP: list? ( object -- ? ) { $values { "object" "an object" } { "?" "a boolean" } } { $description "Returns true if the object conforms to the list protocol." } ; @@ -43,7 +100,7 @@ HELP: 2list HELP: 3list { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } { $description "Create a list with 3 elements." } ; - + HELP: lnth { $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } { $description "Outputs the nth element of the list." } @@ -55,7 +112,11 @@ HELP: llength { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +HELP: unswons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; { leach foldl lmap>array } related-words @@ -75,30 +136,52 @@ HELP: foldr HELP: lmap { $values { "list" "a cons object" } { "quot" { $quotation "( 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" } } +{ $values { "list" list } { "newlist" list } } +{ $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ; + +HELP: list>array +{ $values { "list" "a cons object" } { "array" array } } { $description "Turns the given cons object into an array, maintaing order." } ; - -HELP: seq>list -{ $values { "seq" "a sequence" } { "list" "a cons object" } } + +HELP: sequence>cons +{ $values { "sequence" sequence } { "list" cons } } { $description "Turns the given array into a cons object, maintaing order." } ; - -HELP: cons>seq -{ $values { "cons" "a cons object" } { "array" "an array object" } } + +HELP: deep-list>array +{ $values { "list" list } { "array" array } } { $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" } } + +HELP: deep-sequence>cons +{ $values { "sequence" sequence } { "cons" cons } } { $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" { $quotation "( list/elt -- ? )" } } { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" - " returns true for with the result of applying quot to." } ; - + " returns true for with the result of applying quot to." } ; + +HELP: list +{ $class-description "The class of lists. All lists are expected to conform to " { $link { "lists" "protocol" } } "." } ; + +HELP: cadr +{ $values { "list" list } { "elt" object } } +{ $description "Returns the second element of the list, ie the car of the cdr." } ; + +HELP: lappend +{ $values { "list1" list } { "list2" list } { "newlist" list } } +{ $description "Appends the two lists to form a new list. The first list must be finite. The result is a strict cons cell, and the first list is exausted." } ; + +HELP: lcut +{ $values { "list" list } { "index" integer } { "before" cons } { "after" cons } } +{ $description "Analogous to " { $link cut } ", this word cuts a list into two pieces at the given index." } ; + +HELP: lmap>array +{ $values { "list" list } { "quot" quotation } { "array" array } } +{ $description "Executes the quotation on each element of the list, collecting the results in an array." } ; + +HELP: lmap-as +{ $values { "list" list } { "quot" quotation } { "exemplar" sequence } { "sequence" sequence } } +{ $description "Executes the quotation on each element of the list, collecting the results in a sequence of the type given by the exemplar." } ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 4a08a4d1e3..404a776505 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -5,7 +5,7 @@ USING: tools.test lists math ; IN: lists.tests { { 3 4 5 6 7 } } [ - { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq + { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array ] unit-test { { 3 4 5 6 } } [ @@ -38,33 +38,33 @@ IN: lists.tests +nil+ } } } +nil+ } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons + { 1 2 { 3 4 { 5 } } } deep-sequence>cons ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array ] 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 + { 1 2 3 4 } sequence>cons [ 1+ ] lmap ] unit-test { 15 } [ - { 1 2 3 4 5 } seq>list 0 [ + ] foldr + { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr ] unit-test { { 5 4 3 2 1 } } [ - { 1 2 3 4 5 } seq>list lreverse list>seq + { 1 2 3 4 5 } sequence>cons lreverse list>array ] unit-test { 5 } [ - { 1 2 3 4 5 } seq>list llength + { 1 2 3 4 5 } sequence>cons llength ] unit-test { { 3 4 { 5 6 { 7 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array ] unit-test { { 1 2 3 4 5 6 } } [ - { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq -] unit-test \ No newline at end of file + { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array +] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 5568b9d53e..784bc95bfe 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words locals ; +USING: kernel sequences accessors math arrays vectors classes words +combinators.short-circuit combinators ; IN: lists ! List Protocol MIXIN: list -GENERIC: car ( cons -- car ) -GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( object -- ? ) +GENERIC: car ( cons -- car ) +GENERIC: cdr ( cons -- cdr ) +GENERIC: nil? ( object -- ? ) -TUPLE: cons car cdr ; +TUPLE: cons { car read-only } { cdr read-only } ; C: cons cons @@ -18,41 +19,53 @@ M: cons car ( cons -- car ) M: cons cdr ( cons -- cdr ) cdr>> ; - -SYMBOL: +nil+ -M: word nil? +nil+ eq? ; + +SINGLETON: +nil+ +M: +nil+ nil? drop t ; M: object nil? drop f ; - -: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; + +: atom? ( obj -- ? ) + { [ list? ] [ nil? ] } 1|| not ; : nil ( -- symbol ) +nil+ ; - -: uncons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - + +: uncons ( cons -- car cdr ) + [ car ] [ cdr ] bi ; + +: swons ( cdr car -- cons ) + swap cons ; + +: unswons ( cons -- cdr car ) + uncons swap ; + : 1list ( obj -- cons ) nil cons ; - + +: 1list? ( list -- ? ) + { [ nil? not ] [ cdr nil? ] } 1&& ; + : 2list ( a b -- cons ) nil cons cons ; : 3list ( a b c -- cons ) nil cons cons cons ; - -: cadr ( cons -- elt ) + +: cadr ( list -- elt ) cdr car ; - -: 2car ( cons -- car caar ) + +: 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; - -: 3car ( cons -- car cadr caddr ) + +: 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; : lnth ( n list -- elt ) swap [ cdr ] times car ; - + + : leach ( list quot: ( elt -- ) -- ) over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive @@ -71,41 +84,59 @@ M: object nil? drop f ; : llength ( list -- n ) 0 [ drop 1+ ] foldl ; - + : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; - + : lappend ( list1 list2 -- newlist ) [ lreverse ] dip [ swap cons ] foldl ; - -: seq>list ( seq -- list ) + +: lcut ( list index -- before after ) + [ +nil+ ] dip + [ [ [ cdr ] [ car ] bi ] dip cons ] times + lreverse swap ; + +: sequence>cons ( sequence -- list ) nil [ swap cons ] reduce ; - + +cons ( seq -- cons ) - [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; - +PRIVATE> + +: deep-sequence>cons ( sequence -- cons ) + [ ] keep nil + [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + +array) ( acc cons quot: ( elt -- elt' ) -- newcons ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; + [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline recursive - -: lmap>array ( cons quot -- newcons ) - { } -rot (lmap>array) ; inline - -: lmap-as ( cons quot exemplar -- seq ) +PRIVATE> + +: lmap>array ( list quot -- array ) + [ { } ] 2dip (lmap>array) ; inline + +: lmap-as ( list quot exemplar -- sequence ) [ lmap>array ] dip like ; - -: cons>seq ( cons -- array ) - [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ; - -: list>seq ( list -- array ) + +: deep-list>array ( list -- array ) + [ + { + { [ dup list? ] [ deep-list>array ] } + { [ dup nil? ] [ drop { } ] } + [ ] + } cond + ] lmap>array ; + +: list>array ( list -- array ) [ ] lmap>array ; - + : traverse ( list pred quot: ( list/elt -- result ) -- result ) - [ 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive - + [ + 2over call [ tuck [ call ] 2dip ] when + pick list? [ traverse ] [ 2drop ] if + ] 2curry lmap ; inline recursive + INSTANCE: cons list diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor index 43018bed16..f1027d107b 100644 --- a/basis/persistent/deques/deques-docs.factor +++ b/basis/persistent/deques/deques-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences ; IN: persistent.deques diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index ece1cda772..8f93ae1ab8 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,7 +1,6 @@ -! Copyback (C) 2008 Daniel Ehrenberg +! Copyright (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math lists ; -QUALIFIED: sequences +USING: kernel accessors math lists sequences combinators.short-circuit ; IN: persistent.deques ! Amortized O(1) push/pop on both ends for single-threaded access @@ -9,30 +8,13 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. TUPLE: deque { front read-only } { back read-only } ; -: ( -- deque ) T{ deque } ; +: ( -- deque ) + T{ deque f +nil+ +nil+ } ; : deque-empty? ( deque -- ? ) - [ front>> ] [ back>> ] bi or not ; + { [ front>> nil? ] [ back>> nil? ] } 1&& ; [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline : transfer ( deque -- item newdeque ) - back>> [ split-reverse deque boa remove ] - [ "Popping from an empty deque" throw ] if* ; inline + back>> dup nil? + [ "Popping from an empty deque" throw ] + [ split-reverse deque boa remove ] if ; inline : pop ( deque -- item newdeque ) - dup front>> [ remove ] [ transfer ] if ; inline + dup front>> nil? [ transfer ] [ remove ] if ; inline PRIVATE> : pop-front ( deque -- item newdeque ) @@ -74,12 +57,14 @@ PRIVATE> : pop-back ( deque -- item newdeque ) [ pop ] flipped ; -: peek-front ( deque -- item ) pop-front drop ; +: peek-front ( deque -- item ) + pop-front drop ; -: peek-back ( deque -- item ) pop-back drop ; +: peek-back ( deque -- item ) + pop-back drop ; : sequence>deque ( sequence -- deque ) - [ push-back ] sequences:reduce ; + [ push-back ] reduce ; : deque>sequence ( deque -- sequence ) - [ dup deque-empty? not ] [ pop-front swap ] [ ] sequences:produce nip ; + [ dup deque-empty? not ] [ pop-front swap ] [ ] produce nip ; diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index f6c25980ea..437a9419e3 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -82,8 +82,8 @@ HELP: parse-host { $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." } { $examples { $example - "USING: prettyprint urls ;" - "\"sbcl.org:80\" parse-host .s" + "USING: prettyprint urls kernel ;" + "\"sbcl.org:80\" parse-host .s 2drop" "\"sbcl.org\"\n80" } } ; diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 55fe10283a..6e5bf31075 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -12,18 +12,6 @@ C: element : element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -: swons ( cdr car -- cons ) - swap cons ; - -: unswons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - -: 1list? ( list -- ? ) - { [ ] [ cdr +nil+ = ] } 1&& ; - -: lists>arrays ( lists -- arrays ) - [ list>seq ] lmap>array ; - TUPLE: paragraph lines head-width tail-cost ; C: paragraph @@ -78,7 +66,7 @@ SYMBOL: line-ideal 0 ; : post-process ( paragraph -- array ) - lines>> lists>arrays + lines>> deep-list>array [ [ contents>> ] map ] map ; : initialize ( elements -- elements paragraph ) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 7d0666328f..94ff2c1f29 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -254,7 +254,7 @@ HELP: fp-infinity? { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } { $examples { $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" } - { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" } + { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; { fp-nan? fp-infinity? } related-words diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 8afbb2d03b..347ab638ff 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -17,7 +17,7 @@ ERROR: cannot-parse input ; : parse-1 ( input parser -- result ) dupd parse dup nil? [ - rot cannot-parse + swap cannot-parse ] [ nip car parsed>> ] if ; diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index e00e86865d..0f009919d9 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -39,7 +39,7 @@ IN: project-euler.134 PRIVATE> : euler134 ( -- answer ) - 0 5 lprimes-from uncons swap [ 1000000 > ] luntil + 0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time From 975f197558c5efc49e43c87477b50bcaea64d962 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 14:37:22 -0600 Subject: [PATCH 2/3] Fixing help-lint bugs --- .../generalizations-docs.factor | 20 +++++++++---------- core/kernel/kernel-docs.factor | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index ac8e14c05a..376ae5bed2 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -58,7 +58,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } + { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" } "Some core words expressed in terms of " { $link npick } ":" { $table { { $link dup } { $snippet "1 npick" } } @@ -75,7 +75,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" } "Some core words expressed in terms of " { $link ndup } ":" { $table { { $link dup } { $snippet "1 ndup" } } @@ -91,7 +91,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" } "Some core words expressed in terms of " { $link nnip } ":" { $table { { $link nip } { $snippet "1 nnip" } } @@ -106,7 +106,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" } "Some core words expressed in terms of " { $link ndrop } ":" { $table { { $link drop } { $snippet "1 ndrop" } } @@ -121,7 +121,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" } "Some core words expressed in terms of " { $link nrot } ":" { $table { { $link swap } { $snippet "1 nrot" } } @@ -135,7 +135,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" } "Some core words expressed in terms of " { $link -nrot } ":" { $table { { $link swap } { $snippet "1 -nrot" } } @@ -151,8 +151,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" } "Some core words expressed in terms of " { $link ndip } ":" { $table { { $link dip } { $snippet "1 ndip" } } @@ -168,7 +168,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nslip } ":" { $table { { $link slip } { $snippet "1 nslip" } } @@ -184,7 +184,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nkeep } ":" { $table { { $link keep } { $snippet "1 nkeep" } } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 71183093ee..b8191004db 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -658,7 +658,7 @@ HELP: loop "hi hi hi" } "A fun loop:" { $example "USING: kernel prettyprint math ; " - "3 [ dup . 7 + 11 mod dup 3 = not ] loop" + "3 [ dup . 7 + 11 mod dup 3 = not ] loop drop" "3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" } } ; From 462b208475382fc240648a92a296c95be90d8520 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 15:31:57 -0600 Subject: [PATCH 3/3] Cleaning up strict list combinators --- basis/lists/lists-tests.factor | 5 ++-- basis/lists/lists.factor | 47 +++++++++++++++++++--------------- basis/wrap/words/words.factor | 2 +- 3 files changed, 30 insertions(+), 24 deletions(-) diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 404a776505..13d2e03e0f 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lists math ; - +USING: tools.test lists math kernel ; IN: lists.tests { { 3 4 5 6 7 } } [ @@ -68,3 +67,5 @@ IN: lists.tests { { 1 2 3 4 5 6 } } [ { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array ] unit-test + +[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 784bc95bfe..4b0abb7f2d 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words -combinators.short-circuit combinators ; +combinators.short-circuit combinators locals ; IN: lists ! List Protocol @@ -25,7 +25,7 @@ M: +nil+ nil? drop t ; M: object nil? drop f ; : atom? ( obj -- ? ) - { [ list? ] [ nil? ] } 1|| not ; + list? not ; : nil ( -- symbol ) +nil+ ; @@ -76,10 +76,10 @@ PRIVATE> : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result ) swapd leach ; inline -: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) - pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ - [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi - call +:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) + list nil? [ identity ] [ + list cdr identity quot foldr + list car quot call ] if ; inline recursive : llength ( list -- n ) @@ -92,7 +92,7 @@ PRIVATE> [ lreverse ] dip [ swap cons ] foldl ; : lcut ( list index -- before after ) - [ +nil+ ] dip + [ nil ] dip [ [ [ cdr ] [ car ] bi ] dip cons ] times lreverse swap ; @@ -109,23 +109,27 @@ PRIVATE> [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; array) ( acc cons quot: ( elt -- elt' ) -- newcons ) - over nil? [ 2drop ] - [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; - inline recursive +:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc ) + list nil? [ acc ] [ + list car quot call acc push + acc list cdr quot (lmap>vector) + ] if ; inline recursive + +: lmap>vector ( list quot -- array ) + [ V{ } clone ] 2dip (lmap>vector) ; inline PRIVATE> -: lmap>array ( list quot -- array ) - [ { } ] 2dip (lmap>array) ; inline - : lmap-as ( list quot exemplar -- sequence ) - [ lmap>array ] dip like ; + [ lmap>vector ] dip like ; inline + +: lmap>array ( list quot -- array ) + { } lmap-as ; inline : deep-list>array ( list -- array ) [ { - { [ dup list? ] [ deep-list>array ] } { [ dup nil? ] [ drop { } ] } + { [ dup list? ] [ deep-list>array ] } [ ] } cond ] lmap>array ; @@ -133,10 +137,11 @@ PRIVATE> : list>array ( list -- array ) [ ] lmap>array ; -: traverse ( list pred quot: ( list/elt -- result ) -- result ) - [ - 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if - ] 2curry lmap ; inline recursive +:: traverse ( list pred quot: ( list/elt -- result ) -- result ) + list [| elt | + elt dup pred call [ quot call ] when + dup list? [ pred quot traverse ] when + ] lmap ; inline recursive INSTANCE: cons list +INSTANCE: +nil+ list diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor index 00f257a5cf..bcf4460170 100644 --- a/basis/wrap/words/words.factor +++ b/basis/wrap/words/words.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel splitting.monotonic accessors wrap grouping ; +USING: sequences kernel splitting.monotonic accessors grouping wrap ; IN: wrap.words TUPLE: word key width break? ;