From 001dc3b2518d6549b93ff7c493040b84e997f69e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 22 Dec 2008 06:42:08 -0800 Subject: [PATCH 01/34] Cleanup uuid a bit more, thanks Slava! --- basis/uuid/uuid.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor index 337ea22df5..209485b3bc 100644 --- a/basis/uuid/uuid.factor +++ b/basis/uuid/uuid.factor @@ -52,13 +52,10 @@ IN: uuid : string>uuid ( string -- n ) [ CHAR: - = not ] filter 16 base> ; -: uuid>byte-array ( n -- byte-array ) - 16 >be ; - PRIVATE> : uuid-parse ( string -- byte-array ) - string>uuid uuid>byte-array ; + string>uuid 16 >be ; : uuid-unparse ( byte-array -- string ) be> uuid>string ; From 8bb9429589055b51434a8147a5b1ddb93313253e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 26 Jan 2009 15:47:52 -0800 Subject: [PATCH 02/34] ensure accumulator comes back as a vector from literals --- extra/literals/literals-tests.factor | 6 ++++++ extra/literals/literals.factor | 6 +++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 185d672dd3..34ea4d6415 100644 --- a/extra/literals/literals-tests.factor +++ b/extra/literals/literals-tests.factor @@ -11,4 +11,10 @@ IN: literals.tests [ { 7 11 } ] [ { $ seven-eleven } ] unit-test [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test +[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test + [ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test + +[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test + +[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index a450c2118e..6df51a35ef 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -1,6 +1,6 @@ ! (c) Joe Groff, see license for details -USING: continuations kernel parser words quotations ; +USING: continuations kernel parser words quotations vectors ; IN: literals -: $ scan-word [ execute ] curry with-datastack ; parsing -: $[ \ ] parse-until >quotation with-datastack ; parsing +: $ scan-word [ execute ] curry with-datastack >vector ; parsing +: $[ \ ] parse-until >quotation with-datastack >vector ; parsing From 3ad52dd85b3f371f8fdb4ad9924979a74596c6ec Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 28 Jan 2009 21:23:21 +0100 Subject: [PATCH 03/34] FUEL: New refactoring: extract region as ARTICLE: (C-cC-xa). --- misc/fuel/README | 1 + misc/fuel/fuel-mode.el | 1 + misc/fuel/fuel-refactor.el | 47 ++++++++++++++++++++++++++++++-------- misc/fuel/fuel-syntax.el | 7 +++--- 4 files changed, 43 insertions(+), 13 deletions(-) diff --git a/misc/fuel/README b/misc/fuel/README index cf96e29f52..198c9bb275 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -129,6 +129,7 @@ beast. | | (fuel-refactor-extract-vocab) | | C-cC-xi | replace word by its definition (fuel-refactor-inline-word) | | C-cC-xw | rename all uses of a word (fuel-refactor-rename-word) | + | C-cC-xa | extract region as a separate ARTICLE: form | |-----------------+------------------------------------------------------------| *** In the listener: diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 88ad73864a..504308fccd 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -198,6 +198,7 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?e ?w 'fuel-edit-word) (fuel-mode--key ?e ?x 'fuel-eval-definition) +(fuel-mode--key ?x ?a 'fuel-refactor-extract-article) (fuel-mode--key ?x ?i 'fuel-refactor-inline-word) (fuel-mode--key ?x ?r 'fuel-refactor-extract-region) (fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp) diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el index 061adbb82c..bd62227755 100644 --- a/misc/fuel/fuel-refactor.el +++ b/misc/fuel/fuel-refactor.el @@ -78,17 +78,19 @@ (when found (setq result (fuel-refactor--reuse-p (car found))))) (and result found)))) +(defsubst fuel-refactor--insertion-point () + (max (save-excursion (fuel-syntax--beginning-of-defun) (point)) + (save-excursion + (re-search-backward fuel-syntax--end-of-def-regex nil t) + (forward-line 1) + (skip-syntax-forward "-")))) + (defun fuel-refactor--insert-word (word stack-effect code) - (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point))) - (end (save-excursion - (re-search-backward fuel-syntax--end-of-def-regex nil t) - (forward-line 1) - (skip-syntax-forward "-")))) - (let ((start (goto-char (max beg end)))) - (open-line 1) - (insert ": " word " " stack-effect "\n" code " ;\n") - (indent-region start (point)) - (move-overlay fuel-stack--overlay start (point))))) + (let ((start (goto-char (fuel-refactor--insertion-point)))) + (open-line 1) + (insert ": " word " " stack-effect "\n" code " ;\n") + (indent-region start (point)) + (move-overlay fuel-stack--overlay start (point)))) (defun fuel-refactor--extract-other (start end code) (unwind-protect @@ -233,5 +235,30 @@ The region is extended to the closest definition boundaries." (mark-defun) (mark)))) +;;; Extract article: + +(defun fuel-refactor-extract-article (begin end) + "Extracts region as a new ARTICLE form." + (interactive "r") + (let ((topic (read-string "Article topic: ")) + (title (read-string "Article title: "))) + (kill-region begin end) + (insert (format "{ $subsection %s }\n" topic)) + (end-of-line 0) + (save-excursion + (goto-char (fuel-refactor--insertion-point)) + (open-line 1) + (let ((start (point))) + (insert (format "ARTICLE: %S %S\n" topic title)) + (yank) + (when (looking-at "^ *$") (end-of-line 0)) + (insert " ;") + (unwind-protect + (progn + (move-overlay fuel-stack--overlay start (point)) + (sit-for fuel-stack-highlight-period)) + (delete-overlay fuel-stack--overlay)))))) + + (provide 'fuel-refactor) ;;; fuel-refactor.el ends here diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index ad5a025a88..80bfd0afcb 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -158,7 +158,9 @@ "PREDICATE" "PRIMITIVE" "UNION")) -(defconst fuel-syntax--no-indent-def-starts '("SINGLETONS" +(defconst fuel-syntax--no-indent-def-starts '("ARTICLE" + "HELP" + "SINGLETONS" "SYMBOLS" "TUPLE" "VARS")) @@ -179,13 +181,12 @@ (defconst fuel-syntax--single-liner-regex (regexp-opt '("ABOUT:" - "ARTICLE:" "ALIAS:" "CONSTANT:" "C:" "DEFER:" "FORGET:" "GENERIC:" "GENERIC#" - "HELP:" "HEX:" "HOOK:" + "HEX:" "HOOK:" "IN:" "INSTANCE:" "LIBRARY:" "MAIN:" "MATH:" "MIXIN:" From 3cd8fbc6835b73d849da5251956c6178d297a371 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 28 Jan 2009 21:32:19 +0100 Subject: [PATCH 04/34] FUEL: Note about .factor-boot-rc added. --- misc/fuel/README | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/misc/fuel/README b/misc/fuel/README index 198c9bb275..d712560b03 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -53,6 +53,14 @@ beast. factor image (overwriting the current one) with all the needed vocabs. + Alternatively, you can add the following line to your + .factor-boot-rc file: + + "fuel" require + + This will ensure that the image generated while bootstrapping + Factor contains fuel and the vocabularies it depends on. + *** Connecting to a running Factor 'run-factor' starts a new factor listener process managed by Emacs. From 2ea9d0bce1f401229f9b58bb1a1fac96f312a3bc Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 30 Jan 2009 00:20:58 +0100 Subject: [PATCH 05/34] FUEL: Better handling of $see in help browser. --- extra/fuel/help/help.factor | 12 ++++++------ misc/fuel/fuel-markup.el | 9 +++++---- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index e70327bd35..55183734b3 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -2,15 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators help help.crossref -help.markup help.topics io io.streams.string kernel make memoize -namespaces parser prettyprint sequences summary tools.vocabs -tools.vocabs.browser vocabs vocabs.loader words ; +help.markup help.topics io io.streams.string kernel make namespaces +parser prettyprint sequences summary tools.vocabs tools.vocabs.browser +vocabs vocabs.loader words ; IN: fuel.help > ] dip = ] curry all-words swap filter dup empty? not [ first ] [ drop f ] if ; @@ -102,11 +102,11 @@ PRIVATE> : (fuel-vocab-help) ( name -- str ) dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-element) ] if ; -MEMO: (fuel-get-vocabs/author) ( author -- element ) +: (fuel-get-vocabs/author) ( author -- element ) [ "Vocabularies by " prepend \ $heading swap 2array ] [ authored fuel-vocab-list ] bi 2array ; -MEMO: (fuel-get-vocabs/tag) ( tag -- element ) +: (fuel-get-vocabs/tag) ( tag -- element ) [ "Vocabularies tagged " prepend \ $heading swap 2array ] [ tagged fuel-vocab-list ] bi 2array ; diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 7a8fa0c234..2784335fbb 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -585,12 +585,13 @@ (defun fuel-markup--see (e) (let* ((word (nth 1 e)) - (cmd (and word `(:fuel* (,(format "%s" word) fuel-word-see) "fuel" t))) - (res (and cmd - (fuel-eval--retort-result (fuel-eval--send/wait cmd 100))))) + (cmd (and word `(:fuel* ((:quote ,(format "%S" word)) see) "fuel"))) + (ret (and cmd (fuel-eval--send/wait cmd))) + (res (and (not (fuel-eval--retort-error ret)) + (fuel-eval--retort-output ret)))) (if res (fuel-markup--code (list '$code res)) - (fuel-markup--snippet (list '$snippet word))))) + (fuel-markup--snippet (list '$snippet " " word))))) (defun fuel-markup--null (e)) From a5cc358f196a1674aae07154c9cccbfb8e458d98 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 30 Jan 2009 00:33:13 +0100 Subject: [PATCH 06/34] FUEL: Bug fix: escape ';' in fuel pretty print. --- extra/fuel/pprint/pprint.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/pprint/pprint.factor b/extra/fuel/pprint/pprint.factor index 25f3aec14d..9dcbd76368 100644 --- a/extra/fuel/pprint/pprint.factor +++ b/extra/fuel/pprint/pprint.factor @@ -12,7 +12,7 @@ GENERIC: fuel-pprint ( obj -- ) Date: Fri, 30 Jan 2009 00:40:17 +0100 Subject: [PATCH 07/34] FUEL: Even better $see handling in help browser. --- misc/fuel/fuel-markup.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 2784335fbb..9e508b802d 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -585,7 +585,7 @@ (defun fuel-markup--see (e) (let* ((word (nth 1 e)) - (cmd (and word `(:fuel* ((:quote ,(format "%S" word)) see) "fuel"))) + (cmd (and word `(:fuel* ((:quote ,(format "%s" word)) see) "fuel"))) (ret (and cmd (fuel-eval--send/wait cmd))) (res (and (not (fuel-eval--retort-error ret)) (fuel-eval--retort-output ret)))) From 8d522caa82967e2d97bd50cf2a03cb7828528eea Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 30 Jan 2009 00:44:15 +0100 Subject: [PATCH 08/34] FUEL: $synopsis markup implemented. --- misc/fuel/fuel-markup.el | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 9e508b802d..4a5df8e7ea 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -593,10 +593,17 @@ (fuel-markup--code (list '$code res)) (fuel-markup--snippet (list '$snippet " " word))))) -(defun fuel-markup--null (e)) - (defun fuel-markup--synopsis (e) - (insert (format " %S " e))) + (let* ((word (nth 1 e)) + (cmd (and word `(:fuel* ((:quote ,(format "%s" word)) synopsis) "fuel"))) + (ret (and cmd (fuel-eval--send/wait cmd))) + (res (and (not (fuel-eval--retort-error ret)) + (fuel-eval--retort-output ret)))) + (if res + (fuel-markup--code (list '$code res)) + (fuel-markup--snippet (list '$snippet " " word))))) + +(defun fuel-markup--null (e)) (provide 'fuel-markup) From ba3c188b3cc1615dc5c95579ff3dab7de052b371 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 30 Jan 2009 00:48:24 +0100 Subject: [PATCH 09/34] FUEL: Small refactoring. --- misc/fuel/fuel-markup.el | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 4a5df8e7ea..0c2fe91551 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -583,9 +583,9 @@ (defun fuel-markup--notes (e) (fuel-markup--elem-with-heading e "Notes")) -(defun fuel-markup--see (e) +(defun fuel-markup--word-info (e s) (let* ((word (nth 1 e)) - (cmd (and word `(:fuel* ((:quote ,(format "%s" word)) see) "fuel"))) + (cmd (and word `(:fuel* ((:quote ,(format "%s" word)) ,s) "fuel"))) (ret (and cmd (fuel-eval--send/wait cmd))) (res (and (not (fuel-eval--retort-error ret)) (fuel-eval--retort-output ret)))) @@ -593,15 +593,11 @@ (fuel-markup--code (list '$code res)) (fuel-markup--snippet (list '$snippet " " word))))) +(defun fuel-markup--see (e) + (fuel-markup--word-info e 'see)) + (defun fuel-markup--synopsis (e) - (let* ((word (nth 1 e)) - (cmd (and word `(:fuel* ((:quote ,(format "%s" word)) synopsis) "fuel"))) - (ret (and cmd (fuel-eval--send/wait cmd))) - (res (and (not (fuel-eval--retort-error ret)) - (fuel-eval--retort-output ret)))) - (if res - (fuel-markup--code (list '$code res)) - (fuel-markup--snippet (list '$snippet " " word))))) + (fuel-markup--word-info e 'synopsis)) (defun fuel-markup--null (e)) From aad17e43efe9fb52349eb610011c5c51ffb48e35 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 09:39:15 -0600 Subject: [PATCH 10/34] math.affine-transforms, sequences.squish, and svg vocabs --- .../affine-transforms-tests.factor | 48 ++++ .../affine-transforms.factor | 70 ++++++ extra/sequences/squish/squish.factor | 12 + extra/svg/svg-tests.factor | 95 ++++++++ extra/svg/svg.factor | 223 ++++++++++++++++++ 5 files changed, 448 insertions(+) create mode 100644 extra/math/affine-transforms/affine-transforms-tests.factor create mode 100644 extra/math/affine-transforms/affine-transforms.factor create mode 100644 extra/sequences/squish/squish.factor create mode 100644 extra/svg/svg-tests.factor create mode 100644 extra/svg/svg.factor diff --git a/extra/math/affine-transforms/affine-transforms-tests.factor b/extra/math/affine-transforms/affine-transforms-tests.factor new file mode 100644 index 0000000000..f79c0fa63b --- /dev/null +++ b/extra/math/affine-transforms/affine-transforms-tests.factor @@ -0,0 +1,48 @@ +USING: arrays kernel literals tools.test math math.affine-transforms +math.constants math.functions ; +IN: math.affine-transforms.tests + +[ { 7.25 4.25 } ] [ + { 0.75 0.75 } { 0.75 -0.75 } { 5.0 5.0 } + { 1.0 2.0 } a.v +] unit-test + +[ -1.125 ] [ + { 0.75 0.75 } { 0.75 -0.75 } { 5.0 5.0 } + |a| +] unit-test + +{ 1.0 3.0 } { 2.0 4.0 } { 5.0 6.0 } 1array [ + { 1.0 2.0 } { 3.0 4.0 } { 5.0 6.0 } + transpose-axes +] unit-test + +{ 1.0 -1.0 } { 1.0 1.0 } { 0.0 0.0 } 1array [ + { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } + inverse-axes +] unit-test + +{ 1.0 -1.0 } { 1.0 1.0 } { -10.0 0.0 } 1array [ + { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } + inverse-transform +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } 1array [ + { 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } + dup inverse-transform a. +] unit-test + +[ t ] [ + { 0.01 0.02 } { 0.03 0.04 } { 0.05 0.06 } + { 0.011 0.021 } { 0.031 0.041 } { 0.051 0.061 } 0.01 a~ +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } 1array [ + { 5.0 10.0 } +] unit-test + +{ $[ pi 0.25 * cos ] $[ pi 0.25 * sin ] } +{ $[ pi -0.25 * sin ] $[ pi 0.25 * cos ] } +{ 0.0 0.0 } 1array [ + pi 0.25 * +] unit-test diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor new file mode 100644 index 0000000000..141dbf9634 --- /dev/null +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -0,0 +1,70 @@ +USING: accessors arrays combinators combinators.short-circuit kernel math math.vectors +math.functions sequences ; +IN: math.affine-transforms + +TUPLE: affine-transform x y origin ; +C: affine-transform + +CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } } + +: a.v ( a v -- v ) + [ [ x>> ] [ first ] bi* v*n ] + [ [ y>> ] [ second ] bi* v*n ] + [ drop origin>> ] 2tri + v+ v+ ; + +: ( origin -- a ) + [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; +: ( theta -- transform ) + [ cos ] [ sin ] bi + [ 2array ] [ neg swap 2array ] 2bi { 0.0 0.0 } ; +: ( x y -- transform ) + [ 0.0 2array ] [ 0.0 swap 2array ] bi* { 0.0 0.0 } ; + +: center-rotation ( transform center -- transform ) + [ clone dup ] dip [ vneg a.v ] [ v+ ] bi >>origin ; + +: flatten-transform ( transform -- array ) + [ x>> ] [ y>> ] [ origin>> ] tri 3append ; + +: |a| ( a -- det ) + [ [ x>> first ] [ y>> second ] bi * ] + [ [ x>> second ] [ y>> first ] bi * ] bi - ; + +: (inverted-axes) ( a -- x y ) + [ [ y>> second ] [ x>> second neg ] bi 2array ] + [ [ y>> first neg ] [ x>> first ] bi 2array ] + [ |a| ] tri + tuck [ v/n ] 2bi@ ; + +: inverse-axes ( a -- a^-1 ) + (inverted-axes) { 0.0 0.0 } ; + +: inverse-transform ( a -- a^-1 ) + [ inverse-axes dup ] [ origin>> ] bi + a.v vneg >>origin ; + +: transpose-axes ( a -- a^T ) + [ [ x>> first ] [ y>> first ] bi 2array ] + [ [ x>> second ] [ y>> second ] bi 2array ] + [ origin>> ] tri ; + +: a. ( a a -- a ) + transpose-axes { + [ [ x>> ] [ x>> ] bi* v. ] + [ [ x>> ] [ y>> ] bi* v. ] + [ [ y>> ] [ x>> ] bi* v. ] + [ [ y>> ] [ y>> ] bi* v. ] + [ origin>> a.v ] + } 2cleave + [ [ 2array ] 2bi@ ] dip ; + +: v~ ( a b epsilon -- ? ) + [ ~ ] curry 2all? ; + +: a~ ( a b epsilon -- ? ) + { + [ [ [ x>> ] bi@ ] dip v~ ] + [ [ [ y>> ] bi@ ] dip v~ ] + [ [ [ origin>> ] bi@ ] dip v~ ] + } 3&& ; diff --git a/extra/sequences/squish/squish.factor b/extra/sequences/squish/squish.factor new file mode 100644 index 0000000000..6a7ffb49f8 --- /dev/null +++ b/extra/sequences/squish/squish.factor @@ -0,0 +1,12 @@ +USING: combinators.short-circuit fry make math kernel sequences ; +IN: sequences.squish + +: (squish) ( seq quot: ( obj -- ? ) -- ) + 2dup call [ '[ _ (squish) ] each ] [ drop , ] if ; inline recursive + +: squish ( seq quot exemplar -- seq' ) + [ [ (squish) ] ] dip make ; inline + +: squish-strings ( seq -- seq' ) + [ { [ sequence? ] [ integer? not ] } 1&& ] "" squish ; + diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor new file mode 100644 index 0000000000..4ad1514d38 --- /dev/null +++ b/extra/svg/svg-tests.factor @@ -0,0 +1,95 @@ +USING: arrays literals math math.affine-transforms math.functions multiline +svg tools.test ; +IN: svg.tests + +{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } 1array [ + "matrix ( 1 +2.25 -3 , 0.4e+1 ,5.5, 1e-6 )" svg-transform>affine-transform +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } 1array [ + "translate(5.0, 1e1 )" svg-transform>affine-transform +] unit-test + +{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } 1array [ + "translate( 5.0 1e+1)" svg-transform>affine-transform +] unit-test + +{ 2.0 0.0 } { 0.0 2.0 } { 0.0 0.0 } 1array [ + "scale(2.0)" svg-transform>affine-transform +] unit-test + +{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } 1array [ + "scale(2.0 4.0)" svg-transform>affine-transform +] unit-test + +{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } 1array [ + "scale(2.0 4.0)" svg-transform>affine-transform +] unit-test + +{ 1.0 0.0 } { $[ 45 degrees tan ] 1.0 } { 0.0 0.0 } 1array [ + "skewX(45)" svg-transform>affine-transform +] unit-test + +{ 1.0 $[ -45 degrees tan ] } { 0.0 1.0 } { 0.0 0.0 } 1array [ + "skewY(-4.5e1)" svg-transform>affine-transform +] unit-test + +{ $[ 30 degrees cos ] $[ 30 degrees sin ] } +{ $[ -30 degrees sin ] $[ 30 degrees cos ] } { 0.0 0.0 } 1array [ + "rotate(30)" svg-transform>affine-transform +] unit-test + +[ t ] [ + "rotate(30 1.0,2.0)" svg-transform>affine-transform + { $[ 30 degrees cos ] $[ 30 degrees sin ] } + { $[ -30 degrees sin ] $[ 30 degrees cos ] } { + $[ 1.0 30 degrees cos 1.0 * - 30 degrees sin 2.0 * + ] + $[ 2.0 30 degrees cos 2.0 * - 30 degrees sin 1.0 * - ] + } 0.001 a~ +] unit-test + +{ $[ 30 degrees cos ] $[ 30 degrees sin ] } +{ $[ -30 degrees sin ] $[ 30 degrees cos ] } +{ 1.0 2.0 } 1array [ + "translate(1 2) rotate(30)" svg-transform>affine-transform +] unit-test + +[ { + T{ moveto f { 1.0 1.0 } f } + T{ lineto f { 3.0 -1.0 } f } + + T{ lineto f { 2.0 2.0 } t } + T{ lineto f { 2.0 -2.0 } t } + T{ lineto f { 2.0 2.0 } t } + + T{ vertical-lineto f -9.0 t } + T{ vertical-lineto f 1.0 t } + T{ horizontal-lineto f 9.0 f } + T{ horizontal-lineto f 8.0 f } + + T{ closepath } + + T{ moveto f { 0.0 0.0 } f } + + T{ curveto f { -4.0 0.0 } { -8.0 4.0 } { -8.0 8.0 } f } + T{ curveto f { -8.0 4.0 } { -12.0 8.0 } { -16.0 8.0 } f } + + T{ smooth-curveto f { 0.0 2.0 } { 2.0 0.0 } t } + + T{ quadratic-bezier-curveto f { -2.0 0.0 } { 0.0 -2.0 } f } + T{ quadratic-bezier-curveto f { -3.0 0.0 } { 0.0 3.0 } f } + + T{ smooth-quadratic-bezier-curveto f { 1.0 2.0 } t } + T{ smooth-quadratic-bezier-curveto f { 3.0 4.0 } t } + + T{ elliptical-arc f { 5.0 6.0 } 7.0 t f { 8.0 9.0 } f } +} ] [ + <" + M 1.0,+1 3,-10e-1 l 2 2, 2 -2, 2 2 v -9 1 H 9 8 z + M 0 0 C -4.0 0.0 -8.0 4.0 -8.0 8.0 -8.0 4.0 -12.0 8.0 -16.0 8.0 + s 0.0,2.0 2.0,0.0 + Q -2 0 0 -2 -3. 0 0 3 + t 1 2 3 4 + A 5 6 7 1 0 8 9 + "> svg-path>array +] unit-test diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor new file mode 100644 index 0000000000..b5c5e96e90 --- /dev/null +++ b/extra/svg/svg.factor @@ -0,0 +1,223 @@ +USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants +math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish +splitting strings xml.data xml.utilities ; +IN: svg + +XML-NS: svg-name http://www.w3.org/2000/svg +XML-NS: xlink-name http://www.w3.org/1999/xlink +XML-NS: sodipodi-name http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd +XML-NS: inkscape-name http://www.inkscape.org/namespaces/inkscape + +: svg-string>number ( string -- number ) + { { CHAR: E CHAR: e } } substitute "e" split1 + [ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* * + >float ; + +: degrees ( deg -- rad ) pi * 180.0 / ; + +EBNF: svg-transform>affine-transform + +transforms = + transform:m comma-wsp+ transforms:n => [[ m n a. ]] + | transform +transform = + matrix + | translate + | scale + | rotate + | skewX + | skewY +matrix = + "matrix" wsp* "(" wsp* + number:xx comma-wsp + number:xy comma-wsp + number:yx comma-wsp + number:yy comma-wsp + number:ox comma-wsp + number:oy wsp* ")" + => [[ { xx xy } { yx yy } { ox oy } ]] +translate = + "translate" wsp* "(" wsp* number:tx ( comma-wsp number:ty => [[ ty ]] )?:ty wsp* ")" + => [[ tx ty 0.0 or 2array ]] +scale = + "scale" wsp* "(" wsp* number:sx ( comma-wsp number:sy => [[ sy ]] )?:sy wsp* ")" + => [[ sx sy sx or ]] +rotate = + "rotate" wsp* "(" wsp* number:a ( comma-wsp number:cx comma-wsp number:cy => [[ cx cy 2array ]])?:c wsp* ")" + => [[ a degrees c [ center-rotation ] when* ]] +skewX = + "skewX" wsp* "(" wsp* number:a wsp* ")" + => [[ { 1.0 0.0 } a degrees tan 1.0 2array { 0.0 0.0 } ]] +skewY = + "skewY" wsp* "(" wsp* number:a wsp* ")" + => [[ 1.0 a degrees tan 2array { 0.0 1.0 } { 0.0 0.0 } ]] +number = + sign? (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]] +comma-wsp = + (wsp+ comma? wsp*) | (comma wsp*) +comma = + "," +integer-constant = + digit-sequence +floating-point-constant = + fractional-constant exponent? + | digit-sequence exponent +fractional-constant = + digit-sequence? "." digit-sequence + | digit-sequence "." +exponent = + ( "e" | "E" ) sign? digit-sequence +sign = + "+" => [[ f ]] | "-" +digit-sequence = [0-9]+ => [[ >string ]] +wsp = (" " | "\t" | "\r" | "\n") + +transform-list = wsp* transforms?:t wsp* + => [[ t [ identity-transform ] unless* ]] + +;EBNF + +: tag-transform ( tag -- transform ) + "transform" svg-name swap at svg-transform>affine-transform ; + +TUPLE: moveto p relative? ; +TUPLE: closepath ; +TUPLE: lineto p relative? ; +TUPLE: horizontal-lineto x relative? ; +TUPLE: vertical-lineto y relative? ; +TUPLE: curveto p1 p2 p relative? ; +TUPLE: smooth-curveto p2 p relative? ; +TUPLE: quadratic-bezier-curveto p1 p relative? ; +TUPLE: smooth-quadratic-bezier-curveto p relative? ; +TUPLE: elliptical-arc radii x-axis-rotation large-arc? sweep? p relative? ; + +: (set-relative) ( args rel -- args ) + '[ [ _ >>relative? drop ] each ] keep ; + +EBNF: svg-path>array + +moveto-drawto-command-groups = + moveto-drawto-command-group:first wsp* moveto-drawto-command-groups:rest + => [[ first rest append ]] + | moveto-drawto-command-group +moveto-drawto-command-group = + moveto:m wsp* drawto-commands?:d => [[ m d append ]] +drawto-commands = + drawto-command:first wsp* drawto-commands:rest => [[ first rest append ]] + | drawto-command +drawto-command = + closepath + | lineto + | horizontal-lineto + | vertical-lineto + | curveto + | smooth-curveto + | quadratic-bezier-curveto + | smooth-quadratic-bezier-curveto + | elliptical-arc +moveto = + ("M" => [[ f ]] | "m" => [[ t ]]):rel wsp* moveto-argument-sequence:args + => [[ args rel (set-relative) ]] +moveto-argument = coordinate-pair => [[ f moveto boa ]] +moveto-argument-sequence = + moveto-argument:first comma-wsp? lineto-argument-sequence:rest + => [[ rest first prefix ]] + | moveto-argument => [[ 1array ]] +closepath = + ("Z" | "z") => [[ drop closepath boa 1array ]] +lineto = + ("L" => [[ f ]] | "l" => [[ t ]]):rel wsp* lineto-argument-sequence:args + => [[ args rel (set-relative) ]] +lineto-argument = coordinate-pair => [[ f lineto boa ]] +lineto-argument-sequence = + lineto-argument:first comma-wsp? lineto-argument-sequence:rest + => [[ rest first prefix ]] + | lineto-argument => [[ 1array ]] +horizontal-lineto = + ( "H" => [[ f ]] | "h" => [[ t ]]):rel wsp* horizontal-lineto-argument-sequence:args + => [[ args rel (set-relative) ]] +horizontal-lineto-argument = coordinate => [[ f horizontal-lineto boa ]] +horizontal-lineto-argument-sequence = + horizontal-lineto-argument:first comma-wsp? horizontal-lineto-argument-sequence:rest + => [[ rest first prefix ]] + | horizontal-lineto-argument => [[ 1array ]] +vertical-lineto = + ( "V" => [[ f ]] | "v" => [[ t ]]):rel wsp* vertical-lineto-argument-sequence:args + => [[ args rel (set-relative) ]] +vertical-lineto-argument = coordinate => [[ f vertical-lineto boa ]] +vertical-lineto-argument-sequence = + vertical-lineto-argument:first comma-wsp? vertical-lineto-argument-sequence:rest + => [[ rest first prefix ]] + | vertical-lineto-argument => [[ 1array ]] +curveto = + ( "C" => [[ f ]] | "c" => [[ t ]]):rel wsp* curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +curveto-argument-sequence = + curveto-argument:first comma-wsp? curveto-argument-sequence:rest + => [[ rest first prefix ]] + | curveto-argument => [[ 1array ]] +curveto-argument = + coordinate-pair:pone comma-wsp? coordinate-pair:ptwo comma-wsp? coordinate-pair:p + => [[ pone ptwo p f curveto boa ]] +smooth-curveto = + ( "S" => [[ f ]] | "s" => [[ t ]] ):rel wsp* smooth-curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +smooth-curveto-argument-sequence = + smooth-curveto-argument:first comma-wsp? smooth-curveto-argument-sequence:rest + => [[ rest first prefix ]] + | smooth-curveto-argument => [[ 1array ]] +smooth-curveto-argument = + coordinate-pair:ptwo comma-wsp? coordinate-pair:p + => [[ ptwo p f smooth-curveto boa ]] +quadratic-bezier-curveto = + ( "Q" => [[ f ]] | "q" => [[ t ]] ):rel wsp* quadratic-bezier-curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +quadratic-bezier-curveto-argument-sequence = + quadratic-bezier-curveto-argument:first comma-wsp? + quadratic-bezier-curveto-argument-sequence:rest + => [[ rest first prefix ]] + | quadratic-bezier-curveto-argument => [[ 1array ]] +quadratic-bezier-curveto-argument = + coordinate-pair:pone comma-wsp? coordinate-pair:p + => [[ pone p f quadratic-bezier-curveto boa ]] +smooth-quadratic-bezier-curveto = + ( "T" => [[ f ]] | "t" => [[ t ]] ):rel wsp* smooth-quadratic-bezier-curveto-argument-sequence:args + => [[ args rel (set-relative) ]] +smooth-quadratic-bezier-curveto-argument-sequence = + smooth-quadratic-bezier-curveto-argument:first comma-wsp? smooth-quadratic-bezier-curveto-argument-sequence:rest + => [[ rest first prefix ]] + | smooth-quadratic-bezier-curveto-argument => [[ 1array ]] +smooth-quadratic-bezier-curveto-argument = coordinate-pair => [[ f smooth-quadratic-bezier-curveto boa ]] +elliptical-arc = + ( "A" => [[ f ]] | "a" => [[ t ]] ):rel wsp* elliptical-arc-argument-sequence:args + => [[ args rel (set-relative) ]] +elliptical-arc-argument-sequence = + elliptical-arc-argument:first comma-wsp? elliptical-arc-argument-sequence:rest + => [[ rest first prefix ]] + | elliptical-arc-argument => [[ 1array ]] +elliptical-arc-argument = + nonnegative-number:radiix comma-wsp? nonnegative-number:radiiy comma-wsp? + number:xrot comma-wsp flag:large comma-wsp flag:sweep + comma-wsp coordinate-pair:p + => [[ radiix radiiy 2array xrot large sweep p f elliptical-arc boa ]] +coordinate-pair = coordinate:x comma-wsp? coordinate:y => [[ x y 2array ]] +coordinate = number +nonnegative-number = (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]] +number = sign? (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]] +flag = "0" => [[ f ]] | "1" => [[ t ]] +comma-wsp = (wsp+ comma? wsp*) | (comma wsp*) +comma = "," +integer-constant = digit-sequence +floating-point-constant = fractional-constant exponent? | digit-sequence exponent +fractional-constant = digit-sequence? "." digit-sequence | digit-sequence "." +exponent = ( "e" | "E" ) sign? digit-sequence +sign = "+" => [[ drop f ]] | "-" +digit-sequence = [0-9]+ => [[ >string ]] +wsp = (" " | "\t" | "\r" | "\n") + +svg-path = wsp* moveto-drawto-command-groups?:x wsp* => [[ x ]] + +;EBNF + +: tag-d ( tag -- d ) + "d" svg-name swap at svg-path>array ; From b06ff3750d3f7483c1afedf66208f279a09ce354 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 10:15:26 -0600 Subject: [PATCH 11/34] Metadata for svg, sequences.squish, math.affine-transforms --- .../affine-transforms-tests.factor | 1 + .../affine-transforms.factor | 1 + extra/math/affine-transforms/authors.txt | 1 + extra/math/affine-transforms/summary.txt | 1 + extra/math/affine-transforms/tags.txt | 1 + extra/sequences/product/product-tests.factor | 19 ++++++++++++++++++ extra/sequences/squish/.squish.factor.swo | Bin 0 -> 12288 bytes extra/sequences/squish/authors.txt | 2 ++ extra/sequences/squish/squish-tests.factor | 8 ++++++++ extra/sequences/squish/squish.factor | 1 + extra/sequences/squish/summary.txt | 1 + extra/sequences/squish/tags.txt | 1 + extra/svg/authors.txt | 1 + extra/svg/summary.txt | 1 + extra/svg/svg-tests.factor | 1 + extra/svg/tags.txt | 3 +++ 16 files changed, 43 insertions(+) create mode 100644 extra/math/affine-transforms/authors.txt create mode 100644 extra/math/affine-transforms/summary.txt create mode 100644 extra/math/affine-transforms/tags.txt create mode 100644 extra/sequences/product/product-tests.factor create mode 100644 extra/sequences/squish/.squish.factor.swo create mode 100644 extra/sequences/squish/authors.txt create mode 100644 extra/sequences/squish/squish-tests.factor create mode 100644 extra/sequences/squish/summary.txt create mode 100644 extra/sequences/squish/tags.txt create mode 100644 extra/svg/authors.txt create mode 100644 extra/svg/summary.txt create mode 100644 extra/svg/tags.txt diff --git a/extra/math/affine-transforms/affine-transforms-tests.factor b/extra/math/affine-transforms/affine-transforms-tests.factor index f79c0fa63b..1d10e07cea 100644 --- a/extra/math/affine-transforms/affine-transforms-tests.factor +++ b/extra/math/affine-transforms/affine-transforms-tests.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff, see BSD license USING: arrays kernel literals tools.test math math.affine-transforms math.constants math.functions ; IN: math.affine-transforms.tests diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 141dbf9634..822af51614 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff, see BSD license USING: accessors arrays combinators combinators.short-circuit kernel math math.vectors math.functions sequences ; IN: math.affine-transforms diff --git a/extra/math/affine-transforms/authors.txt b/extra/math/affine-transforms/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/math/affine-transforms/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/math/affine-transforms/summary.txt b/extra/math/affine-transforms/summary.txt new file mode 100644 index 0000000000..054d98a5e3 --- /dev/null +++ b/extra/math/affine-transforms/summary.txt @@ -0,0 +1 @@ +Affine transforms for two-dimensional vectors diff --git a/extra/math/affine-transforms/tags.txt b/extra/math/affine-transforms/tags.txt new file mode 100644 index 0000000000..ede10ab61b --- /dev/null +++ b/extra/math/affine-transforms/tags.txt @@ -0,0 +1 @@ +math diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor new file mode 100644 index 0000000000..dfabc166ac --- /dev/null +++ b/extra/sequences/product/product-tests.factor @@ -0,0 +1,19 @@ +USING: arrays kernel sequences sequences.cartesian-product tools.test ; +IN: sequences.product.tests + +[ + { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } +] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test + +[ + { + { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t } + { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f } + } +] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test + +[ + { "012012" "aaabbb" } +] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test + + diff --git a/extra/sequences/squish/.squish.factor.swo b/extra/sequences/squish/.squish.factor.swo new file mode 100644 index 0000000000000000000000000000000000000000..71a1d2add76591b46e66acf75ed3a2f34376dc7d GIT binary patch literal 12288 zcmeI&&u`N(6bEo`oHr2s18+s@T4_nTasakNC73jo9}`lwai}KbIxmg4G)`@&8k)w1 z8xj{T{2_4VKj6fbKL%b%R}fN#xK_{7S592#IsP0Qk2)v)=Wsvl3Tn56_||;e|M)%@ zU+DJCU^V*BHb`YYwmNtw!^|j|EqmY%6^ssyDkqqG7dbS803$OqSumB6N01L1H3$OqSumB6Jh=7cR*xVH2 zgi?L~ul@u0dQ*sZl#=2pPboJj>y+;_?=$5SQ&2CiVY*`&VFfcmI6?2EnmW#GKk`Pf0L zssTYzb=%MuqAos!R{czy3YX2*%?nIRS`sgCQe@KpU9KCK1<=v; zjNWm32(SLEjZ&qwzz||<3fQ4boh()Xi>kCv&#LtnFI2yBwIU6I8J$(@^`KpKw1NH+ zZSwk%dsy#691r?OhkKyRWTbORr{P`bQe%Cfv{j|{kl5Gt4kyy5aE>;|>~|TG+k%#A mcRQVjFv#Rg!V7fX%%BNR48ox`NwP!p5grW=AkzwShvFx={J9_i literal 0 HcmV?d00001 diff --git a/extra/sequences/squish/authors.txt b/extra/sequences/squish/authors.txt new file mode 100644 index 0000000000..580f882c8d --- /dev/null +++ b/extra/sequences/squish/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Joe Groff diff --git a/extra/sequences/squish/squish-tests.factor b/extra/sequences/squish/squish-tests.factor new file mode 100644 index 0000000000..21c8864974 --- /dev/null +++ b/extra/sequences/squish/squish-tests.factor @@ -0,0 +1,8 @@ +! (c)2009 Slava Pestov & Joe Groff, see BSD license +USING: kernel sequences sequences.squish strings tools.test ; +IN: sequences.squish.tests + +[ { { 1 2 3 } { 4 } { 5 6 } } ] [ + V{ { 1 2 3 } V{ { 4 } { 5 6 } } } + [ vector? ] { } squish ; +] unit-test diff --git a/extra/sequences/squish/squish.factor b/extra/sequences/squish/squish.factor index 6a7ffb49f8..c42747af47 100644 --- a/extra/sequences/squish/squish.factor +++ b/extra/sequences/squish/squish.factor @@ -1,3 +1,4 @@ +! (c)2009 Slava Pestov & Joe Groff, see BSD license USING: combinators.short-circuit fry make math kernel sequences ; IN: sequences.squish diff --git a/extra/sequences/squish/summary.txt b/extra/sequences/squish/summary.txt new file mode 100644 index 0000000000..946116716b --- /dev/null +++ b/extra/sequences/squish/summary.txt @@ -0,0 +1 @@ +Sequence flattening with parameterized descent predicate diff --git a/extra/sequences/squish/tags.txt b/extra/sequences/squish/tags.txt new file mode 100644 index 0000000000..63926bbb49 --- /dev/null +++ b/extra/sequences/squish/tags.txt @@ -0,0 +1 @@ +sequences diff --git a/extra/svg/authors.txt b/extra/svg/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/svg/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/svg/summary.txt b/extra/svg/summary.txt new file mode 100644 index 0000000000..e329d1aaaf --- /dev/null +++ b/extra/svg/summary.txt @@ -0,0 +1 @@ +Parsers for SVG data diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor index 4ad1514d38..2e1f88b29b 100644 --- a/extra/svg/svg-tests.factor +++ b/extra/svg/svg-tests.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff, see BSD license USING: arrays literals math math.affine-transforms math.functions multiline svg tools.test ; IN: svg.tests diff --git a/extra/svg/tags.txt b/extra/svg/tags.txt new file mode 100644 index 0000000000..0cf061a252 --- /dev/null +++ b/extra/svg/tags.txt @@ -0,0 +1,3 @@ +xml +graphics +svg From 9d44f16ff6e6bfbf9de732e56e64ae6dac957fdb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 10:29:25 -0600 Subject: [PATCH 12/34] fix sequences.squish test --- extra/sequences/squish/squish-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/sequences/squish/squish-tests.factor b/extra/sequences/squish/squish-tests.factor index 21c8864974..6697ea7c92 100644 --- a/extra/sequences/squish/squish-tests.factor +++ b/extra/sequences/squish/squish-tests.factor @@ -1,8 +1,8 @@ ! (c)2009 Slava Pestov & Joe Groff, see BSD license -USING: kernel sequences sequences.squish strings tools.test ; +USING: kernel sequences sequences.squish tools.test vectors ; IN: sequences.squish.tests [ { { 1 2 3 } { 4 } { 5 6 } } ] [ V{ { 1 2 3 } V{ { 4 } { 5 6 } } } - [ vector? ] { } squish ; + [ vector? ] { } squish ] unit-test From ebf6cbaa0d7dd114aa2b29113d25addfdbae9f79 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 11:42:43 -0600 Subject: [PATCH 13/34] remove math.blas.syntax and merge parsing words into math.blas.vectors/matrices --- basis/math/blas/matrices/matrices-docs.factor | 52 +++++++++++- .../math/blas/matrices/matrices-tests.factor | 2 +- basis/math/blas/matrices/matrices.factor | 12 ++- basis/math/blas/syntax/authors.txt | 1 - basis/math/blas/syntax/summary.txt | 1 - basis/math/blas/syntax/syntax-docs.factor | 78 ------------------ basis/math/blas/syntax/syntax.factor | 44 ---------- basis/math/blas/syntax/tags.txt | 1 - basis/math/blas/vectors/vectors-docs.factor | 29 ++++++- basis/math/blas/vectors/vectors-tests.factor | 2 +- basis/math/blas/vectors/vectors.factor | 11 ++- extra/sequences/squish/.squish.factor.swo | Bin 12288 -> 12288 bytes extra/sequences/squish/squish.factor | 1 - 13 files changed, 99 insertions(+), 135 deletions(-) delete mode 100644 basis/math/blas/syntax/authors.txt delete mode 100644 basis/math/blas/syntax/summary.txt delete mode 100644 basis/math/blas/syntax/syntax-docs.factor delete mode 100644 basis/math/blas/syntax/syntax.factor delete mode 100644 basis/math/blas/syntax/tags.txt diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index 01e0997405..f20a565e1f 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -1,4 +1,4 @@ -USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ; +USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ; IN: math.blas.matrices ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" @@ -21,8 +21,6 @@ ARTICLE: "math.blas-types" "BLAS interface types" { $subsection double-blas-matrix } { $subsection float-complex-blas-matrix } { $subsection double-complex-blas-matrix } -"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:" -{ $subsection "math.blas.syntax" } "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:" { $subsection } { $subsection } @@ -74,7 +72,13 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" { $subsection n*M! } { $subsection n*M } { $subsection M*n } -{ $subsection M/n } ; +{ $subsection M/n } +"Literal syntax:" +{ $subsection POSTPONE: smatrix{ } +{ $subsection POSTPONE: dmatrix{ } +{ $subsection POSTPONE: cmatrix{ } +{ $subsection POSTPONE: zmatrix{ } ; + ABOUT: "math.blas.matrices" @@ -243,3 +247,43 @@ HELP: { $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } } { $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ; +HELP: smatrix{ +{ $syntax <" smatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 1.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + { 0.0 0.0 0.0 1.0 } +} "> } +{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: dmatrix{ +{ $syntax <" dmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 1.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + { 0.0 0.0 0.0 1.0 } +} "> } +{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: cmatrix{ +{ $syntax <" cmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 -1.0 3.0 } + { 0.0 0.0 0.0 C{ 0.0 -1.0 } } +} "> } +{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: zmatrix{ +{ $syntax <" zmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 -1.0 3.0 } + { 0.0 0.0 0.0 C{ 0.0 -1.0 } } +} "> } +{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +{ + POSTPONE: smatrix{ POSTPONE: dmatrix{ + POSTPONE: cmatrix{ POSTPONE: zmatrix{ +} related-words diff --git a/basis/math/blas/matrices/matrices-tests.factor b/basis/math/blas/matrices/matrices-tests.factor index dabf3c3ee9..cf0c25745e 100644 --- a/basis/math/blas/matrices/matrices-tests.factor +++ b/basis/math/blas/matrices/matrices-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax +USING: kernel math.blas.matrices math.blas.vectors sequences tools.test ; IN: math.blas.matrices.tests diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index f6b98e3ae2..7b03ddf42a 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -4,7 +4,8 @@ math math.blas.cblas math.blas.vectors math.blas.vectors.private math.complex math.functions math.order functors words sequences sequences.merged sequences.private shuffle specialized-arrays.direct.float specialized-arrays.direct.double -specialized-arrays.float specialized-arrays.double ; +specialized-arrays.float specialized-arrays.double +parser prettyprint.backend prettyprint.custom ; IN: math.blas.matrices TUPLE: blas-matrix-base underlying ld rows cols transpose ; @@ -258,6 +259,7 @@ XGERC IS cblas_${T}ger${C} MATRIX DEFINES ${TYPE}-blas-matrix DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix +XMATRIX{ DEFINES ${T}matrix{ WHERE @@ -291,6 +293,11 @@ M: MATRIX n*V(*)Vconj+M! [ TYPE>ARG ] (prepare-ger) [ XGERC ] dip ; +: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing + +M: MATRIX pprint-delims + drop \ XMATRIX{ \ } ; + ;FUNCTOR @@ -305,3 +312,6 @@ M: MATRIX n*V(*)Vconj+M! "double-complex" "z" define-complex-blas-matrix >> + +M: blas-matrix-base >pprint-sequence Mrows ; +M: blas-matrix-base pprint* pprint-object ; diff --git a/basis/math/blas/syntax/authors.txt b/basis/math/blas/syntax/authors.txt deleted file mode 100644 index f13c9c1e77..0000000000 --- a/basis/math/blas/syntax/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff diff --git a/basis/math/blas/syntax/summary.txt b/basis/math/blas/syntax/summary.txt deleted file mode 100644 index a71bebb50f..0000000000 --- a/basis/math/blas/syntax/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Literal syntax for BLAS vectors and matrices diff --git a/basis/math/blas/syntax/syntax-docs.factor b/basis/math/blas/syntax/syntax-docs.factor deleted file mode 100644 index 6b58df738a..0000000000 --- a/basis/math/blas/syntax/syntax-docs.factor +++ /dev/null @@ -1,78 +0,0 @@ -USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ; -IN: math.blas.syntax - -ARTICLE: "math.blas.syntax" "BLAS interface literal syntax" -"Vectors:" -{ $subsection POSTPONE: svector{ } -{ $subsection POSTPONE: dvector{ } -{ $subsection POSTPONE: cvector{ } -{ $subsection POSTPONE: zvector{ } -"Matrices:" -{ $subsection POSTPONE: smatrix{ } -{ $subsection POSTPONE: dmatrix{ } -{ $subsection POSTPONE: cmatrix{ } -{ $subsection POSTPONE: zmatrix{ } ; - -ABOUT: "math.blas.syntax" - -HELP: svector{ -{ $syntax "svector{ 1.0 -2.0 3.0 }" } -{ $description "Construct a literal " { $link float-blas-vector } "." } ; - -HELP: dvector{ -{ $syntax "dvector{ 1.0 -2.0 3.0 }" } -{ $description "Construct a literal " { $link double-blas-vector } "." } ; - -HELP: cvector{ -{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; - -HELP: zvector{ -{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; - -{ - POSTPONE: svector{ POSTPONE: dvector{ - POSTPONE: cvector{ POSTPONE: zvector{ -} related-words - -HELP: smatrix{ -{ $syntax <" smatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 1.0 0.0 2.0 } - { 0.0 0.0 1.0 3.0 } - { 0.0 0.0 0.0 1.0 } -} "> } -{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -HELP: dmatrix{ -{ $syntax <" dmatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 1.0 0.0 2.0 } - { 0.0 0.0 1.0 3.0 } - { 0.0 0.0 0.0 1.0 } -} "> } -{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -HELP: cmatrix{ -{ $syntax <" cmatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 C{ 0.0 1.0 } 0.0 2.0 } - { 0.0 0.0 -1.0 3.0 } - { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } -{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -HELP: zmatrix{ -{ $syntax <" zmatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 C{ 0.0 1.0 } 0.0 2.0 } - { 0.0 0.0 -1.0 3.0 } - { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } -{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -{ - POSTPONE: smatrix{ POSTPONE: dmatrix{ - POSTPONE: cmatrix{ POSTPONE: zmatrix{ -} related-words diff --git a/basis/math/blas/syntax/syntax.factor b/basis/math/blas/syntax/syntax.factor deleted file mode 100644 index 2d171a801b..0000000000 --- a/basis/math/blas/syntax/syntax.factor +++ /dev/null @@ -1,44 +0,0 @@ -USING: kernel math.blas.vectors math.blas.matrices parser -arrays prettyprint.backend prettyprint.custom sequences ; -IN: math.blas.syntax - -: svector{ - \ } [ >float-blas-vector ] parse-literal ; parsing -: dvector{ - \ } [ >double-blas-vector ] parse-literal ; parsing -: cvector{ - \ } [ >float-complex-blas-vector ] parse-literal ; parsing -: zvector{ - \ } [ >double-complex-blas-vector ] parse-literal ; parsing - -: smatrix{ - \ } [ >float-blas-matrix ] parse-literal ; parsing -: dmatrix{ - \ } [ >double-blas-matrix ] parse-literal ; parsing -: cmatrix{ - \ } [ >float-complex-blas-matrix ] parse-literal ; parsing -: zmatrix{ - \ } [ >double-complex-blas-matrix ] parse-literal ; parsing - -M: float-blas-vector pprint-delims - drop \ svector{ \ } ; -M: double-blas-vector pprint-delims - drop \ dvector{ \ } ; -M: float-complex-blas-vector pprint-delims - drop \ cvector{ \ } ; -M: double-complex-blas-vector pprint-delims - drop \ zvector{ \ } ; - -M: float-blas-matrix pprint-delims - drop \ smatrix{ \ } ; -M: double-blas-matrix pprint-delims - drop \ dmatrix{ \ } ; -M: float-complex-blas-matrix pprint-delims - drop \ cmatrix{ \ } ; -M: double-complex-blas-matrix pprint-delims - drop \ zmatrix{ \ } ; - -M: blas-vector-base >pprint-sequence ; -M: blas-vector-base pprint* pprint-object ; -M: blas-matrix-base >pprint-sequence Mrows ; -M: blas-matrix-base pprint* pprint-object ; diff --git a/basis/math/blas/syntax/tags.txt b/basis/math/blas/syntax/tags.txt deleted file mode 100644 index ede10ab61b..0000000000 --- a/basis/math/blas/syntax/tags.txt +++ /dev/null @@ -1 +0,0 @@ -math diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index cb26d67334..b37a4b966e 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -23,7 +23,12 @@ ARTICLE: "math.blas.vectors" "BLAS interface vector operations" { $subsection V- } "Vector inner products:" { $subsection V. } -{ $subsection V.conj } ; +{ $subsection V.conj } +"Literal syntax:" +{ $subsection POSTPONE: svector{ } +{ $subsection POSTPONE: dvector{ } +{ $subsection POSTPONE: cvector{ } +{ $subsection POSTPONE: zvector{ } ; ABOUT: "math.blas.vectors" @@ -129,3 +134,25 @@ HELP: V/n HELP: Vsub { $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } } { $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ; + +HELP: svector{ +{ $syntax "svector{ 1.0 -2.0 3.0 }" } +{ $description "Construct a literal " { $link float-blas-vector } "." } ; + +HELP: dvector{ +{ $syntax "dvector{ 1.0 -2.0 3.0 }" } +{ $description "Construct a literal " { $link double-blas-vector } "." } ; + +HELP: cvector{ +{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } +{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; + +HELP: zvector{ +{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } +{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; + +{ + POSTPONE: svector{ POSTPONE: dvector{ + POSTPONE: cvector{ POSTPONE: zvector{ +} related-words + diff --git a/basis/math/blas/vectors/vectors-tests.factor b/basis/math/blas/vectors/vectors-tests.factor index 5f9e8fdc42..da271a4fc7 100644 --- a/basis/math/blas/vectors/vectors-tests.factor +++ b/basis/math/blas/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ; +USING: kernel math.blas.vectors sequences tools.test ; IN: math.blas.vectors.tests ! clone diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index c86fa30115..3b7f89f730 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -2,7 +2,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel math math.blas.cblas math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private -functors words locals +functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double specialized-arrays.direct.float specialized-arrays.direct.double ; IN: math.blas.vectors @@ -138,6 +138,8 @@ VECTOR DEFINES ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector +XVECTOR{ DEFINES ${T}vector{ + WHERE TUPLE: VECTOR < blas-vector-base ; @@ -165,6 +167,11 @@ M: VECTOR (blas-direct-array) [ [ length>> ] [ inc>> ] bi * ] bi ; +: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing + +M: VECTOR pprint-delims + drop \ XVECTOR{ \ } ; + ;FUNCTOR @@ -270,3 +277,5 @@ M: VECTOR n*V! >> +M: blas-vector-base >pprint-sequence ; +M: blas-vector-base pprint* pprint-object ; diff --git a/extra/sequences/squish/.squish.factor.swo b/extra/sequences/squish/.squish.factor.swo index 71a1d2add76591b46e66acf75ed3a2f34376dc7d..ca9453dd0caf1e72273bb82674e6c764e9f681da 100644 GIT binary patch delta 69 zcmZojXh@JxG6?hZRWR2xVgLdG28JB7W>23fDGYmo+^qc6i3e3Tx}4x= Date: Fri, 30 Jan 2009 12:49:22 -0600 Subject: [PATCH 14/34] rename a word --- extra/benchmark/knucleotide/knucleotide.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index 5264cd26de..99b0ee15f4 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -46,7 +46,7 @@ IN: benchmark.knucleotide tuck length small-groups H{ } tally at [ 0 ] unless* - number>string 8 CHAR: \s pad-right write ; + number>string 8 CHAR: \s pad-tail write ; : process-input ( input -- ) dup 1 handle-table nl From a46d7b34f2bdb33e9767e287c13e8cd3eefd5898 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 14:40:08 -0600 Subject: [PATCH 15/34] Constructors experiment --- extra/constructors/authors.txt | 1 + extra/constructors/constructors-tests.factor | 21 ++++++++++++++++++++ extra/constructors/constructors.factor | 21 ++++++++++++++++++++ 3 files changed, 43 insertions(+) create mode 100644 extra/constructors/authors.txt create mode 100644 extra/constructors/constructors-tests.factor create mode 100644 extra/constructors/constructors.factor diff --git a/extra/constructors/authors.txt b/extra/constructors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/constructors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor new file mode 100644 index 0000000000..367f0ad143 --- /dev/null +++ b/extra/constructors/constructors-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test constructors calendar kernel accessors +combinators.short-circuit ; +IN: constructors.tests + +TUPLE: stock-spread stock spread timestamp ; + +CONSTRUCTOR: stock-spread ( stock spread -- stock-spread ) + now >>timestamp ; + +SYMBOL: AAPL + +[ t ] [ + AAPL 1234 + { + [ stock>> AAPL eq? ] + [ spread>> 1234 = ] + [ timestamp>> timestamp? ] + } 1&& +] unit-test \ No newline at end of file diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor new file mode 100644 index 0000000000..6968fd7eda --- /dev/null +++ b/extra/constructors/constructors.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: slots kernel sequences fry accessors parser lexer words +effects.parser ; +IN: constructors + +! An experiment + +: constructor-quot ( class slot-names body -- quot ) + [ [ setter-word '[ swap _ execute ] ] map [ ] join ] dip + '[ _ new @ @ ] ; + +: define-constructor ( name class effect body -- ) + [ [ in>> ] dip constructor-quot ] [ drop ] 2bi + define-declared ; + +: CONSTRUCTOR: + scan-word [ name>> "<" ">" surround create-in ] keep + "(" expect ")" parse-effect + parse-definition + define-constructor ; parsing \ No newline at end of file From 67a1734f8b8c596528e552485a7cb1220141dc4f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 14:43:12 -0600 Subject: [PATCH 16/34] Add .swo to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index a7cbeeeef3..05a53c02c6 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,4 @@ work build-support/wordsize *.bak .#* +*.swo From fbc69718a7239cc03f5d0017e4b4dc9c8ff4267f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 14:44:39 -0600 Subject: [PATCH 17/34] Remove .swo file --- extra/sequences/squish/.squish.factor.swo | Bin 12288 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 extra/sequences/squish/.squish.factor.swo diff --git a/extra/sequences/squish/.squish.factor.swo b/extra/sequences/squish/.squish.factor.swo deleted file mode 100644 index ca9453dd0caf1e72273bb82674e6c764e9f681da..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 12288 zcmeI2&2G~`5XZOW%9rR1OoNmrQf;R};-fu8DwV20sgRn^-t&0+=ys;5pdMhJ`vkD7^ zE^@OcfYj>8~09DZsi}C025#WOn?b60Vco% zm;e*Fo&!h2cwS_2gFaajO1egF5U;<2l2`~XBzyz286JP?@gn*2N*tjjk zD^mUazy1&4`yC-Zk}8rXJty5Dt&@JxzOSS&q)(*!+$o8J2`~XBzyz286JP>NfC(@G zCcp&#O9DVKhPR}vVeSE((VH$jPSFmaFrF6P!A`qPxz&PZ)EoB1?&2|U-s)oNpi_H5 z5Y%Z4xRoX*h-!vWO(x-5Nw!rMS4UyY~j_US%y(cir g Date: Fri, 30 Jan 2009 14:56:44 -0600 Subject: [PATCH 18/34] Clean up CONSTRUCTOR: with Dan's idea: introduce set-slots and construct macros --- extra/constructors/constructors.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor index 6968fd7eda..30d286eb96 100644 --- a/extra/constructors/constructors.factor +++ b/extra/constructors/constructors.factor @@ -1,17 +1,19 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: slots kernel sequences fry accessors parser lexer words -effects.parser ; +effects.parser macros ; IN: constructors ! An experiment -: constructor-quot ( class slot-names body -- quot ) - [ [ setter-word '[ swap _ execute ] ] map [ ] join ] dip - '[ _ new @ @ ] ; +MACRO: set-slots ( slots -- quot ) + [ setter-word '[ swap _ execute ] ] map [ ] join ; + +: construct ( ... class slots -- instance ) + [ new ] dip set-slots ; inline : define-constructor ( name class effect body -- ) - [ [ in>> ] dip constructor-quot ] [ drop ] 2bi + [ [ in>> ] dip '[ _ _ construct @ ] ] [ drop ] 2bi define-declared ; : CONSTRUCTOR: From 43672d90cb29f289b8db658160edf203e580f5bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 15:16:05 -0600 Subject: [PATCH 19/34] Minor tweak --- extra/constructors/constructors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor index 30d286eb96..2eab91310f 100644 --- a/extra/constructors/constructors.factor +++ b/extra/constructors/constructors.factor @@ -13,7 +13,7 @@ MACRO: set-slots ( slots -- quot ) [ new ] dip set-slots ; inline : define-constructor ( name class effect body -- ) - [ [ in>> ] dip '[ _ _ construct @ ] ] [ drop ] 2bi + [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi define-declared ; : CONSTRUCTOR: From f31cf8e9a93ba065db0ee4a7725d9375c451f1dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 Jan 2009 15:21:46 -0600 Subject: [PATCH 20/34] fix empty description --- basis/math/bitwise/bitwise-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 18ae8e1497..358c984276 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -242,7 +242,7 @@ HELP: shift-mod { "n" integer } { "s" integer } { "w" integer } { "n" integer } } -{ $description "" } ; +{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ; HELP: unmask { $values From 16c1f210a66d88a5e07ddc1d00a8f53b788b03b7 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 30 Jan 2009 22:24:53 +0100 Subject: [PATCH 21/34] FUEL: Fix for $vocab-link markup. --- misc/fuel/fuel-markup.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 0c2fe91551..3aee2dc912 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -323,7 +323,7 @@ (sort-lines nil start (point)))))) (defun fuel-markup--vocab-link (e) - (fuel-markup--insert-button (cadr e) (cadr e) 'vocab)) + (fuel-markup--insert-button (cadr e) (car (cddr e)) 'vocab)) (defun fuel-markup--vocab-links (e) (dolist (link (cdr e)) From e5897b5ef740c9559fd7b48055201d279fec9aa5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 15:28:53 -0600 Subject: [PATCH 22/34] Remove bogus dependencies --- basis/html/streams/streams.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 24d9dceb80..43fa8bda85 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators generic assocs help http io io.styles +USING: combinators generic assocs io io.styles io.files continuations io.streams.string kernel math math.order math.parser namespaces make quotations assocs sequences strings words html.elements xml.entities sbufs continuations destructors From e872eb1e8e1b5f5e2fe81b53d6088048d0eba81d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 Jan 2009 15:29:28 -0600 Subject: [PATCH 23/34] fix docs for environment --- basis/environment/environment-docs.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/environment/environment-docs.factor b/basis/environment/environment-docs.factor index e539b446f3..b48a7a01ad 100644 --- a/basis/environment/environment-docs.factor +++ b/basis/environment/environment-docs.factor @@ -7,12 +7,14 @@ HELP: (os-envs) { $values { "seq" sequence } } -{ $description "" } ; +{ $description "Returns a sequence of key/value pairs from the operating system." } +{ $notes "In most cases, use " { $link os-envs } " instead." } ; HELP: (set-os-envs) { $values { "seq" sequence } } -{ $description "" } ; +{ $description "Low-level word for replacing the current set of environment variables." } +{ $notes "In most cases, use " { $link set-os-envs } " instead." } ; HELP: os-env ( key -- value ) From 23d4699d5c59cefffe26b61c1720df927f98a9b3 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 30 Jan 2009 22:32:20 +0100 Subject: [PATCH 24/34] FUEL: Fix the previous fix. --- misc/fuel/fuel-markup.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 3aee2dc912..4844233ae7 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -323,7 +323,7 @@ (sort-lines nil start (point)))))) (defun fuel-markup--vocab-link (e) - (fuel-markup--insert-button (cadr e) (car (cddr e)) 'vocab)) + (fuel-markup--insert-button (cadr e) (or (car (cddr e)) (cadr e)) 'vocab)) (defun fuel-markup--vocab-links (e) (dolist (link (cdr e)) From 267e24676602f7d3789cb4dfb0004e869aebbd0f Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 30 Jan 2009 14:17:12 -0800 Subject: [PATCH 25/34] Support "%s" for numbers, and add support for sequences and assocs formatting. --- basis/formatting/formatting-docs.factor | 32 ++++++++++++++++--------- basis/formatting/formatting.factor | 14 +++++++---- 2 files changed, 31 insertions(+), 15 deletions(-) diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor index cfa322fb53..95b24ae351 100644 --- a/basis/formatting/formatting-docs.factor +++ b/basis/formatting/formatting-docs.factor @@ -12,17 +12,19 @@ HELP: printf "specifying attributes for the result string, including such things as maximum width, " "padding, and decimals.\n" { $table - { "%%" "Single %" "" } - { "%P.Ds" "String format" "string" } - { "%P.DS" "String format uppercase" "string" } - { "%c" "Character format" "char" } - { "%C" "Character format uppercase" "char" } - { "%+Pd" "Integer format" "fixnum" } - { "%+P.De" "Scientific notation" "fixnum, float" } - { "%+P.DE" "Scientific notation" "fixnum, float" } - { "%+P.Df" "Fixed format" "fixnum, float" } - { "%+Px" "Hexadecimal" "hex" } - { "%+PX" "Hexadecimal uppercase" "hex" } + { "%%" "Single %" "" } + { "%P.Ds" "String format" "string" } + { "%P.DS" "String format uppercase" "string" } + { "%c" "Character format" "char" } + { "%C" "Character format uppercase" "char" } + { "%+Pd" "Integer format" "fixnum" } + { "%+P.De" "Scientific notation" "fixnum, float" } + { "%+P.DE" "Scientific notation" "fixnum, float" } + { "%+P.Df" "Fixed format" "fixnum, float" } + { "%+Px" "Hexadecimal" "hex" } + { "%+PX" "Hexadecimal uppercase" "hex" } + { "%[%?, %]" "Sequence format" "sequence" } + { "%[%?: %? %]" "Assocs format" "assocs" } } $nl "A plus sign ('+') is used to optionally specify that the number should be " @@ -72,6 +74,14 @@ HELP: printf "USING: formatting ;" "1234 \"%+d\" printf" "+1234" } + { $example + "USING: formatting ;" + "{ 1 2 3 } \"%[%d, %]\" printf" + "{ 1, 2, 3 }" } + { $example + "USING: formatting ;" + "H{ { 1 2 } { 3 4 } } \"%[%d: %d %]\" printf" + "{ 1:2, 3:4 }" } } ; HELP: sprintf diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index a55f0c77c5..5a1e3650fe 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: accessors arrays ascii calendar combinators fry kernel +USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations sequences splitting strings unicode.case vectors ; @@ -75,8 +75,8 @@ digits = (digits_)? => [[ 6 or ]] fmt-% = "%" => [[ [ "%" ] ]] fmt-c = "c" => [[ [ 1string ] ]] fmt-C = "C" => [[ [ 1string >upper ] ]] -fmt-s = "s" => [[ [ ] ]] -fmt-S = "S" => [[ [ >upper ] ]] +fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]] +fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]] fmt-d = "d" => [[ [ >fixnum number>string ] ]] fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]] fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]] @@ -91,7 +91,13 @@ strings = pad width strings_ => [[ reverse compose-all ]] numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]] -formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]] +types = strings|numbers + +lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]] + +assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]] + +formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]] plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] From 2b6f9f31ff2f523c34cafb916db57390552d2d9f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 Jan 2009 16:17:50 -0600 Subject: [PATCH 26/34] fix help-lint docs for db --- basis/db/db-docs.factor | 2 +- basis/db/types/types-docs.factor | 93 ++++---------------------------- 2 files changed, 10 insertions(+), 85 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 08544b3367..c392ec6b85 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -173,7 +173,7 @@ HELP: with-db HELP: with-transaction { $values { "quot" quotation } } -{ $description "" } ; +{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ; ARTICLE: "db" "Database library" "Accessing a database:" diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index b8ccbd976f..4d3be1d592 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes hashtables help.markup help.syntax io.streams.string -kernel sequences strings math ; +kernel sequences strings math db.tuples db.tuples.private ; IN: db.types HELP: +db-assigned-id+ @@ -27,15 +27,11 @@ HELP: +user-assigned-id+ HELP: { $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } } -{ $description "" } ; +{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ; HELP: { $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } } -{ $description "" } ; - -HELP: -{ $values { "value" object } { "low-level-binding" low-level-binding } } -{ $description "" } ; +{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ; HELP: BIG-INTEGER { $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ; @@ -100,18 +96,12 @@ HELP: user-assigned-id-spec? HELP: bind# { $values { "spec" "a sql spec" } { "obj" object } } -{ $description "" } ; +{ $description "A generic word that lets a database construct a literal binding." } ; HELP: bind% { $values { "spec" "a sql spec" } } -{ $description "" } ; - -HELP: compound -{ $values - { "string" string } { "obj" object } - { "hash" hashtable } } -{ $description "" } ; +{ $description "A generic word that lets a database output a binding." } ; HELP: db-assigned-id-spec? { $values @@ -126,45 +116,12 @@ HELP: find-primary-key { $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." } { $notes "This is a low-level word." } ; -HELP: generator-bind -{ $description "" } ; - HELP: get-slot-named { $values { "name" "a slot name" } { "tuple" tuple } { "value" "the value stored in the slot" } } { $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ; -HELP: literal-bind -{ $description "" } ; - -HELP: lookup-create-type -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - -HELP: lookup-modifier -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - -HELP: lookup-type -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - -HELP: low-level-binding -{ $description "" } ; - -HELP: modifiers -{ $values - { "spec" "a sql spec" } - { "string" string } } -{ $description "" } ; - HELP: no-sql-type { $values { "type" "a sql type" } } @@ -173,7 +130,7 @@ HELP: no-sql-type HELP: normalize-spec { $values { "spec" "a sql spec" } } -{ $description "" } ; +{ $description "Normalizes a sql spec." } ; HELP: offset-of-slot { $values @@ -181,52 +138,20 @@ HELP: offset-of-slot { "n" integer } } { $description "Returns the offset of a tuple slot accessed by name." } ; -HELP: persistent-table -{ $values - - { "hash" hashtable } } -{ $description "" } ; - HELP: primary-key? { $values { "spec" "a sql spec" } { "?" "a boolean" } } -{ $description "" } ; +{ $description "Returns true if a sql spec is a primary key." } ; HELP: random-id-generator -{ $description "" } ; +{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ; HELP: relation? { $values { "spec" "a sql spec" } { "?" "a boolean" } } -{ $description "" } ; - -HELP: remove-db-assigned-id -{ $values - { "specs" "a sequence of sql specs" } - { "obj" object } } -{ $description "" } ; - -HELP: remove-id -{ $values - { "specs" "a sequence of sql specs" } - { "obj" object } } -{ $description "" } ; - -HELP: set-slot-named -{ $values - { "value" object } { "name" string } { "obj" object } } -{ $description "" } ; - -HELP: spec>tuple -{ $values - { "class" class } { "spec" "a sql spec" } - { "tuple" tuple } } -{ $description "" } ; - -HELP: sql-spec -{ $description "" } ; +{ $description "Returns true if a sql spec is a relation." } ; HELP: unknown-modifier { $values { "modifier" string } } From a60e11b89e328b57b5121f6cc0fd6c0a9a9ae9c8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 Jan 2009 16:45:30 -0600 Subject: [PATCH 27/34] add RTLD_GLOBAL to dlopen flags. load atlas before cblas on freebsd --- basis/math/blas/cblas/cblas.factor | 12 +++++++++--- vm/os-unix.c | 2 +- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor index 4c0a88f929..3914c5b2ec 100644 --- a/basis/math/blas/cblas/cblas.factor +++ b/basis/math/blas/cblas/cblas.factor @@ -1,13 +1,19 @@ USING: alien alien.c-types alien.syntax kernel system combinators ; IN: math.blas.cblas -<< "cblas" { +<< +: load-atlas ( -- ) + "atlas" "libatlas.so" "cdecl" add-library + "atlas" load-library drop ; + +"cblas" { { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] } - { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] } + { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] } [ "libblas.so" "cdecl" add-library ] -} cond >> +} cond +>> LIBRARY: cblas diff --git a/vm/os-unix.c b/vm/os-unix.c index 97c29d8c6e..b49f7637af 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -36,7 +36,7 @@ void init_ffi(void) void ffi_dlopen(F_DLL *dll) { - dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); + dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY|RTLD_GLOBAL); } void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) From 7a4b03821b995332cb2a023557f697e9efd36de0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 16:52:03 -0600 Subject: [PATCH 28/34] Fix furnace help lint warning --- basis/furnace/utilities/utilities-docs.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index 1402e9c0ca..d2291786df 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -57,7 +57,7 @@ HELP: modify-redirect-query HELP: nested-responders { $values { "seq" "a sequence of responders" } } -{ $description "" } ; +{ $description "Outputs a sequence of responders which participated in the processing of the current request, with the main responder first and the innermost responder last." } ; HELP: referrer { $values { "referrer/f" { $maybe string } } } @@ -69,11 +69,11 @@ HELP: request-params HELP: resolve-base-path { $values { "string" string } { "string'" string } } -{ $description "" } ; +{ $description "Resolves a responder-relative URL." } ; HELP: resolve-template-path { $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } -{ $description "" } ; +{ $description "Resolves a responder-relative template path." } ; HELP: same-host? { $values { "url" url } { "?" "a boolean" } } @@ -85,7 +85,7 @@ HELP: user-agent HELP: vocab-path { $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } -{ $description "" } ; +{ $description "Outputs the full pathname of the vocabulary's source directory." } ; HELP: exit-with { $values { "value" object } } From 658743bb00c2a7e5357a4db2e3e7228f107a6d43 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 17:13:12 -0600 Subject: [PATCH 29/34] add missing copyright to svg.factor --- extra/svg/svg.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor index b5c5e96e90..6df7314653 100644 --- a/extra/svg/svg.factor +++ b/extra/svg/svg.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff, see BSD license USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish splitting strings xml.data xml.utilities ; From 8b68e80254e35c3b5ef862b0aac9bcb255e8d2db Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 17:13:40 -0600 Subject: [PATCH 30/34] load libblas before libcblas on openbsd --- basis/math/blas/cblas/cblas.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor index 3914c5b2ec..54616d42de 100644 --- a/basis/math/blas/cblas/cblas.factor +++ b/basis/math/blas/cblas/cblas.factor @@ -3,13 +3,14 @@ IN: math.blas.cblas << : load-atlas ( -- ) - "atlas" "libatlas.so" "cdecl" add-library - "atlas" load-library drop ; + "atlas" "libatlas.so" "cdecl" add-library ; +: load-blas ( -- ) + "blas" "libblas.so" "cdecl" add-library ; "cblas" { { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] } + { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] } { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] } [ "libblas.so" "cdecl" add-library ] } cond From f1182ef800c429a68ff9afc370fabff3e161189d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 Jan 2009 17:28:06 -0600 Subject: [PATCH 31/34] use CONSTANT: for cblas constants --- basis/math/blas/cblas/cblas.factor | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor index 54616d42de..11552d67bb 100644 --- a/basis/math/blas/cblas/cblas.factor +++ b/basis/math/blas/cblas/cblas.factor @@ -19,25 +19,25 @@ IN: math.blas.cblas LIBRARY: cblas TYPEDEF: int CBLAS_ORDER -: CblasRowMajor 101 ; inline -: CblasColMajor 102 ; inline +CONSTANT: CblasRowMajor 101 +CONSTANT: CblasColMajor 102 TYPEDEF: int CBLAS_TRANSPOSE -: CblasNoTrans 111 ; inline -: CblasTrans 112 ; inline -: CblasConjTrans 113 ; inline +CONSTANT: CblasNoTrans 111 +CONSTANT: CblasTrans 112 +CONSTANT: CblasConjTrans 113 TYPEDEF: int CBLAS_UPLO -: CblasUpper 121 ; inline -: CblasLower 122 ; inline +CONSTANT: CblasUpper 121 +CONSTANT: CblasLower 122 TYPEDEF: int CBLAS_DIAG -: CblasNonUnit 131 ; inline -: CblasUnit 132 ; inline +CONSTANT: CblasNonUnit 131 +CONSTANT: CblasUnit 132 TYPEDEF: int CBLAS_SIDE -: CblasLeft 141 ; inline -: CblasRight 142 ; inline +CONSTANT: CblasLeft 141 +CONSTANT: CblasRight 142 TYPEDEF: int CBLAS_INDEX From f1a1760e6ead33bef83ca823cf0f1e874e7a2aa8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 Jan 2009 19:23:04 -0600 Subject: [PATCH 32/34] add csv>file and file>csv words, better docs for csv, a few cleanups --- basis/csv/csv-docs.factor | 48 ++++++++++++++----- basis/csv/csv-tests.factor | 16 ++++++- basis/csv/csv.factor | 95 ++++++++++++++++++++++---------------- 3 files changed, 106 insertions(+), 53 deletions(-) diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index e4741f4810..6ae75b6b2f 100644 --- a/basis/csv/csv-docs.factor +++ b/basis/csv/csv-docs.factor @@ -1,28 +1,52 @@ -USING: help.syntax help.markup kernel prettyprint sequences ; +USING: help.syntax help.markup kernel prettyprint sequences +io.pathnames ; IN: csv HELP: csv { $values { "stream" "an input stream" } { "rows" "an array of arrays of fields" } } -{ $description "parses a csv stream into an array of row arrays" -} ; +{ $description "Parses a csv stream into an array of row arrays." } ; + +HELP: file>csv +{ $values + { "path" pathname } { "encoding" "an encoding descriptor" } + { "csv" "csv" } +} +{ $description "Opens a file and parses it into a sequence of comma-separated-value fields." } ; + +HELP: csv>file +{ $values + { "rows" "a sequence of sequences of strings" } + { "path" pathname } { "encoding" "an encoding descriptor" } +} +{ $description "Writes a comma-separated-value structure to a file." } ; HELP: csv-row { $values { "stream" "an input stream" } { "row" "an array of fields" } } -{ $description "parses a row from a csv stream" -} ; +{ $description "parses a row from a csv stream" } ; HELP: write-csv -{ $values { "rows" "an sequence of sequences of strings" } +{ $values { "rows" "a sequence of sequences of strings" } { "stream" "an output stream" } } -{ $description "writes csv to the output stream, escaping where necessary" -} ; - +{ $description "Writes a sequence of sequences of comma-separated-values to the output stream, escaping where necessary." } ; HELP: with-delimiter -{ $values { "char" "field delimiter (e.g. CHAR: \t)" } +{ $values { "ch" "field delimiter (e.g. CHAR: \t)" } { "quot" "a quotation" } } -{ $description "Sets the field delimiter for csv or csv-row words " -} ; +{ $description "Sets the field delimiter for csv or csv-row words." } ; +ARTICLE: "csv" "Comma-separated-values parsing and writing" +"The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl +"Reading a csv file:" +{ $subsection file>csv } +"Writing a csv file:" +{ $subsection csv>file } +"Changing the delimiter from a comma:" +{ $subsection with-delimiter } +"Reading from a stream:" +{ $subsection csv } +"Writing to a stream:" +{ $subsection write-csv } ; + +ABOUT: "csv" diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 8261ae104a..4d78c2af86 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -1,5 +1,7 @@ +USING: io.streams.string csv tools.test shuffle kernel strings +io.pathnames io.files.unique io.encodings.utf8 io.files +io.directories ; IN: csv.tests -USING: io.streams.string csv tools.test shuffle kernel strings ; ! I like to name my unit tests : named-unit-test ( name output input -- ) @@ -76,3 +78,15 @@ USING: io.streams.string csv tools.test shuffle kernel strings ; "escapes quotes commas and newlines when writing" [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] [ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } tuck write-csv >string ] named-unit-test ! " + +[ { { "writing" "some" "csv" "tests" } } ] +[ + "writing,some,csv,tests" + "csv-test1-" unique-file utf8 + [ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri +] unit-test + +[ t ] [ + { { "writing,some,csv,tests" } } dup "csv-test2-" + unique-file utf8 [ csv>file ] [ file>csv ] 2bi = +] unit-test diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index bc3c25d347..7789f015d9 100755 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -1,89 +1,104 @@ ! Copyright (C) 2007, 2008 Phil Dawes ! See http://factorcode.org/license.txt for BSD license. - -! Simple CSV Parser -! Phil Dawes phil@phildawes.net - -USING: kernel sequences io namespaces make -combinators unicode.categories ; +USING: kernel sequences io namespaces make combinators +unicode.categories io.files combinators.short-circuit ; IN: csv SYMBOL: delimiter CHAR: , delimiter set-global + ( -- delimiter ) delimiter get ; inline DEFER: quoted-field ( -- endchar ) -! trims whitespace from either end of string : trim-whitespace ( str -- str ) - [ blank? ] trim ; inline + [ blank? ] trim ; inline : skip-to-field-end ( -- endchar ) "\n" delimiter> suffix read-until nip ; inline : not-quoted-field ( -- endchar ) - "\"\n" delimiter> suffix read-until ! " - dup - { { CHAR: " [ drop drop quoted-field ] } ! " - { delimiter> [ swap trim-whitespace % ] } - { CHAR: \n [ swap trim-whitespace % ] } - { f [ swap trim-whitespace % ] } ! eof - } case ; + "\"\n" delimiter> suffix read-until + dup { + { CHAR: " [ 2drop quoted-field ] } + { delimiter> [ swap trim-whitespace % ] } + { CHAR: \n [ swap trim-whitespace % ] } + { f [ swap trim-whitespace % ] } + } case ; : maybe-escaped-quote ( -- endchar ) - read1 dup - { { CHAR: " [ , quoted-field ] } ! " is an escaped quote - { delimiter> [ ] } ! end of quoted field - { CHAR: \n [ ] } - [ 2drop skip-to-field-end ] ! end of quoted field + padding - } case ; + read1 dup { + { CHAR: " [ , quoted-field ] } + { delimiter> [ ] } + { CHAR: \n [ ] } + [ 2drop skip-to-field-end ] + } case ; : quoted-field ( -- endchar ) - "\"" read-until ! " - drop % maybe-escaped-quote ; + "\"" read-until + drop % maybe-escaped-quote ; : field ( -- sep string ) - [ not-quoted-field ] "" make ; ! trim-whitespace + [ not-quoted-field ] "" make ; : (row) ( -- sep ) - field , - dup delimiter get = [ drop (row) ] when ; + field , + dup delimiter get = [ drop (row) ] when ; : row ( -- eof? array[string] ) - [ (row) ] { } make ; + [ (row) ] { } make ; : append-if-row-not-empty ( row -- ) - dup { "" } = [ drop ] [ , ] if ; + dup { "" } = [ drop ] [ , ] if ; : (csv) ( -- ) - row append-if-row-not-empty - [ (csv) ] when ; + row append-if-row-not-empty + [ (csv) ] when ; +PRIVATE> + : csv-row ( stream -- row ) - [ row nip ] with-input-stream ; + [ row nip ] with-input-stream ; : csv ( stream -- rows ) - [ [ (csv) ] { } make ] with-input-stream ; + [ [ (csv) ] { } make ] with-input-stream ; -: with-delimiter ( char quot -- ) - delimiter swap with-variable ; inline +: file>csv ( path encoding -- csv ) + csv ; + +: with-delimiter ( ch quot -- ) + [ delimiter ] dip with-variable ; inline + + : write-row ( row -- ) - [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline + [ delimiter get write1 ] + [ escape-if-required write ] interleave nl ; inline : write-csv ( rows stream -- ) - [ [ write-row ] each ] with-output-stream ; + [ [ write-row ] each ] with-output-stream ; + +: csv>file ( rows path encoding -- ) write-csv ; From 9c2a476d98751840a31ad3beb855eeafcca6694b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 Jan 2009 19:24:35 -0600 Subject: [PATCH 33/34] minor cleanup --- basis/csv/csv.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 7789f015d9..152b3dcbba 100755 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -51,12 +51,8 @@ DEFER: quoted-field ( -- endchar ) : row ( -- eof? array[string] ) [ (row) ] { } make ; -: append-if-row-not-empty ( row -- ) - dup { "" } = [ drop ] [ , ] if ; - : (csv) ( -- ) - row append-if-row-not-empty - [ (csv) ] when ; + row harvest [ , ] unless-empty [ (csv) ] when ; PRIVATE> From f8092480a6b1488c397d2c69b616a4342f487c56 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 19:34:31 -0600 Subject: [PATCH 34/34] Fix a couple of bugs in xmode and add a unit test --- basis/xmode/catalog/catalog.factor | 36 +++++++++++--------- basis/xmode/code2html/code2html-tests.factor | 9 ++++- basis/xmode/code2html/code2html.factor | 6 ++-- basis/xmode/loader/loader.factor | 16 ++++----- basis/xmode/loader/syntax/syntax.factor | 13 +++---- basis/xmode/marker/context/context.factor | 4 +-- basis/xmode/marker/marker.factor | 4 +-- 7 files changed, 49 insertions(+), 39 deletions(-) diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 8a8e5fad4a..4e3af0af56 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -52,9 +52,15 @@ SYMBOL: rule-sets dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if* dup -roll at* [ nip ] [ drop no-such-rule-set ] if ; +DEFER: finalize-rule-set + : resolve-delegate ( rule -- ) - dup delegate>> dup string? - [ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ; + dup delegate>> dup string? [ + get-rule-set + dup rule-set? [ "not a rule set" throw ] unless + swap rule-sets [ dup finalize-rule-set ] with-variable + >>delegate drop + ] [ 2drop ] if ; : each-rule ( rule-set quot -- ) [ rules>> values concat ] dip each ; inline @@ -74,26 +80,22 @@ SYMBOL: rule-sets : resolve-imports ( ruleset -- ) dup imports>> [ get-rule-set swap rule-sets [ - dup resolve-delegates - 2dup import-keywords - import-rules + [ nip resolve-delegates ] + [ import-keywords ] + [ import-rules ] + 2tri ] with-variable ] with each ; ERROR: mutually-recursive-rulesets ruleset ; + : finalize-rule-set ( ruleset -- ) - dup finalized?>> { - { f [ - { - [ 1 >>finalized? drop ] - [ resolve-imports ] - [ resolve-delegates ] - [ t >>finalized? drop ] - } cleave - ] } - { t [ drop ] } - { 1 [ mutually-recursive-rulesets ] } - } case ; + dup finalized?>> [ drop ] [ + t >>finalized? + [ resolve-imports ] + [ resolve-delegates ] + bi + ] if ; : finalize-mode ( rulesets -- ) rule-sets [ diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor index cd11ba50d0..c0b8a1b560 100644 --- a/basis/xmode/code2html/code2html-tests.factor +++ b/basis/xmode/code2html/code2html-tests.factor @@ -1,7 +1,7 @@ IN: xmode.code2html.tests USING: xmode.code2html xmode.catalog tools.test multiline splitting memoize -kernel ; +kernel io.streams.string xml.writer ; [ ] [ \ (load-mode) reset-memoized ] unit-test @@ -9,4 +9,11 @@ kernel ; <"