diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 59daa3ab53..46b1989357 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -67,10 +67,12 @@ IN: bootstrap.stage2 [ boot do-init-hooks - [ parse-command-line ] try - [ run-user-init ] try - [ "run" get run ] try - stdio get [ stream-flush ] when* + [ + parse-command-line + run-user-init + "run" get run + stdio get [ stream-flush ] when* + ] [ print-error 1 exit ] recover ] set-boot-quot : count-words all-words swap subset length pprint ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 130844e797..147714692d 100644 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -5,7 +5,7 @@ classes.predicate ; IN: classes ARTICLE: "builtin-classes" "Built-in classes" -"Every object is an instance of to exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." +"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." $nl "Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:" { $subsection type } diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 03e0816c19..de661fad92 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -1,7 +1,8 @@ ! Copyright 2007 Ryan Murphy ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math tools.test heaps heaps.private ; +USING: arrays kernel math namespaces tools.test +heaps heaps.private ; IN: temporary [ heap-pop ] unit-test-fails @@ -33,3 +34,16 @@ IN: temporary [ 0 ] [ heap-length ] unit-test [ 1 ] [ t 1 pick heap-push heap-length ] unit-test + +[ { { 1 2 } { 3 4 } { 5 6 } } ] [ + T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } + [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make +] unit-test +[ { { 1 2 } } ] [ + T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } + [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make +] unit-test +[ { } ] [ + T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } + [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make +] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 73a37660f6..f01b436e90 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -3,6 +3,19 @@ USING: kernel math sequences arrays assocs ; IN: heaps +MIXIN: priority-queue + +GENERIC: heap-push ( value key heap -- ) +GENERIC: heap-push-all ( assoc heap -- ) +GENERIC: heap-peek ( heap -- value key ) +GENERIC: heap-pop* ( heap -- ) +GENERIC: heap-pop ( heap -- value key ) +GENERIC: heap-delete ( key heap -- ) +GENERIC: heap-delete* ( key heap -- old ? ) +GENERIC: heap-empty? ( heap -- ? ) +GENERIC: heap-length ( heap -- n ) +GENERIC# heap-pop-while 2 ( heap pred quot -- ) + ( -- max-heap ) max-heap ; +INSTANCE: min-heap priority-queue +INSTANCE: max-heap priority-queue + -: heap-push ( value key heap -- ) +M: priority-queue heap-push ( value key heap -- ) >r swap 2array r> [ heap-data push ] keep [ heap-data ] keep up-heap ; -: heap-push-all ( assoc heap -- ) +M: priority-queue heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; -: heap-peek ( heap -- value key ) +M: priority-queue heap-peek ( heap -- value key ) heap-data first first2 swap ; -: heap-pop* ( heap -- ) +M: priority-queue heap-pop* ( heap -- ) dup heap-data length 1 > [ [ heap-data pop ] keep [ heap-data set-first ] keep @@ -106,8 +122,19 @@ PRIVATE> heap-data pop* ] if ; -: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; +M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; -: heap-empty? ( heap -- ? ) heap-data empty? ; +M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ; -: heap-length ( heap -- n ) heap-data length ; +M: priority-queue heap-length ( heap -- n ) heap-data length ; + +: (heap-pop-while) ( heap pred quot -- ) + pick heap-empty? [ + 3drop + ] [ + [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep + roll [ (heap-pop-while) ] [ 3drop ] if + ] if ; + +M: priority-queue heap-pop-while ( heap pred quot -- ) + [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 04db98c9b2..d8c8f5fbba 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -9,7 +9,6 @@ ARTICLE: "slots" "Slots" $nl { $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data." $nl -"The " "The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance." { $subsection slot-spec } "Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not." diff --git a/extra/assoc-heaps/assoc-heaps-tests.factor b/extra/assoc-heaps/assoc-heaps-tests.factor new file mode 100644 index 0000000000..656e7fc15c --- /dev/null +++ b/extra/assoc-heaps/assoc-heaps-tests.factor @@ -0,0 +1,46 @@ +USING: assocs assoc-heaps heaps heaps.private kernel tools.test ; +IN: temporary + +[ +T{ + assoc-heap + f + H{ { 2 1 } } + T{ min-heap T{ heap f V{ { 1 2 } } } } +} +] [ H{ } clone 1 2 pick heap-push ] unit-test + +[ +T{ + assoc-heap + f + H{ { 1 0 } { 2 1 } } + T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } } +} +] [ H{ } clone 1 2 pick heap-push 0 1 pick heap-push ] unit-test + +[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ] +[ + H{ } clone + 1 2 pick heap-push 0 1 pick heap-push + dup heap-pop 2drop dup heap-pop 2drop +] unit-test + + +[ 0 1 ] [ +T{ + assoc-heap + f + H{ { 1 0 } { 2 1 } } + T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } } +} heap-pop +] unit-test + +[ 1 2 ] [ +T{ + assoc-heap + f + H{ { 1 0 } { 2 1 } } + T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } } +} heap-pop +] unit-test diff --git a/extra/assoc-heaps/assoc-heaps.factor b/extra/assoc-heaps/assoc-heaps.factor new file mode 100644 index 0000000000..0c44950923 --- /dev/null +++ b/extra/assoc-heaps/assoc-heaps.factor @@ -0,0 +1,48 @@ +USING: assocs heaps kernel sequences ; +IN: assoc-heaps + +TUPLE: assoc-heap assoc heap ; + +INSTANCE: assoc-heap assoc +INSTANCE: assoc-heap priority-queue + +C: assoc-heap + +: ( assoc -- obj ) ; +: ( assoc -- obj ) ; + +M: assoc-heap at* ( key assoc-heap -- value ? ) + assoc-heap-assoc at* ; + +M: assoc-heap assoc-size ( assoc-heap -- n ) + assoc-heap-assoc assoc-size ; + +TUPLE: assoc-heap-key-exists ; + +: check-key-exists ( key assoc-heap -- ) + assoc-heap-assoc key? + [ \ assoc-heap-key-exists construct-empty throw ] when ; + +M: assoc-heap set-at ( value key assoc-heap -- ) + [ check-key-exists ] 2keep + [ assoc-heap-assoc set-at ] 3keep + assoc-heap-heap swapd heap-push ; + +M: assoc-heap heap-empty? ( assoc-heap -- ? ) + assoc-heap-assoc assoc-empty? ; + +M: assoc-heap heap-length ( assoc-heap -- n ) + assoc-heap-assoc assoc-size ; + +M: assoc-heap heap-peek ( assoc-heap -- value key ) + assoc-heap-heap heap-peek ; + +M: assoc-heap heap-push ( value key assoc-heap -- ) + set-at ; + +M: assoc-heap heap-push-all ( assoc assoc-heap -- ) + swap [ rot set-at ] curry* each ; + +M: assoc-heap heap-pop ( assoc-heap -- value key ) + dup assoc-heap-heap heap-pop swap + rot dupd assoc-heap-assoc delete-at ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 047887bcc8..e4d66d4725 100644 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -72,9 +72,9 @@ MACRO: nfirst ( n -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; +: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline -: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; +: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline : all-unique? ( seq -- ? ) [ prune ] keep [ length ] 2apply = ; diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 01ef33b922..dd9a77aa21 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,4 +1,5 @@ USING: delegate kernel arrays tools.test ; +IN: temporary TUPLE: hello this that ; C: hello diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 5614296305..8ff5e2110b 100644 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -42,11 +42,13 @@ M: tuple-class group-words PROTOCOL: sequence-protocol clone clone-like like new new-resizable nth nth-unsafe - set-nth set-nth-unsafe length immutable set-length lengthen ; + set-nth set-nth-unsafe length set-length lengthen ; PROTOCOL: assoc-protocol - at* assoc-size >alist assoc-find set-at + at* assoc-size >alist set-at assoc-clone-like delete-at clear-assoc new-assoc assoc-like ; + ! assoc-find excluded because GENERIC# 1 + ! everything should work, just slower (with >alist) PROTOCOL: stream-protocol stream-close stream-read1 stream-read stream-read-until diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 9f39b33dc6..1968a9e5f4 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -8,16 +8,16 @@ IN: faq : find-after ( seq quot -- elem after ) over >r find r> rot 1+ tail ; inline -: tag-named? ( tag name -- ? ) - assure-name swap (get-tag) ; +: tag-named*? ( tag name -- ? ) + assure-name swap tag-named? ; ! Questions TUPLE: q/a question answer ; C: q/a : li>q/a ( li -- q/a ) - [ "br" tag-named? not ] subset - [ "strong" tag-named? ] find-after + [ "br" tag-named*? not ] subset + [ "strong" tag-named*? ] find-after >r tag-children r> ; : q/a>li ( q/a -- li ) diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index 1c70c0c325..ccb004581a 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -1,54 +1,54 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test parser-combinators lazy-lists fjsc ; +USING: kernel tools.test peg fjsc ; IN: temporary -{ T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "55 2abc1 100" 'expression' parse-1 +{ T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ + "55 2abc1 100" 'expression' parse parse-result-ast ] unit-test -{ T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "[ 55 2abc1 100 ]" 'quotation' parse-1 +{ T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ + "[ 55 2abc1 100 ]" 'quotation' parse parse-result-ast ] unit-test -{ T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "{ 55 2abc1 100 }" 'array' parse-1 +{ T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ + "{ 55 2abc1 100 }" 'array' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { } { "d" "e" "f" } } } [ - "( -- d e f )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [ + "( -- d e f )" 'stack-effect' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [ - "( a b c -- d e f )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [ + "( a b c -- d e f )" 'stack-effect' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { "a" "b" "c" } { } } } [ - "( a b c -- )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [ + "( a b c -- )" 'stack-effect' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { } { } } } [ - "( -- )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ } V{ } } } [ + "( -- )" 'stack-effect' parse parse-result-ast ] unit-test -{ } [ - ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop +{ f } [ + ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse not ] unit-test -{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [ - "\"abcd\"" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [ + "\"abcd\"" 'statement' parse parse-result-ast ] unit-test -{ T{ ast-expression f { T{ ast-use f "foo" } } } } [ - "USE: foo" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-use f "foo" } } } } [ + "USE: foo" 'statement' parse parse-result-ast ] unit-test -{ T{ ast-expression f { T{ ast-in f "foo" } } } } [ - "IN: foo" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-in f "foo" } } } } [ + "IN: foo" 'statement' parse parse-result-ast ] unit-test -{ T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [ - "USING: foo bar ;" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [ + "USING: foo bar ;" 'statement' parse parse-result-ast ] unit-test diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 22031afb25..e469b61617 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -1,50 +1,38 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel lazy-lists parser-combinators parser-combinators.simple - strings promises sequences math math.parser namespaces words - quotations arrays hashtables io io.streams.string assocs ; +USING: kernel peg strings promises sequences math math.parser + namespaces words quotations arrays hashtables io + io.streams.string assocs memoize ; IN: fjsc TUPLE: ast-number value ; -C: ast-number - TUPLE: ast-identifier value vocab ; -C: ast-identifier - TUPLE: ast-string value ; -C: ast-string - TUPLE: ast-quotation values ; -C: ast-quotation - TUPLE: ast-array elements ; -C: ast-array - TUPLE: ast-define name stack-effect expression ; -C: ast-define - TUPLE: ast-expression values ; -C: ast-expression - TUPLE: ast-word value vocab ; -C: ast-word - TUPLE: ast-comment ; -C: ast-comment - TUPLE: ast-stack-effect in out ; -C: ast-stack-effect - TUPLE: ast-use name ; -C: ast-use - TUPLE: ast-using names ; -C: ast-using - TUPLE: ast-in name ; -C: ast-in - TUPLE: ast-hashtable elements ; + +C: ast-number +C: ast-identifier +C: ast-string +C: ast-quotation +C: ast-array +C: ast-define +C: ast-expression +C: ast-word +C: ast-comment +C: ast-stack-effect +C: ast-use +C: ast-using +C: ast-in C: ast-hashtable : identifier-middle? ( ch -- bool ) @@ -56,7 +44,7 @@ C: ast-hashtable digit? not and and and and and ; -LAZY: 'identifier-ends' ( -- parser ) +MEMO: 'identifier-ends' ( -- parser ) [ [ blank? not ] keep [ CHAR: " = not ] keep @@ -65,99 +53,137 @@ LAZY: 'identifier-ends' ( -- parser ) [ letter? not ] keep identifier-middle? not and and and and and - ] satisfy ; + ] satisfy repeat0 ; -LAZY: 'identifier-middle' ( -- parser ) - [ identifier-middle? ] satisfy ; +MEMO: 'identifier-middle' ( -- parser ) + [ identifier-middle? ] satisfy repeat1 ; -LAZY: 'identifier' ( -- parser ) - 'identifier-ends' - 'identifier-middle' <&> - 'identifier-ends' <:&> - [ concat >string f ] <@ ; +MEMO: 'identifier' ( -- parser ) + [ + 'identifier-ends' , + 'identifier-middle' , + 'identifier-ends' , + ] { } make seq [ + concat >string f + ] action ; DEFER: 'expression' -LAZY: 'effect-name' ( -- parser ) +MEMO: 'effect-name' ( -- parser ) [ [ blank? not ] keep + [ CHAR: ) = not ] keep CHAR: - = not - and - ] satisfy [ >string ] <@ ; + and and + ] satisfy repeat1 [ >string ] action ; -LAZY: 'stack-effect' ( -- parser ) - "(" token sp - 'effect-name' sp <*> &> - "--" token sp <& - 'effect-name' sp <*> <&> - ")" token sp <& [ first2 ] <@ ; +MEMO: 'stack-effect' ( -- parser ) + [ + "(" token hide , + 'effect-name' sp repeat0 , + "--" token sp hide , + 'effect-name' sp repeat0 , + ")" token sp hide , + ] { } make seq [ + first2 + ] action ; -LAZY: 'define' ( -- parser ) - ":" token sp - 'identifier' sp [ ast-identifier-value ] <@ &> - 'stack-effect' sp <&> - 'expression' <:&> - ";" token sp <& [ first3 ] <@ ; +MEMO: 'define' ( -- parser ) + [ + ":" token sp hide , + 'identifier' sp [ ast-identifier-value ] action , + 'stack-effect' sp optional , + 'expression' , + ";" token sp hide , + ] { } make seq [ first3 ] action ; -LAZY: 'quotation' ( -- parser ) - "[" token sp - 'expression' [ ast-expression-values ] <@ &> - "]" token sp <& [ ] <@ ; +MEMO: 'quotation' ( -- parser ) + [ + "[" token sp hide , + 'expression' [ ast-expression-values ] action , + "]" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'array' ( -- parser ) - "{" token sp - 'expression' [ ast-expression-values ] <@ &> - "}" token sp <& [ ] <@ ; +MEMO: 'array' ( -- parser ) + [ + "{" token sp hide , + 'expression' [ ast-expression-values ] action , + "}" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'word' ( -- parser ) - "\\" token sp - 'identifier' sp &> [ ast-identifier-value f ] <@ ; +MEMO: 'word' ( -- parser ) + [ + "\\" token sp hide , + 'identifier' sp , + ] { } make seq [ first ast-identifier-value f ] action ; -LAZY: 'atom' ( -- parser ) - 'identifier' 'integer' [ ] <@ <|> 'string' [ ] <@ <|> ; +MEMO: 'atom' ( -- parser ) + [ + 'identifier' , + 'integer' [ ] action , + 'string' [ ] action , + ] { } make choice ; -LAZY: 'comment' ( -- parser ) - "#!" token sp - "!" token sp <|> [ - dup CHAR: \n = swap CHAR: \r = or not - ] satisfy <*> <&> [ drop ] <@ ; +MEMO: 'comment' ( -- parser ) + [ + [ + "#!" token sp , + "!" token sp , + ] { } make choice hide , + [ + dup CHAR: \n = swap CHAR: \r = or not + ] satisfy repeat0 , + ] { } make seq [ drop ] action ; -LAZY: 'USE:' ( -- parser ) - "USE:" token sp - 'identifier' sp &> [ ast-identifier-value ] <@ ; +MEMO: 'USE:' ( -- parser ) + [ + "USE:" token sp hide , + 'identifier' sp , + ] { } make seq [ first ast-identifier-value ] action ; -LAZY: 'IN:' ( -- parser ) - "IN:" token sp - 'identifier' sp &> [ ast-identifier-value ] <@ ; +MEMO: 'IN:' ( -- parser ) + [ + "IN:" token sp hide , + 'identifier' sp , + ] { } make seq [ first ast-identifier-value ] action ; -LAZY: 'USING:' ( -- parser ) - "USING:" token sp - 'identifier' sp [ ast-identifier-value ] <@ <+> &> - ";" token sp <& [ ] <@ ; +MEMO: 'USING:' ( -- parser ) + [ + "USING:" token sp hide , + 'identifier' sp [ ast-identifier-value ] action repeat1 , + ";" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'hashtable' ( -- parser ) - "H{" token sp - 'expression' [ ast-expression-values ] <@ &> - "}" token sp <& [ ] <@ ; +MEMO: 'hashtable' ( -- parser ) + [ + "H{" token sp hide , + 'expression' [ ast-expression-values ] action , + "}" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'parsing-word' ( -- parser ) - 'USE:' - 'USING:' <|> - 'IN:' <|> ; +MEMO: 'parsing-word' ( -- parser ) + [ + 'USE:' , + 'USING:' , + 'IN:' , + ] { } make choice ; -LAZY: 'expression' ( -- parser ) - 'comment' - 'parsing-word' sp <|> - 'quotation' sp <|> - 'define' sp <|> - 'array' sp <|> - 'hashtable' sp <|> - 'word' sp <|> - 'atom' sp <|> - <*> [ ] <@ ; +MEMO: 'expression' ( -- parser ) + [ + [ + 'comment' , + 'parsing-word' sp , + 'quotation' sp , + 'define' sp , + 'array' sp , + 'hashtable' sp , + 'word' sp , + 'atom' sp , + ] { } make choice repeat0 [ ] action + ] delay ; -LAZY: 'statement' ( -- parser ) +MEMO: 'statement' ( -- parser ) 'expression' ; GENERIC: (compile) ( ast -- ) @@ -328,7 +354,7 @@ M: wrapper (parse-factor-quotation) ( object -- ast ) GENERIC: fjsc-parse ( object -- ast ) M: string fjsc-parse ( object -- ast ) - 'expression' parse-1 ; + 'expression' parse parse-result-ast ; M: quotation fjsc-parse ( object -- ast ) [ @@ -345,11 +371,11 @@ M: quotation fjsc-parse ( object -- ast ) ] string-out ; : fjsc-compile* ( string -- string ) - 'statement' parse-1 fjsc-compile ; + 'statement' parse parse-result-ast fjsc-compile ; : fc* ( string -- string ) [ - 'statement' parse-1 ast-expression-values do-expressions + 'statement' parse parse-result-ast ast-expression-values do-expressions ] { } make [ write ] each ; diff --git a/extra/fjsc/resources/bootstrap.factor b/extra/fjsc/resources/bootstrap.factor index 13fef4aa57..db63f15f1c 100644 --- a/extra/fjsc/resources/bootstrap.factor +++ b/extra/fjsc/resources/bootstrap.factor @@ -3,10 +3,6 @@ USE: kernel-internals : bind ( ns quot -- ) swap >n call n> drop ; -: alert ( string -- ) - #! Display the string in an alert box - window { } "" "alert" { "string" } alien-invoke ; - "browser-dom" set-in : elements ( string -- result ) @@ -38,3 +34,6 @@ USE: kernel-internals drop "Click done!" alert ] callcc0 ; +: alert ( string -- ) + #! Display the string in an alert box + window { } "" "alert" { "string" } alien-invoke ; diff --git a/extra/fjsc/resources/bootstrap.js b/extra/fjsc/resources/bootstrap.js index 43d100ec73..032829c363 100644 --- a/extra/fjsc/resources/bootstrap.js +++ b/extra/fjsc/resources/bootstrap.js @@ -513,6 +513,12 @@ factor.add_word("alien", "set-alien-property", "primitive", function(next) { factor.call_next(next); }); +factor.add_word("alien", "uneval", "primitive", function(next) { + var stack = factor.cont.data_stack; + stack.push(uneval(stack.pop())); + factor.call_next(next); +}); + factor.add_word("words", "vocabs", "primitive", function(next) { var stack = factor.cont.data_stack; var result = []; diff --git a/extra/furnace/authors.txt b/extra/furnace/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/extra/furnace/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index 85fc6c8727..6a14d40cde 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -28,7 +28,7 @@ TUPLE: test-tuple m n ; [ H{ { "bar" "hello" } - } \ foo query>quot + } \ foo query>seq ] with-scope ] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 756fa13d1c..e745e28ad5 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -1,48 +1,39 @@ -! Copyright (C) 2006 Slava Pestov +! Copyright (C) 2006 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel vectors io assocs quotations splitting strings - words sequences namespaces arrays hashtables debugger - continuations tuples classes io.files - http http.server.templating http.basic-authentication - webapps.callback html html.elements - http.server.responders furnace.validator vocabs ; +USING: arrays assocs calendar debugger furnace.sessions furnace.validator +hashtables heaps html.elements http http.server.responders +http.server.templating io.files kernel math namespaces +quotations sequences splitting words strings vectors +webapps.callback ; +USING: continuations io prettyprint ; IN: furnace -SYMBOL: default-action +: code>quotation ( word/quot -- quot ) + dup word? [ 1quotation ] when ; +SYMBOL: default-action SYMBOL: template-path -: define-authenticated-action ( word params realm -- ) - pick swap "action-realm" set-word-prop +: render-template ( template -- ) + template-path get swap path+ + ".furnace" append resource-path + run-template-file ; + +: define-action ( word hash -- ) over t "action" set-word-prop "action-params" set-word-prop ; -: define-action ( word params -- ) - f define-authenticated-action ; +: define-form ( word1 word2 hash -- ) + dupd define-action + swap code>quotation "form-failed" set-word-prop ; -: define-redirect ( word quot -- ) - "action-redirect" set-word-prop ; +: default-values ( word hash -- ) + "default-values" set-word-prop ; -: responder-vocab ( name -- vocab ) - "webapps." swap append ; - -: lookup-action ( name webapp -- word ) - responder-vocab lookup dup [ - dup "action" word-prop [ drop f ] unless - ] when ; - -: truncate-url ( url -- action-name ) - CHAR: / over index [ head ] when* ; - -: current-action ( url -- word/f ) - dup empty? [ drop default-action get ] when - truncate-url "responder" get lookup-action ; - -PREDICATE: word action "action" word-prop ; - -: quot>query ( seq action -- hash ) - >r >array r> "action-params" word-prop - [ first swap 2array ] 2map >hashtable ; +SYMBOL: request-params +SYMBOL: current-action +SYMBOL: validators-errored +SYMBOL: validation-errors : action-link ( query action -- url ) [ @@ -52,6 +43,38 @@ PREDICATE: word action "action" word-prop ; word-name % ] "" make swap build-url ; +: action-param ( hash paramsepc -- obj error/f ) + unclip rot at swap >quotation apply-validators ; + +: query>seq ( hash word -- seq ) + "action-params" word-prop [ + dup first -rot + action-param [ + t validators-errored >session + rot validation-errors session> set-at + ] [ + nip + ] if* + ] curry* map ; + +: expire-sessions ( -- ) + sessions get-global + [ nip session-last-seen 20 minutes ago <=> 0 > ] + [ 2drop ] heap-pop-while ; + +: lookup-session ( hash -- session ) + "furnace-session-id" over at sessions get-global at [ + nip + ] [ + new-session rot "furnace-session-id" swap set-at + ] if* ; + +: quot>query ( seq action -- hash ) + >r >array r> "action-params" word-prop + [ first swap 2array ] 2map >hashtable ; + +PREDICATE: word action "action" word-prop ; + : action-call? ( quot -- ? ) >vector dup pop action? >r [ word? not ] all? r> and ; @@ -64,62 +87,94 @@ PREDICATE: word action "action" word-prop ; t register-html-callback ] if ; -: render-link ( quot name -- ) - write ; +: replace-variables ( quot -- quot ) + [ dup string? [ request-params session> at ] when ] map ; -: action-param ( params paramspec -- obj error/f ) - unclip rot at swap >quotation apply-validators ; +: furnace-session-id ( -- hash ) + "furnace-session-id" request-params session> at + "furnace-session-id" associate ; -: query>quot ( params action -- seq ) - "action-params" word-prop [ action-param drop ] curry* map ; +: redirect-to-action ( -- ) + current-action session> + "form-failed" word-prop replace-variables + quot-link furnace-session-id build-url permanent-redirect ; -SYMBOL: request-params +: if-form-page ( if then -- ) + current-action session> "form-failed" word-prop -rot if ; -: perform-redirect ( action -- ) - "action-redirect" word-prop - [ dup string? [ request-params get at ] when ] map - [ quot-link permanent-redirect ] when* ; +: do-action + current-action session> [ query>seq ] keep add >quotation call ; -: (call-action) ( params action -- ) - over request-params set - [ query>quot ] keep [ add >quotation call ] keep - perform-redirect ; +: process-form ( -- ) + H{ } clone validation-errors >session + request-params session> current-action session> query>seq + validators-errored session> [ + drop redirect-to-action + ] [ + current-action session> add >quotation call + ] if ; -: call-action ( params action -- ) - dup "action-realm" word-prop [ - [ (call-action) ] with-basic-authentication - ] [ (call-action) ] if* ; +: page-submitted ( -- ) + [ process-form ] [ request-params session> do-action ] if-form-page ; -: service-request ( params url -- ) - current-action [ +: action-first-time ( -- ) + request-params session> current-action session> + [ "default-values" word-prop swap union request-params >session ] keep + request-params session> do-action ; + +: page-not-submitted ( -- ) + [ redirect-to-action ] [ action-first-time ] if-form-page ; + +: setup-call-action ( hash word -- ) + over lookup-session session set + current-action >session + request-params session> swap union + request-params >session + f validators-errored >session ; + +: call-action ( hash word -- ) + setup-call-action + "furnace-form-submitted" request-params session> at + [ page-submitted ] [ page-not-submitted ] if ; + +: responder-vocab ( str -- newstr ) + "webapps." swap append ; + +: lookup-action ( str webapp -- word ) + responder-vocab lookup dup [ + dup "action" word-prop [ drop f ] unless + ] when ; + +: truncate-url ( str -- newstr ) + CHAR: / over index [ head ] when* ; + +: parse-action ( str -- word/f ) + dup empty? [ drop default-action get ] when + truncate-url "responder" get lookup-action ; + +: service-request ( hash str -- ) + parse-action [ [ call-action ] [
 print-error 
] recover ] [ "404 no such action: " "argument" get append httpd-error ] if* ; -: service-get ( url -- ) "query" get swap service-request ; +: service-get + "query" get swap service-request ; -: service-post ( url -- ) "response" get swap service-request ; +: service-post + "response" get swap service-request ; -: send-resource ( name -- ) - template-path get swap path+ resource-path - stdio get stream-copy ; - -: render-template ( template -- ) - template-path get swap path+ - ".furnace" append resource-path - run-template-file ; - -: web-app ( name default path -- ) +: web-app ( name defaul path -- ) [ template-path set default-action set "responder" set [ service-get ] "get" set [ service-post ] "post" set - ! [ service-head ] "head" set ] make-responder ; +USING: classes html tuples vocabs ; : explode-tuple ( tuple -- ) dup tuple-slots swap class "slot-names" word-prop [ set ] 2each ; @@ -138,3 +193,24 @@ SYMBOL: model vocab-link browser-link-href =href a> "Browse source" write ; + +: send-resource ( name -- ) + template-path get swap path+ resource-path + stdio get stream-copy ; + +: render-link ( quot name -- ) + write ; + +: session-var ( str -- newstr ) + request-params session> at ; + +: render ( str -- ) + request-params session> at [ write ] when* ; + +: render-error ( str error-str -- ) + swap validation-errors session> at validation-error? [ + write + ] [ + drop + ] if ; + diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor new file mode 100644 index 0000000000..523598efe7 --- /dev/null +++ b/extra/furnace/sessions/sessions.factor @@ -0,0 +1,40 @@ +USING: assoc-heaps assocs calendar crypto.sha2 heaps +init kernel math.parser namespaces random ; +IN: furnace.sessions + +SYMBOL: sessions + +[ + H{ } clone + sessions set-global +] "furnace.sessions" add-init-hook + +: new-session-id ( -- str ) + 4 big-random number>string string>sha-256-string + dup sessions get-global at [ drop new-session-id ] when ; + +TUPLE: session created last-seen user-agent namespace ; + +M: session <=> ( session1 session2 -- n ) + [ session-last-seen ] 2apply <=> ; + +: ( -- obj ) + now dup H{ } clone + [ set-session-created set-session-last-seen set-session-namespace ] + \ session construct ; + +: new-session ( -- obj id ) + new-session-id [ sessions get-global set-at ] 2keep ; + +: get-session ( id -- obj/f ) + sessions get-global at* [ "no session found 1" throw ] unless ; + +! Delete from the assoc only, the heap will timeout +: destroy-session ( id -- ) + sessions get-global assoc-heap-assoc delete-at ; + +: session> ( str -- obj ) + session get session-namespace at ; + +: >session ( value key -- ) + session get session-namespace set-at ; diff --git a/extra/http/http.factor b/extra/http/http.factor index f6ea3d699f..6ecb3c5a71 100644 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -60,11 +60,18 @@ IN: http : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make ; -: build-url ( path query-params -- str ) +: hash>query ( hash -- str ) + [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map + "&" join ; + +: build-url ( str query-params -- newstr ) [ - swap % dup assoc-empty? [ - "?" % dup - [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map - "&" join % - ] unless drop + over % + dup assoc-empty? [ + 2drop + ] [ + CHAR: ? rot member? "&" "?" ? % + hash>query % + ] if ] "" make ; + diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index d76e11287c..cd587799c2 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -76,6 +76,7 @@ DEFER: <% delimiter : run-template-file ( filename -- ) [ [ + "quiet" on file-vocabs parser-notes off templating-vocab use+ diff --git a/extra/lazy-lists/authors.txt b/extra/lazy-lists/authors.txt index 6d23bcac92..f6ba9ba80d 100644 --- a/extra/lazy-lists/authors.txt +++ b/extra/lazy-lists/authors.txt @@ -1,2 +1,3 @@ Chris Double +Samuel Tardieu Matthew Willis diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index e8acb397df..b66eb6367f 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -114,6 +114,16 @@ HELP: lsubset { $description "Perform a similar functionality to that of the " { $link subset } " 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." } { $see-also leach lmap lmap-with ltake lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +HELP: lwhile +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } } +{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } +{ $see-also luntil } ; + +HELP: luntil +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } } +{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } +{ $see-also lwhile } ; + HELP: list>vector { $values { "list" "a cons object" } { "vector" "the list converted to a vector" } } { $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." } diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 2e3dc9154a..1fb7a18cba 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -100,11 +100,7 @@ M: lazy-cons list? ( object -- bool ) dup car swap cdr ; : leach ( list quot -- ) - swap dup nil? [ - 2drop - ] [ - uncons swap pick call swap leach - ] if ; + swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline TUPLE: memoized-cons original car cdr nil? ; @@ -210,6 +206,48 @@ M: lazy-take nil? ( lazy-take -- bool ) M: lazy-take list? ( object -- bool ) drop t ; +TUPLE: lazy-until cons quot ; + +C: lazy-until + +: luntil ( list quot -- result ) + ; + +M: lazy-until car ( lazy-until -- car ) + lazy-until-cons car ; + +M: lazy-until cdr ( lazy-until -- cdr ) + [ lazy-until-cons uncons ] keep lazy-until-quot + rot over call [ 2drop nil ] [ luntil ] if ; + +M: lazy-until nil? ( lazy-until -- bool ) + lazy-until-cons nil? ; + +M: lazy-until list? ( lazy-until -- bool ) + drop t ; + +TUPLE: lazy-while cons quot ; + +C: lazy-while + +: lwhile ( list quot -- result ) + +; + +M: lazy-while car ( lazy-while -- car ) + lazy-while-cons car ; + +M: lazy-while cdr ( lazy-while -- cdr ) + dup lazy-while-cons cdr dup nil? + [ 2drop nil ] [ swap lazy-while-quot lwhile ] if ; + +M: lazy-while nil? ( lazy-while -- bool ) + dup lazy-while-cons nil? + [ nip ] [ [ car ] keep lazy-while-quot call not ] if* ; + +M: lazy-while list? ( lazy-while -- bool ) + drop t ; + TUPLE: lazy-subset cons quot ; C: lazy-subset diff --git a/extra/math/erato/authors.txt b/extra/math/erato/authors.txt new file mode 100644 index 0000000000..f3b0233f74 --- /dev/null +++ b/extra/math/erato/authors.txt @@ -0,0 +1 @@ +Samuel Tardieu diff --git a/extra/math/erato/erato-docs.factor b/extra/math/erato/erato-docs.factor new file mode 100644 index 0000000000..6e84c84057 --- /dev/null +++ b/extra/math/erato/erato-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax ; +IN: math.erato + +HELP: lerato +{ $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } } +{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive). Lazy lists are described in " { $link "lazy-lists" } "." } ; diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor new file mode 100644 index 0000000000..6e961b979c --- /dev/null +++ b/extra/math/erato/erato-tests.factor @@ -0,0 +1,6 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: lazy-lists math.erato tools.test ; +IN: temporary + +[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor new file mode 100644 index 0000000000..4993f39e44 --- /dev/null +++ b/extra/math/erato/erato.factor @@ -0,0 +1,38 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: bit-arrays kernel lazy-lists math math.functions math.ranges sequences ; +IN: math.erato + +r ind r> erato-bits nth ; inline + +: indices ( n erato -- range ) + erato-limit ind over 3 * ind swap rot ; + +: mark-multiples ( n erato -- ) + over sq over erato-limit <= + [ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ; + +: ( n -- erato ) + dup ind 1+ 1 over set-bits erato construct-boa ; + +: next-prime ( erato -- prime/f ) + [ erato-latest 2 + ] keep [ set-erato-latest ] 2keep + 2dup erato-limit <= + [ + 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if + ] [ + 2drop f + ] if ; + +PRIVATE> + +: lerato ( n -- lazy-list ) + 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile ; diff --git a/extra/math/erato/summary.txt b/extra/math/erato/summary.txt new file mode 100644 index 0000000000..e8982fa3e0 --- /dev/null +++ b/extra/math/erato/summary.txt @@ -0,0 +1 @@ +Sieve of Eratosthene diff --git a/extra/math/text/authors.txt b/extra/math/text/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/math/text/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/math/text/summary.txt b/extra/math/text/summary.txt new file mode 100644 index 0000000000..96b2f4f151 --- /dev/null +++ b/extra/math/text/summary.txt @@ -0,0 +1 @@ +Convert integers to text diff --git a/extra/math/text/text-docs.factor b/extra/math/text/text-docs.factor new file mode 100644 index 0000000000..6a896b1a82 --- /dev/null +++ b/extra/math/text/text-docs.factor @@ -0,0 +1,7 @@ +USING: help.markup help.syntax math strings ; +IN: math.text + +HELP: number>text +{ $values { "n" integer } { "str" string } } +{ $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." } +{ $examples { $example "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ; diff --git a/extra/math/text/text-tests.factor b/extra/math/text/text-tests.factor new file mode 100644 index 0000000000..09c8a0461b --- /dev/null +++ b/extra/math/text/text-tests.factor @@ -0,0 +1,15 @@ +USING: math.functions math.text tools.test ; +IN: temporary + +[ "Zero" ] [ 0 number>text ] unit-test +[ "Twenty-One" ] [ 21 number>text ] unit-test +[ "One Hundred" ] [ 100 number>text ] unit-test +[ "One Hundred and One" ] [ 101 number>text ] unit-test +[ "One Thousand and One" ] [ 1001 number>text ] unit-test +[ "One Thousand, One Hundred and One" ] [ 1101 number>text ] unit-test +[ "One Million, One Thousand and One" ] [ 1001001 number>text ] unit-test +[ "One Million, One Thousand, One Hundred and One" ] [ 1001101 number>text ] unit-test +[ "One Million, One Hundred and Eleven Thousand, One Hundred and Eleven" ] [ 1111111 number>text ] unit-test +[ "One Duotrigintillion" ] [ 10 99 ^ number>text ] unit-test + +[ "Negative One Hundred and Twenty-Three" ] [ -123 number>text ] unit-test diff --git a/extra/math/text/text.factor b/extra/math/text/text.factor new file mode 100644 index 0000000000..7298fd3c15 --- /dev/null +++ b/extra/math/text/text.factor @@ -0,0 +1,103 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.functions math.parser namespaces + sequences splitting sequences.lib ; +IN: math.text + + ] + } && and-needed? set drop ; + +: negative-text ( n -- str ) + 0 < "Negative " "" ? ; + +: 3digit-groups ( n -- seq ) + number>string 3 + [ reverse 10 string>integer ] map ; + +: hundreds-place ( n -- str ) + 100 /mod swap dup zero? [ + 2drop "" + ] [ + small-numbers " Hundred" append + swap zero? [ " and " append ] unless + ] if ; + +: tens-place ( n -- str ) + 100 mod dup 20 >= [ + 10 /mod >r tens r> + dup zero? [ drop ] [ "-" swap small-numbers 3append ] if + ] [ + dup zero? [ drop "" ] [ small-numbers ] if + ] if ; + +: 3digits>text ( n -- str ) + dup hundreds-place swap tens-place append ; + +: text-with-scale ( index seq -- str ) + dupd nth 3digits>text swap + scale-numbers dup empty? [ + drop + ] [ + " " swap 3append + ] if ; + +: append-with-conjunction ( str1 str2 -- newstr ) + over length zero? [ + nip + ] [ + and-needed? get " and " ", " ? rot 3append + and-needed? off + ] if ; + +: (recombine) ( str index seq -- newstr seq ) + 2dup nth zero? [ + nip + ] [ + [ text-with-scale ] keep + -rot append-with-conjunction swap + ] if ; + +: recombine ( seq -- str ) + dup singleton? [ + first 3digits>text + ] [ + dup set-conjunction "" swap + dup length [ swap (recombine) ] each drop + ] if ; + +: (number>text) ( n -- str ) + dup negative-text swap abs 3digit-groups recombine append ; + +PRIVATE> + +: number>text ( n -- str ) + dup zero? [ + small-numbers + ] [ + [ (number>text) ] with-scope + ] if ; + diff --git a/extra/parser-combinators/replace/replace-docs.factor b/extra/parser-combinators/replace/replace-docs.factor deleted file mode 100644 index fe73f5d3c2..0000000000 --- a/extra/parser-combinators/replace/replace-docs.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup parser-combinators -parser-combinators.replace ; - -HELP: tree-write -{ $values - { "object" "an object" } } -{ $description - "Write the object to the standard output stream, unless " - "it is an array, in which case recurse through the array " - "writing each object to the stream." } -{ $example "USE: parser-combinators" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; - -HELP: search -{ $values - { "string" "a string" } - { "parser" "a parser combinator based parser" } - { "seq" "a sequence" } -} -{ $description - "Returns a sequence containing the parse results of all substrings " - "from the input string that successfully parse using the " - "parser." -} - -{ $example "USE: parser-combinators" "\"one 123 two 456\" 'integer' search ." "{ 123 456 }" } -{ $example "USE: parser-combinators" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' <|> search ." "{ 123 \"hello\" 456 }" } -{ $see-also search* replace replace* } ; - -HELP: search* -{ $values - { "string" "a string" } - { "parsers" "a sequence of parser combinator based parsers" } - { "seq" "a sequence" } -} -{ $description - "Returns a sequence containing the parse results of all substrings " - "from the input string that successfully parse using any of the " - "parsers in the 'parsers' sequence." -} - -{ $example "USE: parser-combinators" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array search* ." "{ 123 \"hello\" 456 }" } -{ $see-also search replace replace* } ; - -HELP: replace -{ $values - { "string" "a string" } - { "parser" "a parser combinator based parser" } - { "result" "a string" } -} -{ $description - "Returns a copy of the original string but with all substrings that " - "successfully parse with the given parser replaced with " - "the result of that parser." -} -{ $example "USING: parser-combinators math.parser ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] <@ replace ." "\"one 246 two 912\"" } -{ $example "USE: parser-combinators" "\"hello *world* from *factor*\" 'bold' [ \"\" swap \"\" 3append ] <@ replace ." "\"hello world from factor\"" } -{ $example "USE: parser-combinators" "\"hello *world* from _factor_\"\n 'bold' [ \"\" swap \"\" 3append ] <@\n 'italic' [ \"\" swap \"\" 3append ] <@ <|>\n replace ." "\"hello world from factor\"" } -{ $see-also search search* replace* } ; - -HELP: replace* -{ $values - { "string" "a string" } - { "parsers" "a sequence of parser combinator based parsers" } - { "result" "a string" } -} -{ $description - "Returns a copy of the original string but with all substrings that " - "successfully parse with the given parsers replaced with " - "the result of that parser. Each parser is done in sequence so that " - "the parse results of the first parser can be replaced by later parsers." -} -{ $example "USE: parser-combinators" "\"*hello _world_*\"\n 'bold' [ \"\" swap \"\" 3append ] <@\n 'italic' [ \"\" swap \"\" 3append ] <@ 2array\n replace* ." "\"hello world\"" } -{ $see-also search search* replace* } ; - diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index c5b84d86c6..3b59068dd6 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel strings math sequences lazy-lists words -math.parser promises ; -IN: parser-combinators +math.parser promises parser-combinators ; +IN: parser-combinators.simple : 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] <@ ; diff --git a/extra/peg/ebnf/tags.txt b/extra/peg/ebnf/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/ebnf/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7fa1fb90e5..411a47b9bd 100644 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib memoize ; + vectors arrays combinators.lib memoize math.parser ; IN: peg TUPLE: parse-result remaining ast ; @@ -265,3 +265,16 @@ MEMO: delay ( parser -- parser ) MEMO: list-of ( items separator -- parser ) hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ; + +MEMO: 'digit' ( -- parser ) + [ digit? ] satisfy [ digit> ] action ; + +MEMO: 'integer' ( -- parser ) + 'digit' repeat1 [ 10 swap digits>integer ] action ; + +MEMO: 'string' ( -- parser ) + [ + [ CHAR: " = ] satisfy hide , + [ CHAR: " = not ] satisfy repeat0 , + [ CHAR: " = ] satisfy hide , + ] { } make seq [ first >string ] action ; diff --git a/extra/peg/pl0/tags.txt b/extra/peg/pl0/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/pl0/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/search/authors.txt b/extra/peg/search/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/peg/search/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/peg/search/search-docs.factor b/extra/peg/search/search-docs.factor new file mode 100644 index 0000000000..d6dc5e543b --- /dev/null +++ b/extra/peg/search/search-docs.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup peg peg.search ; + +HELP: tree-write +{ $values + { "object" "an object" } } +{ $description + "Write the object to the standard output stream, unless " + "it is an array, in which case recurse through the array " + "writing each object to the stream." } +{ $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; + +HELP: search +{ $values + { "string" "a string" } + { "parser" "a peg based parser" } + { "seq" "a sequence" } +} +{ $description + "Returns a sequence containing the parse results of all substrings " + "from the input string that successfully parse using the " + "parser." +} + +{ $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" } +{ $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" } +{ $see-also replace } ; + +HELP: replace +{ $values + { "string" "a string" } + { "parser" "a peg based parser" } + { "result" "a string" } +} +{ $description + "Returns a copy of the original string but with all substrings that " + "successfully parse with the given parser replaced with " + "the result of that parser." +} +{ $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" } +{ $see-also search } ; + diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor new file mode 100644 index 0000000000..53dcbd99f5 --- /dev/null +++ b/extra/peg/search/search-tests.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel math math.parser arrays tools.test peg peg.search ; +IN: temporary + +{ V{ 123 456 } } [ + "abc 123 def 456" 'integer' search +] unit-test + +{ V{ 123 "hello" 456 } } [ + "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search +] unit-test + +{ "abc 246 def 912" } [ + "abc 123 def 456" 'integer' [ 2 * number>string ] action replace +] unit-test + diff --git a/extra/parser-combinators/replace/replace.factor b/extra/peg/search/search.factor similarity index 54% rename from extra/parser-combinators/replace/replace.factor rename to extra/peg/search/search.factor index 541bde7ac7..86b6e114cf 100755 --- a/extra/parser-combinators/replace/replace.factor +++ b/extra/peg/search/search.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math io io.streams.string sequences strings -lazy-lists combinators parser-combinators.simple ; -IN: parser-combinators +combinators peg memoize arrays ; +IN: peg.search : tree-write ( object -- ) { @@ -12,26 +12,21 @@ IN: parser-combinators { [ t ] [ write ] } } cond ; +MEMO: any-char-parser ( -- parser ) + [ drop t ] satisfy ; + : search ( string parser -- seq ) - any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [ - drop { } + any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ + parse-result-ast [ ] subset ] [ - car parse-result-parsed [ ] subset + drop { } ] if ; -: search* ( string parsers -- seq ) - unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [ - drop { } - ] [ - car parse-result-parsed [ ] subset - ] if ; : (replace) ( string parser -- seq ) - any-char-parser <|> <*> parse-1 ; + any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ; : replace ( string parser -- result ) [ (replace) [ tree-write ] each ] string-out ; -: replace* ( string parsers -- result ) - swap [ replace ] reduce ; diff --git a/extra/peg/search/summary.txt b/extra/peg/search/summary.txt new file mode 100644 index 0000000000..ad27ade319 --- /dev/null +++ b/extra/peg/search/summary.txt @@ -0,0 +1 @@ +Search and replace using parsing expression grammars diff --git a/extra/peg/search/tags.txt b/extra/peg/search/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/search/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/tags.txt b/extra/peg/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor new file mode 100644 index 0000000000..7d77e86fec --- /dev/null +++ b/extra/project-euler/001/001.factor @@ -0,0 +1,38 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.ranges sequences ; +IN: project-euler.001 + +! http://projecteuler.net/index.php?section=problems&id=1 + +! DESCRIPTION +! ----------- + +! If we list all the natural numbers below 10 that are multiples of 3 or 5, we +! get 3, 5, 6 and 9. The sum of these multiples is 23. + +! Find the sum of all the multiples of 3 or 5 below 1000. + + +! SOLUTION +! -------- + +! Inclusion-exclusion principle + +: euler001 ( -- answer ) + 0 999 3 sum 0 999 5 sum + 0 999 15 sum - ; + +! [ euler001 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +: euler001a ( -- answer ) + 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] subset sum ; + +! [ euler001a ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler001 diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor new file mode 100644 index 0000000000..386d847e27 --- /dev/null +++ b/extra/project-euler/002/002.factor @@ -0,0 +1,34 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences ; +IN: project-euler.002 + +! http://projecteuler.net/index.php?section=problems&id=2 + +! DESCRIPTION +! ----------- + +! Each new term in the Fibonacci sequence is generated by adding the previous +! two terms. By starting with 1 and 2, the first 10 terms will be: + +! 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ... + +! Find the sum of all the even-valued terms in the sequence which do not exceed one million. + + +! SOLUTION +! -------- + +: last2 ( seq -- elt last ) + reverse first2 swap ; + +: fib-up-to ( n -- seq ) + { 0 } 1 [ pick dupd < ] [ add dup last2 + ] [ ] while drop nip ; + +: euler002 ( -- answer ) + 1000000 fib-up-to [ even? ] subset sum ; + +! [ euler002 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler002 diff --git a/extra/project-euler/003/003.factor b/extra/project-euler/003/003.factor new file mode 100644 index 0000000000..87db922e5f --- /dev/null +++ b/extra/project-euler/003/003.factor @@ -0,0 +1,28 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math project-euler.common sequences ; +IN: project-euler.003 + +! http://projecteuler.net/index.php?section=problems&id=3 + +! DESCRIPTION +! ----------- + +! The prime factors of 13195 are 5, 7, 13 and 29. + +! What is the largest prime factor of the number 317584931803? + + +! SOLUTION +! -------- + +: largest-prime-factor ( n -- factor ) + prime-factors supremum ; + +: euler003 ( -- answer ) + 317584931803 largest-prime-factor ; + +! [ euler003 ] 100 ave-time +! 404 ms run / 9 ms GC ave time - 100 trials + +MAIN: euler003 diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor new file mode 100644 index 0000000000..dadde25411 --- /dev/null +++ b/extra/project-euler/004/004.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib hashtables kernel math math.parser math.ranges + sequences sorting ; +IN: project-euler.004 + +! http://projecteuler.net/index.php?section=problems&id=4 + +! DESCRIPTION +! ----------- + +! A palindromic number reads the same both ways. The largest palindrome made +! from the product of two 2-digit numbers is 9009 = 91 * 99. + +! Find the largest palindrome made from the product of two 3-digit numbers. + + +! SOLUTION +! -------- + +: palindrome? ( n -- ? ) + number>string dup reverse = ; + +: cartesian-product ( seq1 seq2 -- seq1xseq2 ) + swap [ swap [ 2array ] map-with ] map-with concat ; + + + +: euler004 ( -- answer ) + 100 999 [a,b] [ 10 mod zero? not ] subset dup + cartesian-product [ product ] map prune max-palindrome ; + +! [ euler004 ] 100 ave-time +! 1608 ms run / 102 ms GC ave time - 100 trials + +MAIN: euler004 diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor new file mode 100644 index 0000000000..ff627e4a0e --- /dev/null +++ b/extra/project-euler/005/005.factor @@ -0,0 +1,26 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions sequences ; +IN: project-euler.005 + +! http://projecteuler.net/index.php?section=problems&id=5 + +! DESCRIPTION +! ----------- + +! 2520 is the smallest number that can be divided by each of the numbers from 1 +! to 10 without any remainder. + +! What is the smallest number that is evenly divisible by all of the numbers from 1 to 20? + + +! SOLUTION +! -------- + +: euler005 ( -- answer ) + 20 1 [ 1+ lcm ] reduce ; + +! [ euler005 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler005 diff --git a/extra/project-euler/006/006.factor b/extra/project-euler/006/006.factor new file mode 100644 index 0000000000..2f09912412 --- /dev/null +++ b/extra/project-euler/006/006.factor @@ -0,0 +1,39 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.ranges sequences ; +IN: project-euler.006 + +! http://projecteuler.net/index.php?section=problems&id=6 + +! DESCRIPTION +! ----------- + +! The sum of the squares of the first ten natural numbers is, +! 1² + 2² + ... + 10² = 385 + +! The square of the sum of the first ten natural numbers is, +! (1 + 2 + ... + 10)² = 55² = 3025 + +! Hence the difference between the sum of the squares of the first ten natural +! numbers and the square of the sum is 3025 385 = 2640. + +! Find the difference between the sum of the squares of the first one hundred +! natural numbers and the square of the sum. + + +! SOLUTION +! -------- + +: sum-of-squares ( seq -- n ) + 0 [ sq + ] reduce ; + +: square-of-sums ( seq -- n ) + 0 [ + ] reduce sq ; + +: euler006 ( -- answer ) + 1 100 [a,b] dup sum-of-squares swap square-of-sums - abs ; + +! [ euler006 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler006 diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor new file mode 100644 index 0000000000..0a9cd98865 --- /dev/null +++ b/extra/project-euler/007/007.factor @@ -0,0 +1,29 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.miller-rabin ; +IN: project-euler.007 + +! http://projecteuler.net/index.php?section=problems&id=7 + +! DESCRIPTION +! ----------- + +! By listing the first six prime numbers: 2, 3, 5, 7, 11, and 13, we can see +! that the 6th prime is 13. + +! What is the 10001st prime number? + + +! SOLUTION +! -------- + +: nth-prime ( n -- n ) + 2 swap 1- [ next-prime ] times ; + +: euler007 ( -- answer ) + 10001 nth-prime ; + +! [ euler007 ] time +! 19230 ms run / 487 ms GC time + +MAIN: euler007 diff --git a/extra/project-euler/008/008.factor b/extra/project-euler/008/008.factor new file mode 100644 index 0000000000..d76f344279 --- /dev/null +++ b/extra/project-euler/008/008.factor @@ -0,0 +1,72 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.parser project-euler.common sequences ; +IN: project-euler.008 + +! http://projecteuler.net/index.php?section=problems&id=8 + +! DESCRIPTION +! ----------- + +! Find the greatest product of five consecutive digits in the 1000-digit number. + +! 73167176531330624919225119674426574742355349194934 +! 96983520312774506326239578318016984801869478851843 +! 85861560789112949495459501737958331952853208805511 +! 12540698747158523863050715693290963295227443043557 +! 66896648950445244523161731856403098711121722383113 +! 62229893423380308135336276614282806444486645238749 +! 30358907296290491560440772390713810515859307960866 +! 70172427121883998797908792274921901699720888093776 +! 65727333001053367881220235421809751254540594752243 +! 52584907711670556013604839586446706324415722155397 +! 53697817977846174064955149290862569321978468622482 +! 83972241375657056057490261407972968652414535100474 +! 82166370484403199890008895243450658541227588666881 +! 16427171479924442928230863465674813919123162824586 +! 17866458359124566529476545682848912883142607690042 +! 24219022671055626321111109370544217506941658960408 +! 07198403850962455444362981230987879927244284909188 +! 84580156166097919133875499200524063689912560717606 +! 05886116467109405077541002256983155200055935729725 +! 71636269561882670428252483600823257530420752963450 + + +! SOLUTION +! -------- + + + +: euler008 ( -- answer ) + source-008 5 collect-consecutive [ string>digits product ] map supremum ; + +! [ euler008 ] 100 ave-time +! 11 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler008 diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor new file mode 100644 index 0000000000..44569149d5 --- /dev/null +++ b/extra/project-euler/009/009.factor @@ -0,0 +1,55 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions namespaces sequences sorting ; +IN: project-euler.009 + +! http://projecteuler.net/index.php?section=problems&id=9 + +! DESCRIPTION +! ----------- + +! A Pythagorean triplet is a set of three natural numbers, a < b < c, for which, +! a² + b² = c² + +! For example, 3² + 4² = 9 + 16 = 25 = 5². + +! There exists exactly one Pythagorean triplet for which a + b + c = 1000. +! Find the product abc. + + +! SOLUTION +! -------- + +! Algorithm adapted from http://www.friesian.com/pythag.com + + q and both are odd integers + dup 1 = [ swap 2 + nip dup 2 - ] [ 2 - ] if ; + +: abc ( p q -- triplet ) + [ + 2dup * , ! a = p * q + 2dup sq swap sq swap - 2 / , ! b = (p² - q²) / 2 + sq swap sq swap + 2 / , ! c = (p² + q²) / 2 + ] { } make natural-sort ; + +: (ptriplet) ( target p q triplet -- target p q ) + roll dup >r swap sum = r> -roll + [ + next-pq 2dup abc (ptriplet) + ] unless ; + +: ptriplet ( target -- triplet ) + 3 1 { 3 4 5 } (ptriplet) abc nip ; + +PRIVATE> + +: euler009 ( -- answer ) + 1000 ptriplet product ; + +! [ euler009 ] 100 ave-time +! 1 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler009 diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor new file mode 100644 index 0000000000..7518eb2f6f --- /dev/null +++ b/extra/project-euler/010/010.factor @@ -0,0 +1,31 @@ +! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel lazy-lists math math.erato math.functions math.ranges + namespaces sequences ; +IN: project-euler.010 + +! http://projecteuler.net/index.php?section=problems&id=10 + +! DESCRIPTION +! ----------- + +! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17. + +! Find the sum of all the primes below one million. + + +! SOLUTION +! -------- + +! Sieve of Eratosthenes and lazy summing + +: euler010 ( -- answer ) + 0 1000000 lerato [ + ] leach ; + +! TODO: solution is still too slow for 1000000, probably due to seq-diff +! calling member? for each number that we want to remove + +! [ euler010 ] time +! 765 ms run / 7 ms GC time + +MAIN: euler010 diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor new file mode 100644 index 0000000000..9739ee971c --- /dev/null +++ b/extra/project-euler/011/011.factor @@ -0,0 +1,107 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces project-euler.common sequences ; +IN: project-euler.011 + +! http://projecteuler.net/index.php?section=problems&id=11 + +! DESCRIPTION +! ----------- + +! In the 20x20 grid below, four numbers along a diagonal line have been marked +! in red. + +! 08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08 +! 49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00 +! 81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65 +! 52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91 +! 22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80 +! 24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50 +! 32 98 81 28 64 23 67 10 26 38 40 67 59 54 70 66 18 38 64 70 +! 67 26 20 68 02 62 12 20 95 63 94 39 63 08 40 91 66 49 94 21 +! 24 55 58 05 66 73 99 26 97 17 78 78 96 83 14 88 34 89 63 72 +! 21 36 23 09 75 00 76 44 20 45 35 14 00 61 33 97 34 31 33 95 +! 78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92 +! 16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57 +! 86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58 +! 19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40 +! 04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66 +! 88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69 +! 04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36 +! 20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16 +! 20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54 +! 01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48 + +! The product of these numbers is 26 * 63 * 78 * 14 = 1788696. + +! What is the greatest product of four numbers in any direction (up, down, +! left, right, or diagonally) in the 20x20 grid? + + +! SOLUTION +! -------- + + ] each + ] keep [ append ] map ; + +: pad-back ( matrix -- matrix ) + [ + length [ 0 ] each + ] keep [ append ] map ; + +: diagonal/ ( -- matrix ) + horizontal reverse pad-front pad-back flip ; + +: diagonal\ ( -- matrix ) + horizontal pad-front pad-back flip ; + +: max-product ( matrix width -- n ) + [ collect-consecutive ] curry map concat + [ product ] map supremum ; inline + +PRIVATE> + +: euler011 ( -- answer ) + [ + { [ horizontal ] [ vertical ] [ diagonal/ ] [ diagonal\ ] } + [ call 4 max-product , ] each + ] { } make supremum ; + +! TODO: solution works but doesn't completely compile due to the creation of +! the diagonal matrices, there must be a cleaner way to generate those + +! [ euler011 ] 100 ave-time +! 4 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler011 diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor new file mode 100644 index 0000000000..0d0d4161e4 --- /dev/null +++ b/extra/project-euler/012/012.factor @@ -0,0 +1,45 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math project-euler.common ; +IN: project-euler.012 + +! http://projecteuler.net/index.php?section=problems&id=12 + +! DESCRIPTION +! ----------- + +! The sequence of triangle numbers is generated by adding the natural numbers. +! So the 7th triangle number would be 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28. The first +! ten terms would be: + +! 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ... + +! Let us list the factors of the first seven triangle numbers: + +! 1: 1 +! 3: 1,3 +! 6: 1,2,3,6 +! 10: 1,2,5,10 +! 15: 1,3,5,15 +! 21: 1,3,7,21 +! 28: 1,2,4,7,14,28 + +! We can see that the 7th triangle number, 28, is the first triangle number to +! have over five divisors. + +! Which is the first triangle number to have over five-hundred divisors? + + +! SOLUTION +! -------- + +: nth-triangle ( n -- n ) + dup 1+ * 2 / ; + +: euler012 ( -- answer ) + 2 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; + +! [ euler012 ] 10 ave-time +! 5413 ms run / 1 ms GC ave time - 10 trials + +MAIN: euler012 diff --git a/extra/project-euler/013/013.factor b/extra/project-euler/013/013.factor new file mode 100644 index 0000000000..be968fc346 --- /dev/null +++ b/extra/project-euler/013/013.factor @@ -0,0 +1,233 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.parser sequences ; +IN: project-euler.013 + +! http://projecteuler.net/index.php?section=problems&id=13 + +! DESCRIPTION +! ----------- + +! Work out the first ten digits of the sum of the following one-hundred +! 50-digit numbers. + +! 37107287533902102798797998220837590246510135740250 +! 46376937677490009712648124896970078050417018260538 +! 74324986199524741059474233309513058123726617309629 +! 91942213363574161572522430563301811072406154908250 +! 23067588207539346171171980310421047513778063246676 +! 89261670696623633820136378418383684178734361726757 +! 28112879812849979408065481931592621691275889832738 +! 44274228917432520321923589422876796487670272189318 +! 47451445736001306439091167216856844588711603153276 +! 70386486105843025439939619828917593665686757934951 +! 62176457141856560629502157223196586755079324193331 +! 64906352462741904929101432445813822663347944758178 +! 92575867718337217661963751590579239728245598838407 +! 58203565325359399008402633568948830189458628227828 +! 80181199384826282014278194139940567587151170094390 +! 35398664372827112653829987240784473053190104293586 +! 86515506006295864861532075273371959191420517255829 +! 71693888707715466499115593487603532921714970056938 +! 54370070576826684624621495650076471787294438377604 +! 53282654108756828443191190634694037855217779295145 +! 36123272525000296071075082563815656710885258350721 +! 45876576172410976447339110607218265236877223636045 +! 17423706905851860660448207621209813287860733969412 +! 81142660418086830619328460811191061556940512689692 +! 51934325451728388641918047049293215058642563049483 +! 62467221648435076201727918039944693004732956340691 +! 15732444386908125794514089057706229429197107928209 +! 55037687525678773091862540744969844508330393682126 +! 18336384825330154686196124348767681297534375946515 +! 80386287592878490201521685554828717201219257766954 +! 78182833757993103614740356856449095527097864797581 +! 16726320100436897842553539920931837441497806860984 +! 48403098129077791799088218795327364475675590848030 +! 87086987551392711854517078544161852424320693150332 +! 59959406895756536782107074926966537676326235447210 +! 69793950679652694742597709739166693763042633987085 +! 41052684708299085211399427365734116182760315001271 +! 65378607361501080857009149939512557028198746004375 +! 35829035317434717326932123578154982629742552737307 +! 94953759765105305946966067683156574377167401875275 +! 88902802571733229619176668713819931811048770190271 +! 25267680276078003013678680992525463401061632866526 +! 36270218540497705585629946580636237993140746255962 +! 24074486908231174977792365466257246923322810917141 +! 91430288197103288597806669760892938638285025333403 +! 34413065578016127815921815005561868836468420090470 +! 23053081172816430487623791969842487255036638784583 +! 11487696932154902810424020138335124462181441773470 +! 63783299490636259666498587618221225225512486764533 +! 67720186971698544312419572409913959008952310058822 +! 95548255300263520781532296796249481641953868218774 +! 76085327132285723110424803456124867697064507995236 +! 37774242535411291684276865538926205024910326572967 +! 23701913275725675285653248258265463092207058596522 +! 29798860272258331913126375147341994889534765745501 +! 18495701454879288984856827726077713721403798879715 +! 38298203783031473527721580348144513491373226651381 +! 34829543829199918180278916522431027392251122869539 +! 40957953066405232632538044100059654939159879593635 +! 29746152185502371307642255121183693803580388584903 +! 41698116222072977186158236678424689157993532961922 +! 62467957194401269043877107275048102390895523597457 +! 23189706772547915061505504953922979530901129967519 +! 86188088225875314529584099251203829009407770775672 +! 11306739708304724483816533873502340845647058077308 +! 82959174767140363198008187129011875491310547126581 +! 97623331044818386269515456334926366572897563400500 +! 42846280183517070527831839425882145521227251250327 +! 55121603546981200581762165212827652751691296897789 +! 32238195734329339946437501907836945765883352399886 +! 75506164965184775180738168837861091527357929701337 +! 62177842752192623401942399639168044983993173312731 +! 32924185707147349566916674687634660915035914677504 +! 99518671430235219628894890102423325116913619626622 +! 73267460800591547471830798392868535206946944540724 +! 76841822524674417161514036427982273348055556214818 +! 97142617910342598647204516893989422179826088076852 +! 87783646182799346313767754307809363333018982642090 +! 10848802521674670883215120185883543223812876952786 +! 71329612474782464538636993009049310363619763878039 +! 62184073572399794223406235393808339651327408011116 +! 66627891981488087797941876876144230030984490851411 +! 60661826293682836764744779239180335110989069790714 +! 85786944089552990653640447425576083659976645795096 +! 66024396409905389607120198219976047599490197230297 +! 64913982680032973156037120041377903785566085089252 +! 16730939319872750275468906903707539413042652315011 +! 94809377245048795150954100921645863754710598436791 +! 78639167021187492431995700641917969777599028300699 +! 15368713711936614952811305876380278410754449733078 +! 40789923115535562561142322423255033685442488917353 +! 44889911501440648020369068063960672322193204149535 +! 41503128880339536053299340368006977710650566631954 +! 81234880673210146739058568557934581403627822703280 +! 82616570773948327592232845941706525094512325230608 +! 22918802058777319719839450180888072429661980811197 +! 77158542502016545090413245809786882778948721859617 +! 72107838435069186155435662884062257473692284509516 +! 20849603980134001723930671666823555245252804609722 +! 53503534226472524250874054075591789781264330331690 + + +! SOLUTION +! -------- + + + +: euler013 ( -- answer ) + source-013 sum number>string 10 head string>number ; + +! [ euler013 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler013 diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor new file mode 100644 index 0000000000..7c1f0d41f9 --- /dev/null +++ b/extra/project-euler/014/014.factor @@ -0,0 +1,79 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.ranges namespaces sequences + sorting ; +IN: project-euler.014 + +! http://projecteuler.net/index.php?section=problems&id=14 + +! DESCRIPTION +! ----------- + +! The following iterative sequence is defined for the set of positive integers: + +! n -> n / 2 (n is even) +! n -> 3n + 1 (n is odd) + +! Using the rule above and starting with 13, we generate the following +! sequence: + +! 13 -> 40 -> 20 -> 10 -> 5 -> 16 -> 8 -> 4 -> 2 -> 1 + +! It can be seen that this sequence (starting at 13 and finishing at 1) +! contains 10 terms. Although it has not been proved yet (Collatz Problem), it +! is thought that all starting numbers finish at 1. + +! Which starting number, under one million, produces the longest chain? + +! NOTE: Once the chain starts the terms are allowed to go above one million. + + +! SOLUTION +! -------- + +! Brute force + + [ nip ] [ drop ] if ; + +PRIVATE> + +: collatz ( n -- seq ) + [ [ dup 1 > ] [ dup , next-collatz ] [ ] while , ] { } make ; + +: euler014 ( -- answer ) + 1000000 0 [ 1+ collatz longest ] reduce first ; + +! [ euler014 ] time +! 52868 ms run / 483 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + + + +: euler014a ( -- answer ) + 500000 1000000 [a,b] 1 [ + dup worth-calculating? [ collatz longest ] [ drop ] if + ] reduce first ; + +! [ euler014a ] 10 ave-time +! 5109 ms run / 44 ms GC time + +! TODO: try using memoization + +MAIN: euler014a diff --git a/extra/project-euler/015/015.factor b/extra/project-euler/015/015.factor new file mode 100644 index 0000000000..305426902b --- /dev/null +++ b/extra/project-euler/015/015.factor @@ -0,0 +1,33 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.combinatorics ; +IN: project-euler.015 + +! http://projecteuler.net/index.php?section=problems&id=15 + +! DESCRIPTION +! ----------- + +! Starting in the top left corner of a 2x2 grid, there are 6 routes (without +! backtracking) to the bottom right corner. + +! How many routes are there through a 20x20 grid? + + +! SOLUTION +! -------- + + + +: euler015 ( -- answer ) + 20 grid-paths ; + +! [ euler015 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler015 diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor new file mode 100644 index 0000000000..a8b2aea0b7 --- /dev/null +++ b/extra/project-euler/016/016.factor @@ -0,0 +1,28 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.functions math.parser sequences ; +IN: project-euler.016 + +! http://projecteuler.net/index.php?section=problems&id=16 + +! DESCRIPTION +! ----------- + +! 2^15 = 32768 and the sum of its digits is 3 + 2 + 7 + 6 + 8 = 26. + +! What is the sum of the digits of the number 2^1000? + + +! SOLUTION +! -------- + +: number>digits ( n -- seq ) + number>string string>digits ; + +: euler016 ( -- answer ) + 2 1000 ^ number>digits sum ; + +! [ euler016 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler016 diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor new file mode 100644 index 0000000000..7568872743 --- /dev/null +++ b/extra/project-euler/017/017.factor @@ -0,0 +1,65 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math namespaces sequences strings ; +IN: project-euler.017 + +! http://projecteuler.net/index.php?section=problems&id=17 + +! DESCRIPTION +! ----------- + +! If the numbers 1 to 5 are written out in words: one, two, three, four, five; +! there are 3 + 3 + 5 + 4 + 4 = 19 letters used in total. + +! If all the numbers from 1 to 1000 (one thousand) inclusive were written out +! in words, how many letters would be used? + +! NOTE: Do not count spaces or hyphens. For example, 342 (three hundred and +! forty-two) contains 23 letters and 115 (one hundred and fifteen) contains +! 20 letters. + +! SOLUTION +! -------- + + + +: >english ( n -- str ) + [ make-english ] "" make ; + +: euler017 ( -- answer ) + 1000 [ 1 + >english [ letter? ] subset length ] map sum ; + +! [ euler017 ] 100 ave-time +! 9 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler017 diff --git a/extra/project-euler/authors.txt b/extra/project-euler/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/project-euler/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/project-euler/ave-time/authors.txt b/extra/project-euler/ave-time/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/project-euler/ave-time/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/project-euler/ave-time/ave-time-docs.factor b/extra/project-euler/ave-time/ave-time-docs.factor new file mode 100644 index 0000000000..cc40ae4bf1 --- /dev/null +++ b/extra/project-euler/ave-time/ave-time-docs.factor @@ -0,0 +1,24 @@ +USING: arrays help.markup help.syntax math memory quotations sequences system tools.time ; +IN: project-euler.ave-time + +HELP: collect-benchmarks +{ $values { "quot" quotation } { "n" integer } { "seq" sequence } } +{ $description "Runs a quotation " { $snippet "n" } " times, collecting the wall clock time and the time spent in the garbage collector into pairs inside of a sequence." } +{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." + $nl + "A nicer word for interactive use is " { $link ave-time } "." } ; + +HELP: ave-time +{ $values { "quot" quotation } { "n" integer } } +{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and the average time spent in the garbage collector." } +{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." } +{ $examples + "This word can be used to compare performance of the non-optimizing and optimizing compilers." + $nl + "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" + { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run / 6 ms GC ave time - 10 trials" } + "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:" + { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run / 13 ms GC ave time - 10 trials" } +} ; + +{ benchmark collect-benchmarks gc-time millis time ave-time } related-words diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor new file mode 100644 index 0000000000..d481b30c84 --- /dev/null +++ b/extra/project-euler/ave-time/ave-time.factor @@ -0,0 +1,25 @@ +! Copyright (c) 2007 Aaron Schaefer +! See http://factorcode.org/license.txt for BSD license. +USING: arrays effects inference io kernel math math.functions math.parser + math.statistics namespaces sequences tools.time ; +IN: project-euler.ave-time + + + +: collect-benchmarks ( quot n -- seq ) + [ + 1- [ [ benchmark ] keep -rot 2array , [ clean-stack ] keep ] times + ] curry { } make >r benchmark 2array r> swap add ; inline + +: ave-time ( quot n -- ) + [ collect-benchmarks ] keep swap ave-benchmarks [ + dup second # " ms run / " % first # " ms GC ave time - " % # " trials" % + ] "" make print flush ; inline diff --git a/extra/project-euler/ave-time/summary.txt b/extra/project-euler/ave-time/summary.txt new file mode 100644 index 0000000000..5fadfa99be --- /dev/null +++ b/extra/project-euler/ave-time/summary.txt @@ -0,0 +1 @@ +Averaging code execution times diff --git a/extra/project-euler/ave-time/tags.txt b/extra/project-euler/ave-time/tags.txt new file mode 100644 index 0000000000..ef1aab0d0e --- /dev/null +++ b/extra/project-euler/ave-time/tags.txt @@ -0,0 +1 @@ +tools diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor new file mode 100644 index 0000000000..73de3a7208 --- /dev/null +++ b/extra/project-euler/common/common.factor @@ -0,0 +1,61 @@ +USING: arrays kernel hashtables math math.functions math.miller-rabin + math.ranges namespaces sequences combinators.lib ; +IN: project-euler.common + +! A collection of words used by more than one Project Euler solution. + +r length 1+ r> - ; + +: shift-3rd ( seq obj obj -- seq obj obj ) + rot 1 tail -rot ; + +: >multiplicity ( seq -- seq ) + dup prune [ + [ 2dup [ = ] curry count 2array , ] each + ] { } make nip ; inline + +: reduce-2s ( n -- r s ) + dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ; + +: tau-limit ( n -- n ) + sqrt floor >fixnum ; + +PRIVATE> + + +: divisor? ( n m -- ? ) + mod zero? ; + +: perfect-square? ( n -- ? ) + dup sqrt mod zero? ; + +: collect-consecutive ( seq width -- seq ) + [ + 2dup count-shifts [ 2dup head shift-3rd , ] times + ] { } make 2nip ; + +: prime-factorization ( n -- seq ) + [ + 2 [ over 1 > ] + [ 2dup divisor? [ dup , [ / ] keep ] [ next-prime ] if ] + [ ] while 2drop + ] { } make ; + +: prime-factorization* ( n -- seq ) + prime-factorization >multiplicity ; + +: prime-factors ( n -- seq ) + prime-factorization prune >array ; + +! The divisor function, counts the number of divisors +: tau ( n -- n ) + prime-factorization* flip second 1 [ 1+ * ] reduce ; + +! Optimized brute-force, is often faster than prime factorization +: tau* ( n -- n ) + reduce-2s [ perfect-square? -1 0 ? ] keep dup tau-limit [1,b] [ + dupd divisor? [ >r 2 + r> ] when + ] each drop * ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor new file mode 100644 index 0000000000..c35101785a --- /dev/null +++ b/extra/project-euler/project-euler.factor @@ -0,0 +1,44 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.files kernel math.parser namespaces sequences strings + vocabs vocabs.loader system project-euler.ave-time + project-euler.001 project-euler.002 project-euler.003 project-euler.004 + project-euler.005 project-euler.006 project-euler.007 project-euler.008 + project-euler.009 project-euler.010 project-euler.011 project-euler.012 + project-euler.013 project-euler.014 project-euler.015 project-euler.016 ; +IN: project-euler + +number ; + +: number>euler ( n -- str ) + number>string string>digits 3 0 pad-left [ number>string ] map concat ; + +: solution-path ( n -- str ) + number>euler dup [ + "project-euler" vocab-root ?resource-path % + os "windows" = [ + "\\project-euler\\" % % "\\" % % ".factor" % + ] [ + "/project-euler/" % % "/" % % ".factor" % + ] if + ] "" make ; + +PRIVATE> + +: problem-solved? ( n -- ? ) + solution-path exists? ; + +: run-project-euler ( -- ) + problem-prompt dup problem-solved? [ + dup number>euler "project-euler." swap append run + "Answer: " swap number>string append print + "Source: " swap solution-path append print + ] [ + drop "That problem has not been solved yet..." print + ] if ; + +MAIN: run-project-euler diff --git a/extra/project-euler/summary.txt b/extra/project-euler/summary.txt new file mode 100644 index 0000000000..add3da577f --- /dev/null +++ b/extra/project-euler/summary.txt @@ -0,0 +1 @@ +Project Euler example solutions diff --git a/extra/project-euler/tags.txt b/extra/project-euler/tags.txt new file mode 100644 index 0000000000..1e107f52e4 --- /dev/null +++ b/extra/project-euler/tags.txt @@ -0,0 +1 @@ +examples diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index cfb1c903e8..233dfcb221 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. IN: rss -USING: xml.utilities kernel assocs +USING: xml.utilities kernel assocs xml.generator strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables ; @@ -85,26 +85,22 @@ C: entry ] if ; ! Atom generation -: simple-tag, ( content name -- ) - [ , ] tag, ; - -: simple-tag*, ( content name attrs -- ) - [ , ] tag*, ; - : entry, ( entry -- ) - "entry" [ - dup entry-title "title" { { "type" "html" } } simple-tag*, - "link" over entry-link "href" associate contained*, - dup entry-pub-date "published" simple-tag, - entry-description [ "content" { { "type" "html" } } simple-tag*, ] when* - ] tag, ; + << entry >> [ + << title >> [ dup entry-title , ] + << link [ dup entry-link ] == href // >> + << published >> [ dup entry-pub-date , ] + << content >> [ entry-description , ] + ] ; : feed>xml ( feed -- xml ) - "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ - dup feed-title "title" simple-tag, - "link" over feed-link "href" associate contained*, - feed-entries [ entry, ] each - ] make-xml* ; + > [ + << title >> [ dup feed-title , ] + << link [ dup feed-link ] == href // >> + feed-entries [ entry, ] each + ] + XML> ; : write-feed ( feed -- ) feed>xml write-xml ; diff --git a/extra/sequences/deep/authors.txt b/extra/sequences/deep/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/sequences/deep/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/sequences/deep/deep-docs.factor b/extra/sequences/deep/deep-docs.factor new file mode 100644 index 0000000000..7a27bbdc1d --- /dev/null +++ b/extra/sequences/deep/deep-docs.factor @@ -0,0 +1,29 @@ +USING: help.syntax help.markup sequences.deep ; + +HELP: deep-each +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ) " } } +{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } ; + +HELP: deep-map +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } } +{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ; + +HELP: deep-subset +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } } +{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ; + +HELP: deep-find +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "elt" "an element" } } +{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } ; + +HELP: deep-contains? +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "?" "a boolean" } } +{ $description "Tests whether the given object or any subnode satisfies the given quotation." } ; + +HELP: flatten +{ $values { "obj" "an object" } { "seq" "a sequence" } } +{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ; + +HELP: deep-change-each +{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } } +{ $description "Modifies each sub-node of an object in place, in preorder." } ; diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor new file mode 100644 index 0000000000..9c02d52089 --- /dev/null +++ b/extra/sequences/deep/deep-tests.factor @@ -0,0 +1,25 @@ +USING: sequences.deep kernel tools.test strings math arrays +namespaces sequences ; + +[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test + +[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find* ] unit-test + +[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find* ] unit-test + +[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test + +: change-something ( seq -- newseq ) + dup array? [ "hi" add ] [ "hello" append ] if ; + +[ { { "heyhello" "hihello" } "hihello" } ] +[ "hey" 1array 1array [ change-something ] deep-map ] unit-test + +[ { { "heyhello" "hihello" } } ] +[ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test + +[ t ] [ "foo" [ string? ] deep-contains? ] unit-test + +[ "foo" ] [ "foo" [ string? ] deep-find ] unit-test + +[ { { 1 2 } 1 2 } ] [ [ { 1 2 } [ , ] deep-each ] { } make ] unit-test diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor new file mode 100644 index 0000000000..6e36878b78 --- /dev/null +++ b/extra/sequences/deep/deep.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel strings math ; +IN: sequences.deep + +! All traversal goes in postorder + +GENERIC: branch? ( object -- ? ) +M: sequence branch? drop t ; +M: string branch? drop f ; +M: number branch? drop f ; +M: object branch? drop f ; + +: deep-each ( obj quot -- ) + [ call ] 2keep over branch? + [ [ deep-each ] curry each ] [ 2drop ] if ; inline + +: deep-map ( obj quot -- newobj ) + [ call ] keep over branch? + [ [ deep-map ] curry map ] [ drop ] if ; inline + +: deep-subset ( obj quot -- seq ) + over >r + pusher >r deep-each r> + r> dup branch? [ like ] [ drop ] if ; inline + +: deep-find* ( obj quot -- elt ? ) + [ call ] 2keep rot [ drop t ] [ + over branch? [ + f -rot [ >r nip r> deep-find* ] curry find drop >boolean + ] [ 2drop f f ] if + ] if ; inline + +: deep-find ( obj quot -- elt ) deep-find* drop ; inline + +: deep-contains? ( obj quot -- ? ) deep-find* nip ; inline + +: deep-change-each ( obj quot -- ) + over branch? [ [ + [ call ] keep over >r deep-change-each r> + ] curry change-each ] [ 2drop ] if ; inline + +: flatten ( obj -- seq ) + [ branch? not ] deep-subset ; diff --git a/extra/sequences/deep/summary.txt b/extra/sequences/deep/summary.txt new file mode 100644 index 0000000000..60ad867782 --- /dev/null +++ b/extra/sequences/deep/summary.txt @@ -0,0 +1 @@ +Sequence/tree combinators like deep-map, deep-each, etc diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index f5adccf445..ea6fdd141b 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,5 +1,6 @@ USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors ; +USING: arrays math.parser sorting strings ; IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -63,6 +64,10 @@ IN: sequences.lib : delete-random ( seq -- value ) [ length random ] keep [ nth ] 2keep delete-nth ; +: split-around ( seq quot -- before elem after ) + dupd find over [ "Element not found" throw ] unless + >r cut-slice 1 tail r> swap ; inline + : (map-until) ( quot pred -- quot ) [ dup ] swap 3compose [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ; @@ -104,3 +109,20 @@ PRIVATE> : power-set ( seq -- subsets ) 2 over length exact-number-strings swap [ nths ] curry map ; + +: cut-find ( seq pred -- before after ) + dupd find drop dup [ cut ] when ; + +: cut3 ( seq pred -- first mid last ) + [ cut-find ] keep [ not ] compose cut-find ; + +: (cut-all) ( seq pred quot -- ) + [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep + pick [ (cut-all) ] [ 3drop ] if ; + +: cut-all ( seq pred quot -- first mid last ) + [ (cut-all) ] { } make ; + +: human-sort ( seq -- newseq ) + [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc + sort-values keys ; diff --git a/extra/tuple-syntax/about.txt b/extra/tuple-syntax/about.txt new file mode 100644 index 0000000000..f243374925 --- /dev/null +++ b/extra/tuple-syntax/about.txt @@ -0,0 +1 @@ +Tuple literals with named slots diff --git a/extra/tuple-syntax/authors.txt b/extra/tuple-syntax/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/tuple-syntax/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/tuple-syntax/tags.txt b/extra/tuple-syntax/tags.txt new file mode 100644 index 0000000000..71c0ff7282 --- /dev/null +++ b/extra/tuple-syntax/tags.txt @@ -0,0 +1 @@ +syntax diff --git a/extra/tuple-syntax/tuple-syntax-docs.factor b/extra/tuple-syntax/tuple-syntax-docs.factor new file mode 100644 index 0000000000..7d4c12c0e9 --- /dev/null +++ b/extra/tuple-syntax/tuple-syntax-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax tuple-syntax ; + +HELP: TUPLE{ +{ $syntax "TUPLE{ class slot-name: value... }" } +{ $values { "class" "a tuple class word" } { "slot-name" "the name of a slot, without the tuple class name" } { "value" "the value for a slot" } } +{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } ". The class word must be specified. Slots which aren't specified are set to f. If slot names are duplicated, the latest one is used." } +{ $see-also POSTPONE: T{ } ; + +IN: tuple-syntax +ABOUT: POSTPONE: TUPLE{ diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor new file mode 100644 index 0000000000..b16c5b337d --- /dev/null +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -0,0 +1,7 @@ +USING: tools.test tuple-syntax ; + +TUPLE: foo bar baz ; + +[ T{ foo } ] [ TUPLE{ foo } ] unit-test +[ T{ foo 1 { 2 3 } { 4 { 5 } } } ] +[ TUPLE{ foo bar: { 2 3 } delegate: 1 baz: { 4 { 5 } } } ] unit-test diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor new file mode 100644 index 0000000000..ddc90a8961 --- /dev/null +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -0,0 +1,21 @@ +USING: kernel sequences slots parser words classes ; +IN: tuple-syntax + +! TUPLE: foo bar baz ; +! TUPLE{ foo bar: 1 baz: 2 } + +: parse-object ( -- object ) + scan-word dup parsing? [ V{ } clone swap execute first ] when ; + +: parse-slot-writer ( tuple -- slot-setter ) + scan dup "}" = [ 2drop f ] [ + 1 head* swap class "slots" word-prop + [ slot-spec-name = ] curry* find nip slot-spec-writer + ] if ; + +: parse-slots ( accum tuple -- accum tuple ) + dup parse-slot-writer + [ parse-object pick rot execute parse-slots ] when* ; + +: TUPLE{ + scan-word construct-empty parse-slots parsed ; parsing diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index b21e91bc8f..19dab4ed1b 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel furnace fjsc parser-combinators namespaces +USING: kernel furnace fjsc peg namespaces lazy-lists io io.files furnace.validator sequences http.client http.server http.server.responders webapps.file html ; @@ -11,7 +11,7 @@ IN: webapps.fjsc #! Compile the factor code as a string, outputting the http #! response containing the javascript. serving-text - 'expression' parse-1 fjsc-compile + 'expression' parse parse-result-ast fjsc-compile write flush ; ! The 'compile' action results in an URL that looks like @@ -25,7 +25,7 @@ IN: webapps.fjsc : compile-url ( url -- ) #! Compile the factor code at the given url, return the javascript. dup "http:" head? [ "Unable to access remote sites." throw ] when - "http://" host rot 3append http-get 2nip compile "();" write flush ; + "http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ; \ compile-url { { "url" v-required } diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 145df4119a..28d73607ba 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -6,18 +6,19 @@ USING: kernel furnace furnace.validator http.server.responders arrays io.files ; IN: webapps.help +! : string>topic ( string -- topic ) + ! " " split dup length 1 = [ first ] when ; + : show-help ( topic -- ) serving-html dup article-title [ [ help ] with-html-stream ] simple-html-document ; -: string>topic ( string -- topic ) - " " split dup length 1 = [ first ] when ; - \ show-help { - { "topic" "handbook" v-default string>topic } + { "topic" } } define-action +\ show-help { { "topic" "handbook" } } default-values M: link browser-link-href link-name @@ -32,9 +33,10 @@ M: link browser-link-href lookup show-help ; \ show-word { - { "word" "call" v-default } - { "vocab" "kernel" v-default } + { "word" } + { "vocab" } } define-action +\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values M: f browser-link-href drop \ f browser-link-href ; @@ -47,9 +49,11 @@ M: word browser-link-href f >vocab-link show-help ; \ show-vocab { - { "vocab" "kernel" v-default } + { "vocab" } } define-action +\ show-vocab { { "vocab" "kernel" } } default-values + M: vocab-spec browser-link-href vocab-name [ show-vocab ] curry quot-link ; diff --git a/extra/webapps/pastebin/annotate-paste.furnace b/extra/webapps/pastebin/annotate-paste.furnace index abb5cc3d07..14a424f776 100755 --- a/extra/webapps/pastebin/annotate-paste.furnace +++ b/extra/webapps/pastebin/annotate-paste.furnace @@ -6,16 +6,16 @@ -string write %>" /> - - + + - + + @@ -23,11 +23,25 @@ + + + + + + + - +
Summary:" /><% "summary" "*Required" render-error %>
Your name:" /><% "author" "*Required" render-error %>
<% "modes" render-template %>
<% "contents" "*Required" render-error %>
Content:
+string write %>" /> + diff --git a/extra/webapps/pastebin/modes.furnace b/extra/webapps/pastebin/modes.furnace index 960b7d4e27..18bbec180a 100644 --- a/extra/webapps/pastebin/modes.furnace +++ b/extra/webapps/pastebin/modes.furnace @@ -1,7 +1,7 @@ -<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %> +<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %> diff --git a/extra/webapps/pastebin/new-paste.furnace b/extra/webapps/pastebin/new-paste.furnace index 8f48f670d3..b21e19734d 100755 --- a/extra/webapps/pastebin/new-paste.furnace +++ b/extra/webapps/pastebin/new-paste.furnace @@ -1,4 +1,4 @@ -<% USING: furnace namespaces ; %> +<% USING: continuations furnace namespaces ; %> <% "New paste" "title" set @@ -11,12 +11,14 @@ Summary: - +" /> +<% "summary" "*Required" render-error %> Your name: - +" /> +<% "author" "*Required" render-error %> @@ -31,12 +33,18 @@ --> + + +<% "contents" "*Required" render-error %> + + Content: - + + diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 8e4c0a5be9..0a7dc559c3 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,6 +1,6 @@ USING: calendar furnace furnace.validator io.files kernel namespaces sequences store http.server.responders html -math.parser rss xml.writer ; +math.parser rss xml.writer xmode.code2html ; IN: webapps.pastebin TUPLE: pastebin pastes ; @@ -84,28 +84,37 @@ C: annotation store save-store ] keep paste-link permanent-redirect ; +\ new-paste \ submit-paste { - { "summary" "- no summary -" v-default } - { "author" "- no author -" v-default } - { "channel" "#concatenative" v-default } - { "mode" "factor" v-default } + { "summary" v-required } + { "author" v-required } + { "channel" } + { "mode" v-required } { "contents" v-required } -} define-action +} define-form + +\ new-paste { + { "channel" "#concatenative" } + { "mode" "factor" } +} default-values : annotate-paste ( n summary author mode contents -- ) swap get-paste - paste-annotations push - store save-store ; + [ paste-annotations push store save-store ] keep + paste-link permanent-redirect ; +[ "n" show-paste ] \ annotate-paste { { "n" v-required v-number } - { "summary" "- no summary -" v-default } - { "author" "- no author -" v-default } - { "mode" "factor" v-default } + { "summary" v-required } + { "author" v-required } + { "mode" v-required } { "contents" v-required } -} define-action +} define-form -\ annotate-paste [ "n" show-paste ] define-redirect +\ show-paste { + { "mode" "factor" } +} default-values : style.css ( -- ) "text/css" serving-content diff --git a/extra/webapps/pastebin/style.css b/extra/webapps/pastebin/style.css index e3c7c19fc5..4a469f92cb 100644 --- a/extra/webapps/pastebin/style.css +++ b/extra/webapps/pastebin/style.css @@ -35,3 +35,7 @@ pre.code { border: 1px solid #C1DAD7; padding: 10px; } + +.error { + color: red; +} diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index 725d6da3cc..ae54816471 100644 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private assocs arrays vectors ; +USING: kernel sequences sequences.private assocs arrays delegate vectors ; IN: xml.data TUPLE: name space tag url ; @@ -41,17 +41,13 @@ C: instruction TUPLE: prolog version encoding standalone ; C: prolog -TUPLE: xml prolog before after ; -: ( prolog before main after -- xml ) - { set-xml-prolog set-xml-before set-delegate set-xml-after } - xml construct ; +TUPLE: tag attrs children ; -TUPLE: attrs ; -: ( alist -- attrs ) - attrs construct-delegate ; +TUPLE: attrs alist ; +C: attrs : attr@ ( key alist -- index {key,value} ) - >r assure-name r> + >r assure-name r> attrs-alist [ first names-match? ] curry* find ; M: attrs at* @@ -60,13 +56,13 @@ M: attrs set-at 2dup attr@ nip [ 2nip set-second ] [ - [ >r assure-name swap 2array r> ?push ] keep - set-delegate + >r assure-name swap 2array r> + [ attrs-alist ?push ] keep set-attrs-alist ] if* ; -M: attrs assoc-size length ; +M: attrs assoc-size attrs-alist length ; M: attrs new-assoc drop V{ } new ; -M: attrs >alist delegate >alist ; +M: attrs >alist attrs-alist ; : >attrs ( assoc -- attrs ) dup [ @@ -77,39 +73,67 @@ M: attrs assoc-like drop dup attrs? [ >attrs ] unless ; M: attrs clear-assoc - f swap set-delegate ; + f swap set-attrs-alist ; M: attrs delete-at - tuck attr@ drop [ swap delete-nth ] [ drop ] if* ; + tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ; + +M: attrs clone + attrs-alist clone ; INSTANCE: attrs assoc -TUPLE: tag attrs children ; : ( name attrs children -- tag ) >r >r assure-name r> T{ attrs } assoc-like r> { set-delegate set-tag-attrs set-tag-children } tag construct ; ! For convenience, tags follow the assoc protocol too (for attrs) -M: tag at* tag-attrs at* ; -M: tag set-at tag-attrs set-at ; -M: tag new-assoc tag-attrs new-assoc ; -M: tag >alist tag-attrs >alist ; -M: tag delete-at tag-attrs delete-at ; -M: tag clear-assoc tag-attrs clear-assoc ; -M: tag assoc-size tag-attrs assoc-size ; -M: tag assoc-like tag-attrs assoc-like ; - +CONSULT: assoc-protocol tag tag-attrs ; INSTANCE: tag assoc ! They also follow the sequence protocol (for children) -M: tag nth tag-children nth ; -M: tag nth-unsafe tag-children nth-unsafe ; -M: tag set-nth tag-children set-nth ; -M: tag set-nth-unsafe tag-children set-nth-unsafe ; -M: tag length tag-children length ; - +CONSULT: sequence-protocol tag tag-children ; INSTANCE: tag sequence +M: tag like + over tag? [ drop ] [ + [ delegate ] keep tag-attrs + rot dup [ V{ } like ] when + ] if ; + +M: tag clone + [ delegate clone ] keep [ tag-attrs clone ] keep + tag-children clone + { set-delegate set-tag-attrs set-tag-children } tag construct ; + +TUPLE: xml prolog before main after ; +: ( prolog before main after -- xml ) + { set-xml-prolog set-xml-before set-delegate set-xml-after } + xml construct ; + +CONSULT: sequence-protocol xml delegate ; +INSTANCE: xml sequence + +CONSULT: assoc-protocol xml delegate ; +INSTANCE: xml assoc + +xml ( xml tag -- newxml ) + swap [ dup xml-prolog swap xml-before rot ] keep xml-after ; + +: seq>xml ( xml seq -- newxml ) + over delegate like tag>xml ; +PRIVATE> + +M: xml clone + [ xml-prolog clone ] keep [ xml-before clone ] keep + [ delegate clone ] keep xml-after clone ; + +M: xml like + swap dup xml? [ nip ] [ + dup tag? [ tag>xml ] [ seq>xml ] if + ] if ; + ! tag with children=f is contained : ( name attrs -- tag ) f ; diff --git a/extra/xml/generator/generator.factor b/extra/xml/generator/generator.factor index d5eb64388c..44bd1934f8 100644 --- a/extra/xml/generator/generator.factor +++ b/extra/xml/generator/generator.factor @@ -1,4 +1,7 @@ -USING: namespaces kernel xml.data xml.utilities ; +! Copyright (C) 2006, 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel xml.data xml.utilities assocs splitting +sequences parser quotations sequences.lib xml.utilities ; IN: xml.generator : comment, ( string -- ) , ; @@ -21,3 +24,56 @@ IN: xml.generator (tag,) build-xml ; inline : make-xml ( name quot -- xml ) f swap make-xml* ; inline + +! Word-based XML literal syntax +: parsed-name ( accum -- accum ) + scan ":" split1 [ f ] [ ] if* parsed ; + +: run-combinator ( accum quot1 quot2 -- accum ) + >r [ ] like parsed r> [ parsed ] each ; + +: parse-tag-contents ( accum contained? -- accum ) + [ \ contained*, parsed ] [ + scan-word \ [ = + [ POSTPONE: [ \ tag*, parsed ] + [ "Expected [ missing" throw ] if + ] if ; + +DEFER: >> + +: attributes-parsed ( accum quot -- accum ) + dup empty? [ drop f parsed ] [ + >r \ >r parsed r> parsed + [ H{ } make-assoc r> swap ] [ parsed ] each + ] if ; + +: << + parsed-name [ + \ >> parse-until >quotation + attributes-parsed \ contained? get + ] with-scope parse-tag-contents ; parsing + +: == + \ call parsed parsed-name \ set parsed ; parsing + +: // + \ contained? on ; parsing + +: parse-special ( accum end-token word -- accum ) + >r parse-tokens " " join parsed r> parsed ; + +: " \ comment, parse-special ; parsing + +: " \ directive, parse-special ; parsing + +: " \ instruction, parse-special ; parsing + +: >xml-document ( seq -- xml ) + dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap + [ tag? ] split-around ; + +DEFER: XML> + +: [ >quotation ] parse-literal + { } parsed \ make parsed \ >xml-document parsed ; parsing diff --git a/extra/xml/test/soap.factor b/extra/xml/test/soap.factor index ed8bd70efc..f8bd8e1021 100644 --- a/extra/xml/test/soap.factor +++ b/extra/xml/test/soap.factor @@ -5,7 +5,7 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ; [ tag-named children>string ] curry* map ; : parse-result ( xml -- seq ) - "resultElements" tag-named* "item" tags-named + "resultElements" deep-tag-named "item" tags-named [ assemble-data ] map ; [ "http://www.foxnews.com/oreilly/" ] [ diff --git a/extra/xml/test/templating.factor b/extra/xml/test/templating.factor index baa0e3bca1..ca2d973510 100644 --- a/extra/xml/test/templating.factor +++ b/extra/xml/test/templating.factor @@ -1,6 +1,6 @@ IN: templating USING: kernel xml sequences assocs tools.test io arrays namespaces - xml.data xml.utilities xml.writer generic ; + xml.data xml.utilities xml.writer generic sequences.deep ; : sub-tag T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ; @@ -16,7 +16,7 @@ M: tag (r-ref) M: object (r-ref) drop ; : template ( xml -- ) - [ (r-ref) ] xml-each ; + [ (r-ref) ] deep-each ; ! Example diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index a2fd2813ed..8c4757517d 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -1,45 +1,48 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -IN: temporary -USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities +! Copyright (C) 2005, 2006 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +IN: temporary +USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities parser strings xml.data io.files xml.writer xml.utilities state-parser - continuations assocs ; - -! This is insufficient -SYMBOL: xml-file -[ ] [ "extra/xml/test/test.xml" resource-path - [ file>xml ] with-html-entities xml-file set ] unit-test -[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test -[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test -[ "a" ] [ xml-file get name-space ] unit-test -[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test -[ "that" ] [ - xml-file get T{ name f "" "this" "http://d.de" } swap at -] unit-test -[ t ] [ xml-file get tag-children second contained-tag? ] unit-test -[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test -[ T{ comment f "This is where the fun begins!" } ] [ - xml-file get xml-before [ comment? ] find nip -] unit-test -[ "xsl stylesheet=\"that-one.xsl\"" ] [ - xml-file get xml-after [ instruction? ] find nip instruction-text -] unit-test -[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test -[ "that" ] [ xml-file get "this" swap at ] unit-test -[ "" ] - [ "" string>xml xml>string ] unit-test -[ "abcd" ] [ - "
abcd
" string>xml - [ [ dup string? [ % ] [ drop ] if ] xml-each ] "" make -] unit-test -[ "abcd" ] [ - "
abcd
" string>xml - [ string? ] xml-subset concat -] unit-test -[ "foo" ] [ - "
foo" string>xml - "c" get-id children>string -] unit-test -[ "foo" ] [ "" string>xml "y" over -at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test + continuations assocs sequences.deep ; + +! This is insufficient +SYMBOL: xml-file +[ ] [ "extra/xml/test/test.xml" resource-path + [ file>xml ] with-html-entities xml-file set ] unit-test +[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test +[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test +[ "a" ] [ xml-file get name-space ] unit-test +[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test +[ "that" ] [ + xml-file get T{ name f "" "this" "http://d.de" } swap at +] unit-test +[ t ] [ xml-file get tag-children second contained-tag? ] unit-test +[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test +[ T{ comment f "This is where the fun begins!" } ] [ + xml-file get xml-before [ comment? ] find nip +] unit-test +[ "xsl stylesheet=\"that-one.xsl\"" ] [ + xml-file get xml-after [ instruction? ] find nip instruction-text +] unit-test +[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test +[ "that" ] [ xml-file get "this" swap at ] unit-test +[ "" ] + [ "" string>xml xml>string ] unit-test +[ "abcd" ] [ + "
abcd
" string>xml + [ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make +] unit-test +[ "abcd" ] [ + "
abcd
" string>xml + [ string? ] deep-subset concat +] unit-test +[ "foo" ] [ + "
foo" string>xml + "c" get-id children>string +] unit-test +[ "foo" ] [ "" string>xml "y" over + at swap "z" >r tuck r> swap set-at + T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test +[ "bar baz" ] +[ "bar" string>xml [ " baz" append ] map xml>string ] unit-test diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index 5e3bf1edfa..85a473f503 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -124,7 +124,8 @@ SYMBOL: ns-stack [ parse-attr (middle-tag) ] when ; : middle-tag ( -- attrs-alist ) - [ (middle-tag) ] V{ } make pass-blank ; + ! f make will make a vector if it has any elements + [ (middle-tag) ] f make pass-blank ; : end-tag ( name attrs-alist -- tag ) tag-ns pass-blank get-char CHAR: / = diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index 2ce4e2b3d3..2d2c6a1d04 100644 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences words io assocs quotations strings parser arrays xml.data xml.writer debugger -splitting vectors ; +splitting vectors sequences.deep ; IN: xml.utilities ! * System for words specialized on tag names @@ -59,59 +59,6 @@ M: process-missing error. : first-child-tag ( tag -- tag ) tag-children [ tag? ] find nip ; -! * Utilities for searching through XML documents -! These all work from the outside in, top to bottom. - -: with-delegate ( object quot -- object ) - over clone >r >r delegate r> call r> - [ set-delegate ] keep ; inline - -GENERIC# xml-each 1 ( quot tag -- ) inline -M: tag xml-each - [ call ] 2keep - swap tag-children [ swap xml-each ] curry* each ; -M: object xml-each - call ; -M: xml xml-each - >r delegate r> xml-each ; - -GENERIC# xml-map 1 ( quot tag -- tag ) inline -M: tag xml-map - swap clone over >r swap call r> - swap [ tag-children [ swap xml-map ] curry* map ] keep - [ set-tag-children ] keep ; -M: object xml-map - call ; -M: xml xml-map - swap [ swap xml-map ] with-delegate ; - -: xml-subset ( quot tag -- seq ) ! quot: tag -- ? - V{ } clone rot [ - swap >r [ swap call ] 2keep rot r> - swap [ [ push ] keep ] [ nip ] if - ] xml-each nip ; - -GENERIC# xml-find 1 ( quot tag -- tag ) inline -M: tag xml-find - [ call ] 2keep swap rot [ - f swap - [ nip over >r swap xml-find r> swap dup ] find - 2drop ! leaves result of quot - ] unless nip ; -M: object xml-find - keep f ? ; -M: xml xml-find - >r delegate r> xml-find ; - -GENERIC# xml-inject 1 ( quot tag -- ) inline -M: tag xml-inject - swap [ - swap [ call ] keep - [ xml-inject ] keep - ] change-each ; -M: object xml-inject 2drop ; -M: xml xml-inject >r delegate >r xml-inject ; - ! * Accessing part of an XML document ! for tag- words, a start means that it searches all children ! and no star searches only direct children @@ -119,19 +66,43 @@ M: xml xml-inject >r delegate >r xml-inject ; : tag-named? ( name elem -- ? ) dup tag? [ names-match? ] [ 2drop f ] if ; -: tag-named* ( tag name/string -- matching-tag ) - assure-name swap [ dupd tag-matches? ] xml-find nip ; +: tags@ ( tag name -- children name ) + >r { } like r> assure-name ; -: tags-named* ( tag name/string -- tags-seq ) - assure-name swap [ dupd tag-matches? ] xml-subset nip ; +: deep-tag-named ( tag name/string -- matching-tag ) + assure-name [ swap tag-named? ] curry deep-find ; + +: deep-tags-named ( tag name/string -- tags-seq ) + tags@ [ swap tag-named? ] curry deep-subset ; : tag-named ( tag name/string -- matching-tag ) ! like get-name-tag but only looks at direct children, ! not all the children down the tree. - assure-name swap [ tag-matches? ] curry* find nip ; + assure-name swap [ tag-named? ] curry* find nip ; : tags-named ( tag name/string -- tags-seq ) - assure-name swap [ tag-matches? ] curry* subset ; + tags@ swap [ tag-named? ] curry* subset ; + +: tag-with-attr? ( elem attr-value attr-name -- ? ) + rot dup tag? [ at = ] [ 3drop f ] if ; + +: tag-with-attr ( tag attr-value attr-name -- matching-tag ) + assure-name [ tag-with-attr? ] 2curry find nip ; + +: tags-with-attr ( tag attr-value attr-name -- tags-seq ) + tags@ [ tag-with-attr? ] 2curry subset tag-children ; + +: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) + assure-name [ tag-with-attr? ] 2curry deep-find ; + +: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) + tags@ [ tag-with-attr? ] 2curry deep-subset ; + +: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) + "id" deep-tag-with-attr ; + +: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags ) + >r >r deep-tags-named r> r> tags-with-attr ; : assert-tag ( name name -- ) names-match? [ "Unexpected XML tag found" throw ] unless ; @@ -142,25 +113,3 @@ M: xml xml-inject >r delegate >r xml-inject ; : insert-child ( child tag -- ) >r 1vector r> insert-children ; - -: tag-with-attr? ( elem attr-value attr-name -- ? ) - rot dup tag? [ at = ] [ drop f ] if ; - -: tag-with-attr ( tag attr-value attr-name -- matching-tag ) - assure-name [ tag-with-attr? ] 2curry find nip ; - -: tags-with-attr ( tag attr-value attr-name -- tags-seq ) - assure-name [ tag-with-attr? ] 2curry subset ; - -: tag-with-attr* ( tag attr-value attr-name -- matching-tag ) - assure-name [ tag-with-attr? ] 2curry xml-find nip ; - -: tags-with-attr* ( tag attr-value attr-name -- tags-seq ) - assure-name [ tag-with-attr? ] 2curry xml-subset ; - -: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) - "id" tag-with-attr ; - -: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags ) - >r >r tags-named* r> r> tags-with-attr ; - diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 986f1b5a01..b0b707fd42 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -22,14 +22,14 @@ IN: xml.writer [ write CHAR: : write1 ] when* name-tag write ; -: print-attrs ( hash -- ) +: print-attrs ( assoc -- ) [ - first2 " " write + " " write swap print-name "=\"" write chars>entities write "\"" write - ] each ; + ] assoc-each ; GENERIC: write-item ( object -- ) @@ -38,8 +38,7 @@ M: string write-item M: contained-tag write-item CHAR: < write1 - dup print-name - tag-attrs print-attrs + dup print-name tag-attrs print-attrs "/>" write ; M: open-tag write-item diff --git a/extra/xml/xml-docs.factor b/extra/xml/xml-docs.factor index bb833585c0..e1c4d035fd 100644 --- a/extra/xml/xml-docs.factor +++ b/extra/xml/xml-docs.factor @@ -49,24 +49,6 @@ HELP: TAG: { $description "defines what a process should do when it encounters a specific tag" } { $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } { $see-also POSTPONE: PROCESS: } ; - -HELP: xml-each -{ $values { "tag" tag } { "quot" "a quotation ( element -- )" } } -{ $description "applies the quotation to each element (tags, strings, etc) in the tag, moving top-down" } -{ $see-also xml-map xml-subset } ; - -HELP: xml-map -{ $values { "tag" tag } { "quot" "a quotation ( element -- element )" } - { "tag" "an XML tag with the quotation applied to each element" } } -{ $description "applies the quotation to each element (tags, strings, etc) in the tag, moving top-down, and produces a new tag" } -{ $see-also xml-each xml-subset } ; - -HELP: xml-subset -{ $values { "tag" tag } { "quot" "a quotation ( tag -- ? )" } - { "seq" "sequence of elements" } } -{ $description "applies the quotation to each element (tags, strings, etc) in the tag, moving top-down, producing a sequence of elements which do not return false for the sequence" } -{ $see-also xml-map xml-each } ; - HELP: build-tag* { $values { "items" "sequence of elements" } { "name" "string" } { "tag" tag } } @@ -166,15 +148,10 @@ HELP: xml-chunk { $description "rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." } { $see-also write-chunk read-xml } ; -HELP: xml-find -{ $values { "tag" "an XML element or document" } { "quot" "a quotation ( elem -- ? )" } { "tag" "an XML element which satisfies the predicate" } } -{ $description "finds the first element in the XML document which satisfies the predicate, moving from the outermost element to the innermost, top-down" } -{ $see-also xml-each xml-map get-id } ; - HELP: get-id { $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } } { $description "finds the XML tag with the specified id, ignoring the namespace" } -{ $see-also xml-find } ; +{ $see-also } ; HELP: process { $values { "object" "an opener, closer, contained or text element" } } @@ -242,15 +219,15 @@ HELP: write-chunk { $description "writes an XML document fragment, ie a sequence of XML elements, to the " { $link stdio } " stream." } { $see-also write-item write-xml } ; -HELP: tag-named* +HELP: deep-tag-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } } { $description "finds an XML tag with a matching name, recursively searching children and children of children" } -{ $see-also tags-named tag-named tags-named* } ; +{ $see-also tags-named tag-named deep-tags-named } ; -HELP: tags-named* +HELP: deep-tags-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } } { $description "returns a sequence of all tags of a matching name, recursively searching children and children of children" } -{ $see-also tag-named tag-named* tags-named } ; +{ $see-also tag-named deep-tag-named tags-named } ; HELP: children>string { $values { "tag" "an XML tag or document" } { "string" "a string" } } @@ -306,14 +283,14 @@ HELP: tag-named { "name/string" "an XML name or string representing the name" } { "matching-tag" tag } } { $description "finds the first tag with matching name which is the direct child of the given tag" } -{ $see-also tags-named* tag-named* tags-named } ; +{ $see-also deep-tags-named deep-tag-named tags-named } ; HELP: tags-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing the name" } { "tags-seq" "a sequence of tags" } } { $description "finds all tags with matching name that are the direct children of the given tag" } -{ $see-also tag-named* tags-named* tag-named } ; +{ $see-also deep-tag-named deep-tags-named tag-named } ; HELP: state-parse { $values { "stream" "an input stream" } { "quot" "a quotation ( -- )" } } @@ -390,18 +367,13 @@ ARTICLE: { "xml" "utils" } "XML processing utilities" "System sfor creating words which dispatch on XML tags:" { $subsection POSTPONE: PROCESS: } { $subsection POSTPONE: TAG: } - "Combinators for traversing XML trees:" - { $subsection xml-each } - { $subsection xml-map } - { $subsection xml-subset } - { $subsection xml-find } "Getting parts of an XML document or tag:" $nl - "Note: the difference between tag-named* and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." + "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." { $subsection tag-named } { $subsection tags-named } - { $subsection tag-named* } - { $subsection tags-named* } + { $subsection deep-tag-named } + { $subsection deep-tags-named } { $subsection get-id } "Words for simplified generation of XML:" { $subsection build-tag* } diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 8bcb9139a7..371560367f 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -9,7 +9,7 @@ TUPLE: result title url summary ; C: result : parse-yahoo ( xml -- seq ) - "Result" tags-named* [ + "Result" deep-tags-named [ { "Title" "Url" "Summary" } [ tag-named children>string ] curry* map first3 diff --git a/misc/factor.sh b/misc/factor.sh index 11ea2a9cdf..4913a57b75 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -152,6 +152,7 @@ echo_build_info() { echo FACTOR_BINARY=$FACTOR_BINARY echo MAKE_TARGET=$MAKE_TARGET echo BOOT_IMAGE=$BOOT_IMAGE + echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET } set_build_info() { @@ -164,11 +165,18 @@ set_build_info() { fi MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD BOOT_IMAGE=boot.$ARCH.$WORD.image if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH MAKE_TARGET=$OS-$ARCH BOOT_IMAGE=boot.macosx-ppc.image fi + if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.linux-ppc.image + fi } find_build_info() { @@ -266,16 +274,24 @@ update_bootstrap() { } refresh_image() { - ./$FACTOR_BINARY -e="refresh-all save 0 USE: system exit" + ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" + check_ret factor +} + +make_boot_image() { + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor + } install_libraries() { - sudo apt-get install libc6-dev libfreetype6-dev wget git-core git-doc libx11-dev glutg3-dev rlwrap + sudo apt-get install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap } case "$1" in install) install ;; install-x11) install_libraries; install ;; + self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; *) usage ;;