From 9fd675a632db492958366bc85e4e99e1646691c5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 5 Feb 2009 10:28:57 +0100 Subject: [PATCH 01/16] FUEL: Accept '?' in prompts for word and vocabs. --- misc/fuel/fuel-completion.el | 33 ++++++++++++++++++++++++++------- misc/fuel/fuel-edit.el | 9 +-------- misc/fuel/fuel-help.el | 2 +- misc/fuel/fuel-markup.el | 3 ++- misc/fuel/fuel-scaffold.el | 2 +- misc/fuel/fuel-xref.el | 2 +- 6 files changed, 32 insertions(+), 19 deletions(-) diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el index e6ec8b2dc9..165a9d9b66 100644 --- a/misc/fuel/fuel-completion.el +++ b/misc/fuel/fuel-completion.el @@ -18,6 +18,15 @@ (require 'fuel-eval) (require 'fuel-log) + +;;; Aux: + +(defvar fuel-completion--minibuffer-map + (let ((map (make-keymap))) + (set-keymap-parent map minibuffer-local-completion-map) + (define-key map "?" 'self-insert-command) + map)) + ;;; Vocabs dictionary: @@ -33,7 +42,8 @@ fuel-completion--vocabs) (defun fuel-completion--read-vocab (&optional reload init-input history) - (let ((vocabs (fuel-completion--vocabs reload))) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs reload))) (completing-read "Vocab name: " vocabs nil nil init-input history))) (defsubst fuel-completion--vocab-list (prefix) @@ -170,12 +180,21 @@ terminates a current completion." (cons completions partial))) (defun fuel-completion--read-word (prompt &optional default history all) - (completing-read prompt - (if all fuel-completion--all-words-list-func - fuel-completion--word-list-func) - nil nil nil - history - (or default (fuel-syntax-symbol-at-point)))) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)) + (completing-read prompt + (if all fuel-completion--all-words-list-func + fuel-completion--word-list-func) + nil nil nil + history + (or default (fuel-syntax-symbol-at-point))))) + +(defun fuel-completion--read-vocab (refresh) + (let* ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs refresh)) + (prompt "Vocabulary name: ")) + (if vocabs + (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) + (read-string prompt nil fuel-edit--vocab-history)))) (defun fuel-completion--complete-symbol () "Complete the symbol at point. diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index e5f0ffd26f..5860fb998a 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -57,13 +57,6 @@ (fuel-edit--visit-file (car loc) fuel-edit-word-method) (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))) -(defun fuel-edit--read-vocabulary-name (refresh) - (let* ((vocabs (fuel-completion--vocabs refresh)) - (prompt "Vocabulary name: ")) - (if vocabs - (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) - (read-string prompt nil fuel-edit--vocab-history)))) - (defun fuel-edit--edit-article (name) (let ((cmd `(:fuel* (,name fuel-get-article-location) "fuel" t))) (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) @@ -80,7 +73,7 @@ When called interactively, asks for vocabulary with completion. With prefix argument, refreshes cached vocabulary list." (interactive "P") - (let* ((vocab (or vocab (fuel-edit--read-vocabulary-name refresh))) + (let* ((vocab (or vocab (fuel-completion--read-vocab refresh))) (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t))) (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index a82de388da..cfc8cab7f1 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -257,7 +257,7 @@ buffer." (defun fuel-help-vocab (vocab) "Ask for a vocabulary name and show its help page." - (interactive (list (fuel-edit--read-vocabulary-name nil))) + (interactive (list (fuel-completion--read-vocab nil))) (fuel-help--get-vocab vocab)) (defun fuel-help-next (&optional forget-current) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 4844233ae7..980ea111a6 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -282,7 +282,8 @@ (fuel-markup--insert-newline) (dolist (s (cdr e)) (fuel-markup--snippet (list '$snippet s)) - (newline))) + (newline)) + (newline)) (defun fuel-markup--markup-example (e) (fuel-markup--insert-newline) diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index 05d825593c..ac400c5622 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/misc/fuel/fuel-scaffold.el @@ -71,7 +71,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to `user-full-name') for the name to be inserted in the generated file." (interactive "P") (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) - (fuel-edit--read-vocabulary-name nil))) + (fuel-completion--read-vocab nil))) (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help) "fuel")) (ret (fuel-eval--send/wait cmd)) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index 4d444ebe3e..faf1897304 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -244,7 +244,7 @@ With prefix argument, force reload of vocabulary list." With prefix argument, ask for the vocab." (interactive "P") (let ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) - (fuel-edit--read-vocabulary-name)))) + (fuel-completion--read-vocab nil)))) (when vocab (fuel-xref--show-vocab-words vocab (fuel-syntax--file-has-private))))) From 84846e21d840c7d6cc74db4d6e04c1062c640baf Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 5 Feb 2009 10:45:44 +0100 Subject: [PATCH 02/16] FUEL: Small nits. --- misc/fuel/fuel-completion.el | 12 +++++++----- misc/fuel/fuel-edit.el | 1 - 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el index 165a9d9b66..c21d25901f 100644 --- a/misc/fuel/fuel-completion.el +++ b/misc/fuel/fuel-completion.el @@ -188,13 +188,15 @@ terminates a current completion." history (or default (fuel-syntax-symbol-at-point))))) +(defvar fuel-completion--vocab-history nil) + (defun fuel-completion--read-vocab (refresh) - (let* ((minibuffer-local-completion-map fuel-completion--minibuffer-map) - (vocabs (fuel-completion--vocabs refresh)) - (prompt "Vocabulary name: ")) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs refresh)) + (prompt "Vocabulary name: ")) (if vocabs - (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) - (read-string prompt nil fuel-edit--vocab-history)))) + (completing-read prompt vocabs nil nil nil fuel-completion--vocab-history) + (read-string prompt nil fuel-completion--vocab-history)))) (defun fuel-completion--complete-symbol () "Complete the symbol at point. diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index 5860fb998a..941f57140e 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -65,7 +65,6 @@ ;;; Editing commands: (defvar fuel-edit--word-history nil) -(defvar fuel-edit--vocab-history nil) (defvar fuel-edit--previous-location nil) (defun fuel-edit-vocabulary (&optional refresh vocab) From 08ad6ca1162f54d7264d95dc02740405b4c332c2 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 8 Feb 2009 23:22:23 +0100 Subject: [PATCH 03/16] FUEL: use factor.com instead of factor.exe as default binary under Windows. --- misc/fuel/fuel-connection.el | 8 ++++++-- misc/fuel/fuel-listener.el | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 14c4d0b36f..f180d0f2b4 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -144,8 +144,12 @@ (add-hook 'comint-redirect-hook 'fuel-con--comint-redirect-hook nil t)) -(defadvice comint-redirect-setup (after fuel-con--advice activate) - (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex)) +(defadvice comint-redirect-setup + (after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo)) + (with-current-buffer comint-buffer + (when fuel-con--connection + (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex)))) +(ad-activate 'comint-redirect-setup) (defun fuel-con--comint-preoutput-filter (str) (when (string-match fuel-con--comint-finished-regex str) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index d0898de04f..b8bf4d4b7f 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -32,7 +32,7 @@ (defcustom fuel-listener-factor-binary (expand-file-name (cond ((eq system-type 'windows-nt) - "factor.exe") + "factor.com") ((eq system-type 'darwin) "Factor.app/Contents/MacOS/factor") (t "factor")) From da45cbe96d1a3f242abefd125eac56301c0a6937 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 17:13:28 -0600 Subject: [PATCH 04/16] Rewriting basis/wrap with Knuth's algorithm. Minor API changes will probably break Slava's unmerged UI changes --- basis/wrap/wrap-docs.factor | 28 +++--- basis/wrap/wrap-tests.factor | 87 +++++++++++------ basis/wrap/wrap.factor | 181 ++++++++++++++++++++++++++--------- 3 files changed, 212 insertions(+), 84 deletions(-) diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index c94e12907f..09ddec36ed 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping" { $subsection wrap-lines } { $subsection wrap-string } { $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words." -{ $subsection wrap } -{ $subsection word } -{ $subsection } ; +"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called elements." +{ $subsection wrap-elements } +{ $subsection element } +{ $subsection } ; 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 -{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" 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 width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; +HELP: wrap-elements +{ $values { "elements" { "a sequence of " { $instance element } "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: word -{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", 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). Words can be created with " { $link } "." } -{ $see-also wrap } ; +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 } "." } +{ $see-also wrap-elements } ; -HELP: -{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } } -{ $description "Creates a " { $link word } " object with the given parameters." } -{ $see-also wrap } ; +HELP: +{ $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 } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index ba5168a1c2..98d0b712f7 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -6,49 +6,77 @@ IN: wrap.tests [ { { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 2 t } + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 2 t } } { - T{ word f 4 10 f } - T{ word f 5 10 f } + T{ element f 4 10 f } + T{ element f 5 10 f } } } ] [ { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 2 t } - T{ word f 4 10 f } - T{ word f 5 10 f } - } 35 wrap [ { } like ] map + 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 ] unit-test [ { { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 3 9 t } + 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{ word f 4 10 f } - T{ word f 5 10 f } + T{ element f 4 10 f } + T{ element f 5 10 f } } } ] [ { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 4 10 f } - T{ word f 5 10 f } - } 35 wrap [ { } like ] map + 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 +] unit-test + +[ + { + { + 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 } + } + } +] [ + { + 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 ] unit-test [ @@ -75,8 +103,13 @@ word wrap."> " " wrap-indented-string ] unit-test -[ "this text\nhas lots of\nspaces" ] +[ "this text\nhas lots\nof spaces" ] [ "this text has lots of spaces" 12 wrap-string ] unit-test [ "hello\nhow\nare\nyou\ntoday?" ] [ "hello how are you today?" 3 wrap-string ] unit-test + +[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test +[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test +[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test +[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index e93509b58e..458d2f86d1 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,70 +1,165 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel namespaces make splitting -math math.order fry assocs accessors ; +USING: kernel sequences math arrays locals fry accessors splitting +make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap -! Word wrapping/line breaking -- not Unicode-aware - -TUPLE: word key width break? ; - -C: word - word -: break-here? ( column word -- ? ) - break?>> not [ width get > ] [ drop f ] if ; +: word-length ( word -- n ) + [ black>> ] [ white>> ] bi + ; -: walk ( n words -- n ) - ! If on a break, take the rest of the breaks - ! If not on a break, go back until you hit a break - 2dup bounds-check? [ - 2dup nth break?>> - [ [ break?>> not ] find-from drop ] - [ [ break?>> ] find-last-from drop 1+ ] if - ] [ drop ] if ; +TUPLE: cons cdr car ; ! This order works out better +C: cons -: find-optimal-break ( words -- n ) - [ 0 ] keep - [ [ width>> + dup ] keep break-here? ] find drop nip - [ 1 max swap walk ] [ drop f ] if* ; +: >cons< ( cons -- cdr car ) + [ cdr>> ] [ car>> ] bi ; -: (wrap) ( words -- ) +: list-each ( list quot -- ) + over [ + [ [ car>> ] dip call ] + [ [ cdr>> ] dip list-each ] 2bi + ] [ 2drop ] if ; inline recursive + +: singleton? ( list -- ? ) + { [ ] [ cdr>> not ] } 1&& ; + +: ( elt -- list ) + f swap ; + +: list>array ( list -- array ) + [ [ , ] list-each ] { } make ; + +: lists>arrays ( lists -- arrays ) + [ [ list>array , ] list-each ] { } make ; + +TUPLE: paragraph lines head-width tail-cost ; +C: paragraph + +SYMBOL: line-max +SYMBOL: line-ideal + +: deviation ( length -- n ) + line-ideal get - sq ; + +: top-fits? ( paragraph -- ? ) + [ head-width>> ] + [ lines>> singleton? line-ideal line-max ? get ] bi <= ; + +: fits? ( paragraph -- ? ) + ! Make this not count spaces at end + { [ lines>> car>> singleton? ] [ top-fits? ] } 1|| ; + +:: min-by ( seq quot -- elt ) + f 1.0/0.0 seq [| key value new | + new quot call :> newvalue + newvalue value < [ new newvalue ] [ key value ] if + ] each drop ; inline + +: paragraph-cost ( paragraph -- cost ) + [ head-width>> deviation ] + [ tail-cost>> ] bi + ; + +: min-cost ( paragraphs -- paragraph ) + [ paragraph-cost ] min-by ; + +: new-line ( paragraph word -- paragraph ) + [ [ lines>> ] [ ] bi* ] + [ nip black>> ] + [ drop paragraph-cost ] 2tri + ; + +: glue ( paragraph word -- paragraph ) + [ [ lines>> >cons< ] dip ] + [ [ head-width>> ] [ word-length ] bi* + ] + [ drop tail-cost>> ] 2tri + ; + +: wrap-step ( paragraphs word -- paragraphs ) + [ '[ _ glue ] map ] + [ [ min-cost ] dip new-line ] + 2bi prefix + [ fits? ] filter ; + +: 1paragraph ( word -- paragraph ) + [ ] + [ black>> ] bi + 0 ; + +: post-process ( paragraph -- array ) + lines>> lists>arrays + [ [ contents>> ] map ] map ; + +: initialize ( words -- words paragraph ) + unclip-slice 1paragraph 1array ; + +: wrap ( words line-max line-ideal -- paragraph ) [ - dup find-optimal-break - [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* - ] unless-empty ; + line-ideal set + line-max set + initialize + [ wrap-step ] reduce + min-cost + post-process + ] with-scope ; -: intersperse ( seq elt -- seq' ) - [ '[ _ , ] [ , ] interleave ] { } make ; +PRIVATE> + +TUPLE: element key width break? ; +C: element + +> ] map sum ; + +: make-word ( whites blacks -- word ) + [ append ] [ [ elements-length ] bi@ ] 2bi ; + +: ?first2 ( seq -- first/f second/f ) + [ 0 swap ?nth ] + [ 1 swap ?nth ] bi ; + +: split-elements ( seq -- half-words ) + [ [ break?>> ] bi@ = ] monotonic-split ; + +: ?first-break ( seq -- newseq f/word ) + dup first first break?>> + [ unclip-slice f swap make-word ] + [ f ] if ; + +: make-words ( seq f/word -- words ) + [ 2 [ ?first2 make-word ] map ] dip + [ prefix ] when* ; + +: elements>words ( seq -- newseq ) + split-elements ?first-break make-words ; + +PRIVATE> + +: wrap-elements ( elements line-max line-ideal -- lines ) + [ elements>words ] 2dip wrap [ concat ] map ; + + ] map - " " 1 t intersperse + [ dup length 1 ] map ] map ; : join-words ( wrapped-lines -- lines ) - [ - [ break?>> ] trim-slice - [ key>> ] map concat - ] map ; + [ " " join ] map ; : join-lines ( strings -- string ) "\n" join ; PRIVATE> -: wrap ( words width -- lines ) - width [ - [ (wrap) ] { } make - ] with-variable ; - : wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ wrap join-words ] map concat ; + [ split-lines ] dip '[ _ dup wrap join-words ] map concat ; : wrap-string ( string width -- newstring ) wrap-lines join-lines ; From 0e8986176f7597d23b5908968c7785ad3b4a02a2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 18:24:22 -0600 Subject: [PATCH 05/16] Adding failing unit test to wrap (must-infer) --- basis/wrap/wrap-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index 98d0b712f7..933238fddc 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -113,3 +113,6 @@ word wrap."> [ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test [ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test + +\ wrap-string must-infer +\ wrap-elements must-infer From b65b88364c46b8c21b4f36e302bc406e0861bf49 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 22:12:11 -0600 Subject: [PATCH 06/16] Updating lots of things to use call( -- ) --- basis/alien/c-types/c-types.factor | 4 ++-- basis/cocoa/messages/messages.factor | 4 ++-- .../compiler/tree/propagation/inlining/inlining.factor | 7 ++++--- basis/help/lint/lint.factor | 10 +++++----- basis/html/templates/chloe/chloe.factor | 4 ++-- basis/html/templates/chloe/compiler/compiler.factor | 6 +++--- basis/html/templates/fhtml/fhtml.factor | 4 ++-- basis/ui/tools/interactor/interactor.factor | 5 ++--- basis/ui/ui.factor | 4 ++-- 9 files changed, 24 insertions(+), 24 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index cf5daa1562..89b3572daf 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry ; +accessors combinators effects continuations fry call ; IN: alien.c-types DEFER: @@ -258,7 +258,7 @@ M: long-long-type box-return ( type -- ) unclip [ [ dup word? [ - def>> { } swap with-datastack first + def>> call( -- object ) ] when ] map ] dip prefix diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index a0b0e89a0d..60bdde262c 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math namespaces make parser quotations sequences strings words cocoa.runtime io macros memoize io.encodings.utf8 effects libc libc.private parser lexer init core-foundation fry -generalizations specialized-arrays.direct.alien ; +generalizations specialized-arrays.direct.alien call ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -83,7 +83,7 @@ class-init-hooks global [ H{ } clone or ] change-at : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ - drop over class-init-hooks get at [ assert-depth ] when* + drop over class-init-hooks get at [ call( -- ) ] when* 2dup execute dup [ 2nip ] [ 2drop "No such class: " prepend throw ] if diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index f3b3238b4e..06d8d4f733 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math math.order +USING: accessors kernel arrays sequences math math.order call math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart @@ -181,8 +181,9 @@ SYMBOL: history "custom-inlining" word-prop ; : inline-custom ( #call word -- ? ) - [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack - first object swap eliminate-dispatch ; + [ dup ] [ "custom-inlining" word-prop ] bi* + call( #call -- word/quot/f ) + object swap eliminate-dispatch ; : inline-instance-check ( #call word -- ? ) over in-d>> second value-info literal>> dup class? diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index b5f8b78ea3..57f64459c8 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate macros math sets eval vocabs.parser words.symbol values grouping unicode.categories -sequences.deep ; +sequences.deep call ; IN: help.lint SYMBOL: vocabs-quot @@ -15,9 +15,9 @@ SYMBOL: vocabs-quot : check-example ( element -- ) [ rest [ - but-last "\n" join 1vector - [ (eval>string) ] with-datastack - peek "\n" ?tail drop + but-last "\n" join + [ (eval>string) ] call( code -- output ) + "\n" ?tail drop ] keep peek assert= ] vocabs-quot get call ; @@ -145,7 +145,7 @@ M: help-error error. bi ; : check-something ( obj quot -- ) - flush '[ _ assert-depth ] swap '[ _ , ] recover ; inline + flush '[ _ call( -- ) ] swap '[ _ , ] recover ; inline : check-word ( word -- ) [ with-file-vocabs ] vocabs-quot set diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 89d00e1f6e..eafa3c3a5d 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml -logging continuations +logging call xml.data xml.writer xml.syntax strings html.forms html @@ -130,6 +130,6 @@ TUPLE: cached-template path last-modified quot ; template-cache get clear-assoc ; M: chloe call-template* - template-quot assert-depth ; + template-quot call( -- ) ; INSTANCE: chloe template diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 394b5ef359..1a1abc9f7b 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present -xml.writer xml.data xml.entities html.forms -html.templates html.templates.chloe.syntax continuations ; +xml.writer xml.data xml.entities html.forms call +html.templates html.templates.chloe.syntax ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) @@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ; : compile-chloe-tag ( tag -- ) dup main>> dup tags get at - [ curry assert-depth ] + [ curry call( -- ) ] [ unknown-chloe-tag ] ?if ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index c419c4a197..e76a812bef 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors -assocs fry vocabs.parser parser lexer io io.files +assocs fry vocabs.parser parser lexer io io.files call io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml @@ -72,6 +72,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ _ path>> utf8 file-contents eval-template ] assert-depth ; + '[ _ path>> utf8 file-contents eval-template ] call( -- ) ; INSTANCE: fhtml template diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index 40da6ebafc..eb2eef3742 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -5,7 +5,7 @@ hashtables io io.styles kernel math math.order math.vectors models models.delay namespaces parser lexer prettyprint quotations sequences strings threads listener classes.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar -ui.gadgets.presentations ui.gadgets.worlds ui.gestures +ui.gadgets.presentations ui.gadgets.worlds ui.gestures call definitions calendar concurrency.flags concurrency.mailboxes ui.tools.workspace accessors sets destructors fry vocabs.parser ; IN: ui.tools.interactor @@ -82,8 +82,7 @@ M: interactor model-changed mailbox>> mailbox-put ; : clear-input ( interactor -- ) - #! The with-datastack is a kludge to make it infer. Stupid. - model>> 1array [ clear-doc ] with-datastack drop ; + model>> [ clear-doc ] call( model -- ) ; : interactor-finish ( interactor -- ) [ editor-string ] keep diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 37ce4ea499..78f150987f 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators hashtables -concurrency.flags sets accessors calendar ; +concurrency.flags sets accessors calendar call ; IN: ui ! Assoc mapping aliens to gadgets @@ -140,7 +140,7 @@ SYMBOL: ui-hook layout-queued redraw-worlds send-queued-gestures - ] assert-depth + ] call( -- ) ] [ ui-error ] recover ; SYMBOL: ui-thread From af9f5112d45beb02023aee377f3d0fbf6b2ceae5 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 22:39:22 -0600 Subject: [PATCH 07/16] Adding call( -- ) --- basis/call/call-tests.factor | 10 ++++++++++ basis/call/call.factor | 24 ++++++++++++++++++++++++ 2 files changed, 34 insertions(+) create mode 100644 basis/call/call-tests.factor create mode 100644 basis/call/call.factor diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor new file mode 100644 index 0000000000..4a59a6d2fb --- /dev/null +++ b/basis/call/call-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: math tools.test call kernel ; +IN: call.tests + +[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test +[ 1 2 [ + ] call( -- z ) ] must-fail +[ 1 2 [ + ] call( x y -- z a ) ] must-fail +[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test +[ [ + ] call( x y -- z ) ] must-infer diff --git a/basis/call/call.factor b/basis/call/call.factor new file mode 100644 index 0000000000..363b024dff --- /dev/null +++ b/basis/call/call.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel macros fry summary sequences generalizations accessors +continuations effects.parser parser ; +IN: call + +ERROR: wrong-values values quot length-required ; + +M: wrong-values summary + drop "Wrong number of values returned from quotation" ; + + + +MACRO: call-effect ( effect -- quot ) + [ in>> length ] [ out>> length ] bi + '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ; + +: call( + ")" parse-effect parsed \ call-effect parsed ; parsing From c4aa14b9d96d0a55b6c94e2441d952cf056ddfcc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 23:06:03 -0600 Subject: [PATCH 08/16] Making lazy lists compile, and using them where applicable --- basis/persistent/deques/deques.factor | 14 ++-- basis/wrap/wrap-docs.factor | 26 +++---- basis/wrap/wrap-tests.factor | 84 +++++++++++------------ basis/wrap/wrap.factor | 97 ++++++++++++--------------- extra/lists/lazy/lazy-tests.factor | 8 ++- extra/lists/lazy/lazy.factor | 22 +++--- extra/lists/lists.factor | 5 +- extra/promises/promises.factor | 10 +-- 8 files changed, 125 insertions(+), 141 deletions(-) diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index be63d807b9..ece1cda772 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,6 +1,6 @@ ! Copyback (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math ; +USING: kernel accessors math lists ; QUALIFIED: sequences IN: persistent.deques @@ -9,25 +9,23 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. 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 ] reduce ; + f [ swap cons ] reduce ; : length ( list -- length ) 0 [ drop 1+ ] reduce ; : cut ( list index -- back front-reversed ) - f swap [ [ [ cdr>> ] [ car>> ] bi ] dip ] 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> > ] [ back>> ] bi deque boa ; inline + [ front>> cons ] [ back>> ] bi deque boa ; inline PRIVATE> : push-front ( deque item -- newdeque ) @@ -60,7 +58,7 @@ PRIVATE> > car>> ] [ [ front>> cdr>> ] [ back>> ] bi deque boa ] bi ; inline + [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline : transfer ( deque -- item newdeque ) back>> [ split-reverse deque boa remove ] diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index 09ddec36ed..59c0352bc7 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping" { $subsection wrap-lines } { $subsection wrap-string } { $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called elements." -{ $subsection wrap-elements } -{ $subsection element } -{ $subsection } ; +"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments." +{ $subsection wrap-segments } +{ $subsection segment } +{ $subsection } ; 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 } "." } -{ $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 } "." } +{ $see-also wrap-segments } ; -HELP: -{ $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: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } } +{ $description "Creates a " { $link segment } " object with the given parameters." } +{ $see-also wrap-segments } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index 933238fddc..eeea3850d5 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -6,77 +6,77 @@ IN: wrap.tests [ { { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 2 t } + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 2 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 2 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 2 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ { { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 3 9 t } + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 3 9 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ { { - T{ element f 1 10 t } - T{ element f 1 10 f } - T{ element f 3 9 t } + T{ segment f 1 10 t } + T{ segment f 1 10 f } + T{ segment f 3 9 t } } { - T{ element f 2 10 f } - T{ element f 3 9 t } + T{ segment f 2 10 f } + T{ segment f 3 9 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 t } - T{ element f 1 10 f } - T{ element f 3 9 t } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 t } + T{ segment f 1 10 f } + T{ segment f 3 9 t } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ @@ -115,4 +115,4 @@ word wrap."> [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test \ wrap-string must-infer -\ wrap-elements must-infer +\ wrap-segments must-infer diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 458d2f86d1..f54c858bf4 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,39 +1,28 @@ -USING: kernel sequences math arrays locals fry accessors splitting -make combinators.short-circuit namespaces grouping splitting.monotonic ; +USING: kernel sequences math arrays locals fry accessors +lists splitting call make combinators.short-circuit namespaces +grouping splitting.monotonic ; IN: wrap word +TUPLE: element contents black white ; +C: element -: word-length ( word -- n ) +: element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -TUPLE: cons cdr car ; ! This order works out better -C: 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&& ; - -: ( elt -- list ) - f swap ; - -: 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 @@ -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>> ] [ ] bi* ] +: new-line ( paragraph element -- paragraph ) + [ [ lines>> ] [ 1list ] bi* swons ] [ nip black>> ] [ drop paragraph-cost ] 2tri ; -: glue ( paragraph word -- paragraph ) - [ [ lines>> >cons< ] dip ] - [ [ head-width>> ] [ word-length ] bi* + ] +: glue ( paragraph element -- paragraph ) + [ [ lines>> unswons ] dip swons swons ] + [ [ head-width>> ] [ element-length ] bi* + ] [ drop tail-cost>> ] 2tri ; -: 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 ) + [ 1list 1list ] [ black>> ] bi 0 ; @@ -92,10 +81,10 @@ SYMBOL: line-ideal lines>> lists>arrays [ [ contents>> ] map ] map ; -: initialize ( words -- words paragraph ) +: initialize ( elements -- elements paragraph ) 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 +TUPLE: segment key width break? ; +C: segment > ] map sum ; -: make-word ( whites blacks -- word ) - [ append ] [ [ elements-length ] bi@ ] 2bi ; +: make-element ( whites blacks -- element ) + [ append ] [ [ segments-length ] bi@ ] 2bi ; : ?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 [ ?first2 make-word ] map ] dip +: make-elements ( seq f/element -- elements ) + [ 2 [ ?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 ; ] map + [ dup length 1 ] map ] map ; -: join-words ( wrapped-lines -- lines ) +: join-elements ( wrapped-lines -- lines ) [ " " join ] map ; : join-lines ( strings -- string ) @@ -159,7 +148,7 @@ PRIVATE> PRIVATE> : wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ dup wrap join-words ] map concat ; + [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; : wrap-string ( string width -- newstring ) wrap-lines join-lines ; diff --git a/extra/lists/lazy/lazy-tests.factor b/extra/lists/lazy/lazy-tests.factor index 5749f94364..03221841c1 100644 --- a/extra/lists/lazy/lazy-tests.factor +++ b/extra/lists/lazy/lazy-tests.factor @@ -1,6 +1,5 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! USING: lists lists.lazy tools.test kernel math io sequences ; IN: lists.lazy.tests @@ -27,3 +26,10 @@ IN: lists.lazy.tests [ { 4 5 6 } ] [ 3 { 1 2 3 } >list [ + ] lazy-map-with list>array ] unit-test + +[ [ ] lmap ] must-infer +[ [ ] lmap>array ] must-infer +[ [ drop ] foldr ] must-infer +[ [ drop ] foldl ] must-infer +[ [ drop ] leach ] must-infer +[ lnth ] must-infer diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index e60fcbaadf..213285e643 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -1,12 +1,7 @@ -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! See http://factorcode.org/license.txt for BSD license. -! -! Updated by Matthew Willis, July 2006 -! Updated by Chris Double, September 2006 -! Updated by James Cash, June 2008 -! USING: kernel sequences math vectors arrays namespaces make -quotations promises combinators io lists accessors ; +quotations promises combinators io lists accessors call ; IN: lists.lazy M: promise car ( promise -- car ) @@ -86,7 +81,7 @@ C: lazy-map 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 over nil? [ 2drop nil ] [ ] if ; : car-filter? ( lazy-filter -- ? ) - [ cons>> car ] [ quot>> ] bi call ; + [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ; : skip ( lazy-filter -- ) dup cons>> cdr >>cons drop ; @@ -221,7 +216,7 @@ M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by cdr ( lazy-from-by -- cdr ) [ n>> ] keep - quot>> dup slip lfrom-by ; + quot>> [ call( old -- new ) ] keep lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) drop f ; @@ -355,7 +350,8 @@ M: lazy-io car ( lazy-io -- car ) dup car>> dup [ nip ] [ - drop dup stream>> over quot>> call + drop dup stream>> over quot>> + call( stream -- value ) >>car ] if ; diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index bf822889e3..5568b9d53e 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words locals ; - IN: lists ! List Protocol @@ -46,7 +45,7 @@ M: object nil? drop f ; : 2car ( cons -- car caar ) [ car ] [ cdr car ] bi ; -: 3car ( cons -- car caar caaar ) +: 3car ( cons -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; : lnth ( n list -- elt ) @@ -109,4 +108,4 @@ M: object nil? drop f ; [ 2over call [ tuck [ call ] 2dip ] when pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive -INSTANCE: cons list \ No newline at end of file +INSTANCE: cons list diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 38366697ea..bec2761e53 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -1,10 +1,6 @@ -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -! -! Updated by Matthew Willis, July 2006 -! Updated by Chris Double, September 2006 - -USING: arrays kernel sequences math vectors arrays namespaces +USING: arrays kernel sequences math vectors arrays namespaces call make quotations parser effects stack-checker words accessors ; IN: promises @@ -24,7 +20,7 @@ TUPLE: promise quot forced? value ; #! promises quotation on the stack. Re-forcing the promise #! will return the same value and not recall the quotation. dup forced?>> [ - dup quot>> call >>value + dup quot>> call( -- value ) >>value t >>forced? ] unless value>> ; From 89e3eb6fa312ce7fd2ab777d8768fb9cd3e5ce2c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 23:49:05 -0600 Subject: [PATCH 09/16] Moving lists to basis --- basis/html/templates/chloe/compiler/compiler.factor | 2 +- basis/html/templates/fhtml/fhtml.factor | 2 +- {extra => basis}/lists/authors.txt | 0 {extra => basis}/lists/lazy/authors.txt | 0 {extra => basis}/lists/lazy/examples/authors.txt | 0 {extra => basis}/lists/lazy/examples/examples-tests.factor | 0 {extra => basis}/lists/lazy/examples/examples.factor | 0 {extra => basis}/lists/lazy/lazy-docs.factor | 0 {extra => basis}/lists/lazy/lazy-tests.factor | 0 {extra => basis}/lists/lazy/lazy.factor | 0 {extra => basis}/lists/lazy/old-doc.html | 0 {extra => basis}/lists/lazy/summary.txt | 0 {extra => basis}/lists/lazy/tags.txt | 0 {extra => basis}/lists/lists-docs.factor | 0 {extra => basis}/lists/lists-tests.factor | 0 {extra => basis}/lists/lists.factor | 0 {extra => basis}/lists/summary.txt | 0 {extra => basis}/lists/tags.txt | 0 18 files changed, 2 insertions(+), 2 deletions(-) rename {extra => basis}/lists/authors.txt (100%) rename {extra => basis}/lists/lazy/authors.txt (100%) rename {extra => basis}/lists/lazy/examples/authors.txt (100%) rename {extra => basis}/lists/lazy/examples/examples-tests.factor (100%) rename {extra => basis}/lists/lazy/examples/examples.factor (100%) rename {extra => basis}/lists/lazy/lazy-docs.factor (100%) rename {extra => basis}/lists/lazy/lazy-tests.factor (100%) rename {extra => basis}/lists/lazy/lazy.factor (100%) rename {extra => basis}/lists/lazy/old-doc.html (100%) rename {extra => basis}/lists/lazy/summary.txt (100%) rename {extra => basis}/lists/lazy/tags.txt (100%) rename {extra => basis}/lists/lists-docs.factor (100%) rename {extra => basis}/lists/lists-tests.factor (100%) rename {extra => basis}/lists/lists.factor (100%) rename {extra => basis}/lists/summary.txt (100%) rename {extra => basis}/lists/tags.txt (100%) diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 1a1abc9f7b..3cb7523bdc 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ; : compile-chloe-tag ( tag -- ) dup main>> dup tags get at - [ curry call( -- ) ] + [ call( tag -- ) ] [ unknown-chloe-tag ] ?if ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index e76a812bef..78202d6460 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -72,6 +72,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ _ path>> utf8 file-contents eval-template ] call( -- ) ; + [ path>> utf8 file-contents eval-template ] call( filename -- ) ; INSTANCE: fhtml template diff --git a/extra/lists/authors.txt b/basis/lists/authors.txt similarity index 100% rename from extra/lists/authors.txt rename to basis/lists/authors.txt diff --git a/extra/lists/lazy/authors.txt b/basis/lists/lazy/authors.txt similarity index 100% rename from extra/lists/lazy/authors.txt rename to basis/lists/lazy/authors.txt diff --git a/extra/lists/lazy/examples/authors.txt b/basis/lists/lazy/examples/authors.txt similarity index 100% rename from extra/lists/lazy/examples/authors.txt rename to basis/lists/lazy/examples/authors.txt diff --git a/extra/lists/lazy/examples/examples-tests.factor b/basis/lists/lazy/examples/examples-tests.factor similarity index 100% rename from extra/lists/lazy/examples/examples-tests.factor rename to basis/lists/lazy/examples/examples-tests.factor diff --git a/extra/lists/lazy/examples/examples.factor b/basis/lists/lazy/examples/examples.factor similarity index 100% rename from extra/lists/lazy/examples/examples.factor rename to basis/lists/lazy/examples/examples.factor diff --git a/extra/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor similarity index 100% rename from extra/lists/lazy/lazy-docs.factor rename to basis/lists/lazy/lazy-docs.factor diff --git a/extra/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor similarity index 100% rename from extra/lists/lazy/lazy-tests.factor rename to basis/lists/lazy/lazy-tests.factor diff --git a/extra/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor similarity index 100% rename from extra/lists/lazy/lazy.factor rename to basis/lists/lazy/lazy.factor diff --git a/extra/lists/lazy/old-doc.html b/basis/lists/lazy/old-doc.html similarity index 100% rename from extra/lists/lazy/old-doc.html rename to basis/lists/lazy/old-doc.html diff --git a/extra/lists/lazy/summary.txt b/basis/lists/lazy/summary.txt similarity index 100% rename from extra/lists/lazy/summary.txt rename to basis/lists/lazy/summary.txt diff --git a/extra/lists/lazy/tags.txt b/basis/lists/lazy/tags.txt similarity index 100% rename from extra/lists/lazy/tags.txt rename to basis/lists/lazy/tags.txt diff --git a/extra/lists/lists-docs.factor b/basis/lists/lists-docs.factor similarity index 100% rename from extra/lists/lists-docs.factor rename to basis/lists/lists-docs.factor diff --git a/extra/lists/lists-tests.factor b/basis/lists/lists-tests.factor similarity index 100% rename from extra/lists/lists-tests.factor rename to basis/lists/lists-tests.factor diff --git a/extra/lists/lists.factor b/basis/lists/lists.factor similarity index 100% rename from extra/lists/lists.factor rename to basis/lists/lists.factor diff --git a/extra/lists/summary.txt b/basis/lists/summary.txt similarity index 100% rename from extra/lists/summary.txt rename to basis/lists/summary.txt diff --git a/extra/lists/tags.txt b/basis/lists/tags.txt similarity index 100% rename from extra/lists/tags.txt rename to basis/lists/tags.txt From 57ac121d2b87ab5c3cfd541ec898403e4a0ce273 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 00:33:30 -0600 Subject: [PATCH 10/16] adding execute( -- ) and documentation for basis/call --- basis/call/call-docs.factor | 32 ++++++++++++++++++++++++++++++++ basis/call/call-tests.factor | 5 +++++ basis/call/call.factor | 8 +++++++- 3 files changed, 44 insertions(+), 1 deletion(-) create mode 100644 basis/call/call-docs.factor diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor new file mode 100644 index 0000000000..463bfdac09 --- /dev/null +++ b/basis/call/call-docs.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax quotations effects words ; +IN: call + +ABOUT: "call" + +ARTICLE: "call" "Calling code with known stack effects" +"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +{ $subsection call-effect } +{ $subsection execute-effect } ; + +HELP: call( +{ $syntax "[ ] call( foo -- bar )" } +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; + +HELP: call-effect +{ $values { "quot" quotation } { "effect" effect } } +{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; + +HELP: execute( +{ $syntax "word execute( foo -- bar )" } +{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ; + +HELP: execute-effect +{ $values { "word" word } { "effect" effect } } +{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; + +{ execute-effect call-effect } related-words +{ POSTPONE: call( POSTPONE: execute( } related-words diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor index 4a59a6d2fb..a2bd11b06a 100644 --- a/basis/call/call-tests.factor +++ b/basis/call/call-tests.factor @@ -8,3 +8,8 @@ IN: call.tests [ 1 2 [ + ] call( x y -- z a ) ] must-fail [ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test [ [ + ] call( x y -- z ) ] must-infer + +[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test +[ 1 2 \ + execute( -- z ) ] must-fail +[ 1 2 \ + execute( x y -- z a ) ] must-fail +[ \ + execute( x y -- z ) ] must-infer diff --git a/basis/call/call.factor b/basis/call/call.factor index 363b024dff..9b49acf64a 100644 --- a/basis/call/call.factor +++ b/basis/call/call.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel macros fry summary sequences generalizations accessors -continuations effects.parser parser ; +continuations effects.parser parser words ; IN: call ERROR: wrong-values values quot length-required ; @@ -22,3 +22,9 @@ MACRO: call-effect ( effect -- quot ) : call( ")" parse-effect parsed \ call-effect parsed ; parsing + +: execute-effect ( word effect -- ) + [ [ execute ] curry ] dip call-effect ; inline + +: execute( + ")" parse-effect parsed \ execute-effect parsed ; parsing From 3e5ec77439381fe12318d4faecc925a953f7cace Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 01:12:32 -0600 Subject: [PATCH 11/16] Splitting up basis/wrap into three vocabs --- basis/wrap/strings/strings-docs.factor | 25 +++++ basis/wrap/strings/strings-tests.factor | 41 ++++++++ basis/wrap/strings/strings.factor | 29 ++++++ basis/wrap/words/words-docs.factor | 25 +++++ basis/wrap/words/words-tests.factor | 82 ++++++++++++++++ basis/wrap/words/words.factor | 40 ++++++++ basis/wrap/wrap-docs.factor | 36 +------- basis/wrap/wrap-tests.factor | 118 ------------------------ basis/wrap/wrap.factor | 66 +------------ basis/xml/writer/writer.factor | 2 +- 10 files changed, 248 insertions(+), 216 deletions(-) create mode 100644 basis/wrap/strings/strings-docs.factor create mode 100644 basis/wrap/strings/strings-tests.factor create mode 100644 basis/wrap/strings/strings.factor create mode 100644 basis/wrap/words/words-docs.factor create mode 100644 basis/wrap/words/words-tests.factor create mode 100644 basis/wrap/words/words.factor delete mode 100644 basis/wrap/wrap-tests.factor diff --git a/basis/wrap/strings/strings-docs.factor b/basis/wrap/strings/strings-docs.factor new file mode 100644 index 0000000000..e20780d3ac --- /dev/null +++ b/basis/wrap/strings/strings-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup strings math ; +IN: wrap.strings + +ABOUT: "wrap.strings" + +ARTICLE: "wrap.strings" "String word wrapping" +"The " { $vocab-link "wrap.strings" } " vocabulary implements word wrapping for simple strings, assumed to be in monospace font." +{ $subsection wrap-lines } +{ $subsection wrap-string } +{ $subsection wrap-indented-string } ; + +HELP: wrap-lines +{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } +{ $description "Given a string, divides it into a sequence of lines where 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." } ; + +HELP: wrap-string +{ $values { "string" string } { "width" integer } { "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." } ; + +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." } ; + diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor new file mode 100644 index 0000000000..0bea9b5d32 --- /dev/null +++ b/basis/wrap/strings/strings-tests.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: wrap.strings tools.test multiline ; +IN: wrap.strings.tests + +[ + <" This is a +long piece +of text +that we +wish to +word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 10 + wrap-string +] unit-test + +[ + <" This is a + long piece + of text + that we + wish to + word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 12 + " " wrap-indented-string +] unit-test + +[ "this text\nhas lots\nof spaces" ] +[ "this text has lots of spaces" 12 wrap-string ] unit-test + +[ "hello\nhow\nare\nyou\ntoday?" ] +[ "hello how are you today?" 3 wrap-string ] unit-test + +[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test +[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test +[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test +[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test + +\ wrap-string must-infer diff --git a/basis/wrap/strings/strings.factor b/basis/wrap/strings/strings.factor new file mode 100644 index 0000000000..7009352f2a --- /dev/null +++ b/basis/wrap/strings/strings.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: wrap kernel sequences fry splitting math ; +IN: wrap.strings + + ] map + ] map ; + +: join-elements ( wrapped-lines -- lines ) + [ " " join ] map ; + +: join-lines ( strings -- string ) + "\n" join ; + +PRIVATE> + +: wrap-lines ( lines width -- newlines ) + [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; + +: wrap-string ( string width -- newstring ) + wrap-lines join-lines ; + +: wrap-indented-string ( string width indent -- newstring ) + [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; diff --git a/basis/wrap/words/words-docs.factor b/basis/wrap/words/words-docs.factor new file mode 100644 index 0000000000..422aea0ac3 --- /dev/null +++ b/basis/wrap/words/words-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup math kernel ; +IN: wrap.words + +ABOUT: "wrap.words" + +ARTICLE: "wrap.words" "Word object wrapping" +"The " { $vocab-link "wrap.words" } " vocabulary implements word wrapping on abstract word objects, which have certain properties making it a more suitable input representation than strings." +{ $subsection wrap-words } +{ $subsection word } +{ $subsection } ; + +HELP: wrap-words +{ $values { "words" { "a sequence of " { $instance word } "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: word +{ $class-description "A word 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). Words can be created with " { $link } "." } +{ $see-also wrap-words } ; + +HELP: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } } +{ $description "Creates a " { $link word } " object with the given parameters." } +{ $see-also wrap-words } ; diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor new file mode 100644 index 0000000000..7598b382ba --- /dev/null +++ b/basis/wrap/words/words-tests.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test wrap.words sequences ; +IN: wrap.words.tests + +[ + { + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +[ + { + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 3 9 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +[ + { + { + T{ word f 1 10 t } + T{ word f 1 10 f } + T{ word f 3 9 t } + } + { + T{ word f 2 10 f } + T{ word f 3 9 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 t } + T{ word f 1 10 f } + T{ word f 3 9 t } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +\ wrap-words must-infer diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor new file mode 100644 index 0000000000..00f257a5cf --- /dev/null +++ b/basis/wrap/words/words.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel splitting.monotonic accessors wrap grouping ; +IN: wrap.words + +TUPLE: word key width break? ; +C: word + +> ] map sum ; + +: make-element ( whites blacks -- element ) + [ append ] [ [ words-length ] bi@ ] 2bi ; + +: ?first2 ( seq -- first/f second/f ) + [ 0 swap ?nth ] + [ 1 swap ?nth ] bi ; + +: split-words ( seq -- half-elements ) + [ [ break?>> ] bi@ = ] monotonic-split ; + +: ?first-break ( seq -- newseq f/element ) + dup first first break?>> + [ unclip-slice f swap make-element ] + [ f ] if ; + +: make-elements ( seq f/element -- elements ) + [ 2 [ ?first2 make-element ] map ] dip + [ prefix ] when* ; + +: words>elements ( seq -- newseq ) + split-words ?first-break make-elements ; + +PRIVATE> + +: wrap-words ( words line-max line-ideal -- lines ) + [ words>elements ] 2dip wrap [ concat ] map ; + diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index 59c0352bc7..feac7c51a7 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -6,36 +6,6 @@ IN: wrap ABOUT: "wrap" ARTICLE: "wrap" "Word wrapping" -"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. There is support for simple string wrapping, with the following words:" -{ $subsection wrap-lines } -{ $subsection wrap-string } -{ $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments." -{ $subsection wrap-segments } -{ $subsection segment } -{ $subsection } ; - -HELP: wrap-lines -{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } -{ $description "Given a string, divides it into a sequence of lines where 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." } ; - -HELP: wrap-string -{ $values { "string" string } { "width" integer } { "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." } ; - -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-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: 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 } "." } -{ $see-also wrap-segments } ; - -HELP: -{ $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 } ; +"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. Wrapping can take place based on simple strings, assumed to be monospace, or abstract word objects." +{ $vocab-subsection "String word wrapping" "wrap.strings" } +{ $vocab-subsection "Word object wrapping" "wrap.words" } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor deleted file mode 100644 index eeea3850d5..0000000000 --- a/basis/wrap/wrap-tests.factor +++ /dev/null @@ -1,118 +0,0 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test wrap multiline sequences ; -IN: wrap.tests - -[ - { - { - 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 } - } - } -] [ - { - 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{ 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 } - } - } -] [ - { - 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{ 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 } - } - } -] [ - { - 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 - -[ - <" This is a -long piece -of text -that we -wish to -word wrap."> -] [ - <" This is a long piece of text that we wish to word wrap."> 10 - wrap-string -] unit-test - -[ - <" This is a - long piece - of text - that we - wish to - word wrap."> -] [ - <" This is a long piece of text that we wish to word wrap."> 12 - " " wrap-indented-string -] unit-test - -[ "this text\nhas lots\nof spaces" ] -[ "this text has lots of spaces" 12 wrap-string ] unit-test - -[ "hello\nhow\nare\nyou\ntoday?" ] -[ "hello how are you today?" 3 wrap-string ] unit-test - -[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test -[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test -[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test -[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test - -\ wrap-string must-infer -\ wrap-segments must-infer diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index f54c858bf4..55fe10283a 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,10 +1,10 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences math arrays locals fry accessors lists splitting call make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap - element @@ -93,65 +93,3 @@ SYMBOL: line-ideal min-cost post-process ] with-scope ; - -PRIVATE> - -TUPLE: segment key width break? ; -C: segment - -> ] map sum ; - -: make-element ( whites blacks -- element ) - [ append ] [ [ segments-length ] bi@ ] 2bi ; - -: ?first2 ( seq -- first/f second/f ) - [ 0 swap ?nth ] - [ 1 swap ?nth ] bi ; - -: split-segments ( seq -- half-elements ) - [ [ break?>> ] bi@ = ] monotonic-split ; - -: ?first-break ( seq -- newseq f/element ) - dup first first break?>> - [ unclip-slice f swap make-element ] - [ f ] if ; - -: make-elements ( seq f/element -- elements ) - [ 2 [ ?first2 make-element ] map ] dip - [ prefix ] when* ; - -: segments>elements ( seq -- newseq ) - split-segments ?first-break make-elements ; - -PRIVATE> - -: wrap-segments ( segments line-max line-ideal -- lines ) - [ segments>elements ] 2dip wrap [ concat ] map ; - - ] map - ] map ; - -: join-elements ( wrapped-lines -- lines ) - [ " " join ] map ; - -: join-lines ( strings -- string ) - "\n" join ; - -PRIVATE> - -: wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; - -: wrap-string ( string width -- newstring ) - wrap-lines join-lines ; - -: wrap-indented-string ( string width indent -- newstring ) - [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 4b80e0818e..4f5bad1aa5 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings assocs combinators io io.streams.string accessors -xml.data wrap xml.entities unicode.categories fry ; +xml.data wrap.strings xml.entities unicode.categories fry ; IN: xml.writer SYMBOL: sensitive-tags From 25d20c6000d36dc0d04c52ad5b2998bb23a1af2b Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 8 Feb 2009 23:45:59 -0800 Subject: [PATCH 12/16] Update docs for GENERIC: GENERIC# and HOOK to show stack effect decl --- core/syntax/syntax-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index e08821bddd..035622454f 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -551,12 +551,12 @@ HELP: BIN: { $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ; HELP: GENERIC: -{ $syntax "GENERIC: word" } +{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" } { $values { "word" "a new word to define" } } { $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ; HELP: GENERIC# -{ $syntax "GENERIC# word n" } +{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" } { $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } } { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } { $notes @@ -571,7 +571,7 @@ HELP: MATH: { $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ; HELP: HOOK: -{ $syntax "HOOK: word variable" } +{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " } { $values { "word" "a new word to define" } { "variable" word } } { $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." } { $examples From 35b526cc7a034fb945342ab53c247a04abc4791c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 14:29:09 -0600 Subject: [PATCH 13/16] 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 14/16] 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 15/16] 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? ; From 0c589061ad895c6a3e8d1914ddc29cd49659cdbf Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 16:18:24 -0600 Subject: [PATCH 16/16] More docs for lazy lists, getting rid of lazy-map-with --- basis/lists/lazy/lazy-docs.factor | 55 ++++++++++++++++--- basis/lists/lazy/lazy-tests.factor | 2 +- basis/lists/lazy/lazy.factor | 7 +-- .../parser-combinators.factor | 8 +-- 4 files changed, 54 insertions(+), 18 deletions(-) diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index c402cdf15b..08fe3bbcba 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -1,11 +1,54 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. - USING: help.markup help.syntax sequences strings lists ; IN: lists.lazy +ABOUT: "lists.lazy" + +ARTICLE: "lists.lazy" "Lazy lists" +"The " { $vocab-link "lists.lazy" } " vocabulary implements lazy lists and standard operations to manipulate them." +{ $subsection { "lists.lazy" "construction" } } +{ $subsection { "lists.lazy" "manipulation" } } +{ $subsection { "lists.lazy" "combinators" } } +{ $subsection { "lists.lazy" "io" } } ; + +ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists" +"The following combinators create lazy lists from other lazy lists:" +{ $subsection lmap } +{ $subsection lfilter } +{ $subsection luntil } +{ $subsection lwhile } +{ $subsection lfrom-by } +{ $subsection lcomp } +{ $subsection lcomp* } ; + +ARTICLE: { "lists.lazy" "io" } "Lazy list I/O" +"Input from a stream can be read through a lazy list, using the following words:" +{ $subsection lcontents } +{ $subsection llines } ; + +ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists" +"Words for constructing lazy lists:" +{ $subsection lazy-cons } +{ $subsection 1lazy-list } +{ $subsection 2lazy-list } +{ $subsection 3lazy-list } +{ $subsection seq>list } +{ $subsection >list } +{ $subsection lfrom } ; + +ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists" +"To make new lazy lists from old ones:" +{ $subsection } +{ $subsection lappend } +{ $subsection lconcat } +{ $subsection lcartesian-product } +{ $subsection lcartesian-product* } +{ $subsection lmerge } +{ $subsection ltake } ; + HELP: lazy-cons -{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } +{ $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $see-also cons car cdr nil nil? } ; @@ -28,16 +71,12 @@ HELP: { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; -{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lazy-map { $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: lazy-map-with -{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } } -{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ; - HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; @@ -86,7 +125,7 @@ HELP: >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 } ; -{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 03221841c1..f4e55cba19 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -24,7 +24,7 @@ IN: lists.lazy.tests ] unit-test [ { 4 5 6 } ] [ - 3 { 1 2 3 } >list [ + ] lazy-map-with list>array + 3 { 1 2 3 } >list [ + ] with lazy-map list>array ] unit-test [ [ ] lmap ] must-infer diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 5adb7a8be5..d3b08a11fb 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -90,9 +90,6 @@ M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map nil? ( lazy-map -- bool ) cons>> nil? ; -: lazy-map-with ( value list quot -- result ) - with lazy-map ; - TUPLE: lazy-take n cons ; C: lazy-take @@ -301,14 +298,14 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; + swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; : lcartesian-product* ( lists -- result ) dup nil? [ drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat + swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat ] reduce ] if ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 347ab638ff..99e8099f38 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -149,8 +149,8 @@ TUPLE: and-parser parsers ; [ parsed>> ] dip [ parsed>> 2array ] keep unparsed>> - ] lazy-map-with - ] lazy-map-with lconcat ; + ] with lazy-map + ] with lazy-map lconcat ; M: and-parser parse ( input parser -- list ) #! Parse 'input' by sequentially combining the @@ -173,7 +173,7 @@ M: or-parser parse ( input parser1 -- list ) #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. parsers>> 0 swap seq>list - [ parse ] lazy-map-with lconcat ; + [ parse ] with lazy-map lconcat ; : trim-head-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -218,7 +218,7 @@ M: apply-parser parse ( input parser -- result ) -rot parse [ [ parsed>> swap call ] keep unparsed>> - ] lazy-map-with ; + ] with lazy-map ; TUPLE: some-parser p1 ;