[
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 ;
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 }
! 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
[ <min-heap> heap-pop ] unit-test-fails
[ 0 ] [ <max-heap> heap-length ] unit-test
[ 1 ] [ <max-heap> 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
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 -- )
+
<PRIVATE
TUPLE: heap data ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
+INSTANCE: min-heap priority-queue
+INSTANCE: max-heap priority-queue
+
<PRIVATE
: left ( n -- m ) 2 * 1+ ; inline
: right ( n -- m ) 2 * 2 + ; inline
PRIVATE>
-: 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
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* ;
+
+M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
+
+M: priority-queue heap-length ( heap -- n ) heap-data length ;
-: heap-empty? ( heap -- ? ) heap-data empty? ;
+: (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 ;
-: heap-length ( heap -- n ) heap-data length ;
+M: priority-queue heap-pop-while ( heap pred quot -- )
+ [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;
C: <column> column
M: column virtual-seq column-seq ;
-M: column virtual@ dup column-col -rot column-seq nth ;
+M: column virtual@
+ dup column-col -rot column-seq nth bounds-check ;
M: column length column-seq length ;
INSTANCE: column virtual-sequence
: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
-: flip ( matrix -- newmatrix )
- dup empty? [
- dup first length [ <column> dup like ] curry* map
- ] unless ;
-
: exchange ( m n seq -- )
pick over bounds-check 2drop 2dup bounds-check 2drop
exchange-unsafe ;
: infimum ( seq -- n ) dup first [ min ] reduce ;
: supremum ( seq -- n ) dup first [ max ] reduce ;
+: flip ( matrix -- newmatrix )
+ dup empty? [
+ dup [ length ] map infimum
+ [ <column> dup like ] curry* map
+ ] unless ;
+
+: sequence-hashcode-step ( oldhash newpart -- newhash )
+ swap [
+ dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
+ fixnum+fast fixnum+fast
+ ] keep bitxor ; inline
+
: sequence-hashcode ( n seq -- x )
0 -rot [
- hashcode* >fixnum swap 31 fixnum*fast fixnum+fast
+ hashcode* >fixnum sequence-hashcode-step
] curry* each ; inline
$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."
--- /dev/null
+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 <assoc-min-heap> 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 <assoc-min-heap> 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 <assoc-min-heap>
+ 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
--- /dev/null
+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-heap
+
+: <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
+: <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
+
+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 ;
USING: delegate kernel arrays tools.test ;
+IN: temporary
TUPLE: hello this that ;
C: <hello> hello
over >r find r> rot 1+ tail ; inline
: tag-named? ( tag name -- ? )
- assure-name swap (get-tag) ;
+ assure-name swap tag-named? ;
! Questions
TUPLE: q/a question answer ;
! 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
! 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> ast-number
-
TUPLE: ast-identifier value vocab ;
-C: <ast-identifier> ast-identifier
-
TUPLE: ast-string value ;
-C: <ast-string> ast-string
-
TUPLE: ast-quotation values ;
-C: <ast-quotation> ast-quotation
-
TUPLE: ast-array elements ;
-C: <ast-array> ast-array
-
TUPLE: ast-define name stack-effect expression ;
-C: <ast-define> ast-define
-
TUPLE: ast-expression values ;
-C: <ast-expression> ast-expression
-
TUPLE: ast-word value vocab ;
-C: <ast-word> ast-word
-
TUPLE: ast-comment ;
-C: <ast-comment> ast-comment
-
TUPLE: ast-stack-effect in out ;
-C: <ast-stack-effect> ast-stack-effect
-
TUPLE: ast-use name ;
-C: <ast-use> ast-use
-
TUPLE: ast-using names ;
-C: <ast-using> ast-using
-
TUPLE: ast-in name ;
-C: <ast-in> ast-in
-
TUPLE: ast-hashtable elements ;
+
+C: <ast-number> ast-number
+C: <ast-identifier> ast-identifier
+C: <ast-string> ast-string
+C: <ast-quotation> ast-quotation
+C: <ast-array> ast-array
+C: <ast-define> ast-define
+C: <ast-expression> ast-expression
+C: <ast-word> ast-word
+C: <ast-comment> ast-comment
+C: <ast-stack-effect> ast-stack-effect
+C: <ast-use> ast-use
+C: <ast-using> ast-using
+C: <ast-in> ast-in
C: <ast-hashtable> ast-hashtable
: identifier-middle? ( ch -- bool )
digit? not
and and and and and ;
-LAZY: 'identifier-ends' ( -- parser )
+MEMO: 'identifier-ends' ( -- parser )
[
[ blank? not ] keep
[ CHAR: " = not ] keep
[ 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 <ast-identifier> ] <@ ;
+MEMO: 'identifier' ( -- parser )
+ [
+ 'identifier-ends' ,
+ 'identifier-middle' ,
+ 'identifier-ends' ,
+ ] { } make seq [
+ concat >string f <ast-identifier>
+ ] action ;
DEFER: 'expression'
-LAZY: 'effect-name' ( -- parser )
+MEMO: 'effect-name' ( -- parser )
[
[ blank? not ] keep
+ [ CHAR: ) = not ] keep
CHAR: - = not
- and
- ] satisfy <!+> [ >string ] <@ ;
-
-LAZY: 'stack-effect' ( -- parser )
- "(" token sp
- 'effect-name' sp <*> &>
- "--" token sp <&
- 'effect-name' sp <*> <&>
- ")" token sp <& [ first2 <ast-stack-effect> ] <@ ;
-
-LAZY: 'define' ( -- parser )
- ":" token sp
- 'identifier' sp [ ast-identifier-value ] <@ &>
- 'stack-effect' sp <!?> <&>
- 'expression' <:&>
- ";" token sp <& [ first3 <ast-define> ] <@ ;
-
-LAZY: 'quotation' ( -- parser )
- "[" token sp
- 'expression' [ ast-expression-values ] <@ &>
- "]" token sp <& [ <ast-quotation> ] <@ ;
-
-LAZY: 'array' ( -- parser )
- "{" token sp
- 'expression' [ ast-expression-values ] <@ &>
- "}" token sp <& [ <ast-array> ] <@ ;
-
-LAZY: 'word' ( -- parser )
- "\\" token sp
- 'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ;
-
-LAZY: 'atom' ( -- parser )
- 'identifier' 'integer' [ <ast-number> ] <@ <|> 'string' [ <ast-string> ] <@ <|> ;
-
-LAZY: 'comment' ( -- parser )
- "#!" token sp
- "!" token sp <|> [
- dup CHAR: \n = swap CHAR: \r = or not
- ] satisfy <*> <&> [ drop <ast-comment> ] <@ ;
-
-LAZY: 'USE:' ( -- parser )
- "USE:" token sp
- 'identifier' sp &> [ ast-identifier-value <ast-use> ] <@ ;
-
-LAZY: 'IN:' ( -- parser )
- "IN:" token sp
- 'identifier' sp &> [ ast-identifier-value <ast-in> ] <@ ;
-
-LAZY: 'USING:' ( -- parser )
- "USING:" token sp
- 'identifier' sp [ ast-identifier-value ] <@ <+> &>
- ";" token sp <& [ <ast-using> ] <@ ;
-
-LAZY: 'hashtable' ( -- parser )
- "H{" token sp
- 'expression' [ ast-expression-values ] <@ &>
- "}" token sp <& [ <ast-hashtable> ] <@ ;
-
-LAZY: 'parsing-word' ( -- parser )
- 'USE:'
- 'USING:' <|>
- 'IN:' <|> ;
-
-LAZY: 'expression' ( -- parser )
- 'comment'
- 'parsing-word' sp <|>
- 'quotation' sp <|>
- 'define' sp <|>
- 'array' sp <|>
- 'hashtable' sp <|>
- 'word' sp <|>
- 'atom' sp <|>
- <*> [ <ast-expression> ] <@ ;
-
-LAZY: 'statement' ( -- parser )
+ and and
+ ] satisfy repeat1 [ >string ] action ;
+
+MEMO: 'stack-effect' ( -- parser )
+ [
+ "(" token hide ,
+ 'effect-name' sp repeat0 ,
+ "--" token sp hide ,
+ 'effect-name' sp repeat0 ,
+ ")" token sp hide ,
+ ] { } make seq [
+ first2 <ast-stack-effect>
+ ] action ;
+
+MEMO: 'define' ( -- parser )
+ [
+ ":" token sp hide ,
+ 'identifier' sp [ ast-identifier-value ] action ,
+ 'stack-effect' sp optional ,
+ 'expression' ,
+ ";" token sp hide ,
+ ] { } make seq [ first3 <ast-define> ] action ;
+
+MEMO: 'quotation' ( -- parser )
+ [
+ "[" token sp hide ,
+ 'expression' [ ast-expression-values ] action ,
+ "]" token sp hide ,
+ ] { } make seq [ first <ast-quotation> ] action ;
+
+MEMO: 'array' ( -- parser )
+ [
+ "{" token sp hide ,
+ 'expression' [ ast-expression-values ] action ,
+ "}" token sp hide ,
+ ] { } make seq [ first <ast-array> ] action ;
+
+MEMO: 'word' ( -- parser )
+ [
+ "\\" token sp hide ,
+ 'identifier' sp ,
+ ] { } make seq [ first ast-identifier-value f <ast-word> ] action ;
+
+MEMO: 'atom' ( -- parser )
+ [
+ 'identifier' ,
+ 'integer' [ <ast-number> ] action ,
+ 'string' [ <ast-string> ] action ,
+ ] { } make choice ;
+
+MEMO: 'comment' ( -- parser )
+ [
+ [
+ "#!" token sp ,
+ "!" token sp ,
+ ] { } make choice hide ,
+ [
+ dup CHAR: \n = swap CHAR: \r = or not
+ ] satisfy repeat0 ,
+ ] { } make seq [ drop <ast-comment> ] action ;
+
+MEMO: 'USE:' ( -- parser )
+ [
+ "USE:" token sp hide ,
+ 'identifier' sp ,
+ ] { } make seq [ first ast-identifier-value <ast-use> ] action ;
+
+MEMO: 'IN:' ( -- parser )
+ [
+ "IN:" token sp hide ,
+ 'identifier' sp ,
+ ] { } make seq [ first ast-identifier-value <ast-in> ] action ;
+
+MEMO: 'USING:' ( -- parser )
+ [
+ "USING:" token sp hide ,
+ 'identifier' sp [ ast-identifier-value ] action repeat1 ,
+ ";" token sp hide ,
+ ] { } make seq [ first <ast-using> ] action ;
+
+MEMO: 'hashtable' ( -- parser )
+ [
+ "H{" token sp hide ,
+ 'expression' [ ast-expression-values ] action ,
+ "}" token sp hide ,
+ ] { } make seq [ first <ast-hashtable> ] action ;
+
+MEMO: 'parsing-word' ( -- parser )
+ [
+ 'USE:' ,
+ 'USING:' ,
+ 'IN:' ,
+ ] { } make choice ;
+
+MEMO: 'expression' ( -- parser )
+ [
+ [
+ 'comment' ,
+ 'parsing-word' sp ,
+ 'quotation' sp ,
+ 'define' sp ,
+ 'array' sp ,
+ 'hashtable' sp ,
+ 'word' sp ,
+ 'atom' sp ,
+ ] { } make choice repeat0 [ <ast-expression> ] action
+ ] delay ;
+
+MEMO: 'statement' ( -- parser )
'expression' ;
GENERIC: (compile) ( 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 )
[
] 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 ;
: 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 )
drop "Click done!" alert
] callcc0 ;
+: alert ( string -- )
+ #! Display the string in an alert box
+ window { } "" "alert" { "string" } alien-invoke ;
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 = [];
--- /dev/null
+Slava Pestov
+Doug Coleman
[
H{
{ "bar" "hello" }
- } \ foo query>quot
+ } \ foo query>seq
] with-scope
] unit-test
-! 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-redirect ( word quot -- )
- "action-redirect" set-word-prop ;
-
-: responder-vocab ( name -- vocab )
- "webapps." swap append ;
+: define-form ( word1 word2 hash -- )
+ dupd define-action
+ swap code>quotation "form-failed" set-word-prop ;
-: 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 ;
+: default-values ( word hash -- )
+ "default-values" set-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 )
[
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 ;
t register-html-callback
] if ;
-: render-link ( quot name -- )
- <a swap quot-link =href a> write </a> ;
+: 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 ;
+
+: page-submitted ( -- )
+ [ process-form ] [ request-params session> do-action ] if-form-page ;
+
+: 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 ;
-: call-action ( params action -- )
- dup "action-realm" word-prop [
- [ (call-action) ] with-basic-authentication
- ] [ (call-action) ] if* ;
+: 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 ;
-: service-request ( params url -- )
- current-action [
+: 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 ] [ <pre> print-error </pre> ] recover
] [
"404 no such action: " "argument" get append httpd-error
] if* ;
-: service-get ( url -- ) "query" get swap service-request ;
-
-: service-post ( url -- ) "response" get swap service-request ;
-
-: send-resource ( name -- )
- template-path get swap path+ resource-path <file-reader>
- stdio get stream-copy ;
+: service-get
+ "query" get swap service-request ;
-: render-template ( template -- )
- template-path get swap path+
- ".furnace" append resource-path
- run-template-file ;
+: service-post
+ "response" get swap service-request ;
-: 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 ;
<a f >vocab-link browser-link-href =href a>
"Browse source" write
</a> ;
+
+: send-resource ( name -- )
+ template-path get swap path+ resource-path <file-reader>
+ stdio get stream-copy ;
+
+: render-link ( quot name -- )
+ <a swap quot-link =href a> write </a> ;
+
+: 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 ;
+
--- /dev/null
+USING: assoc-heaps assocs calendar crypto.sha2 heaps
+init kernel math.parser namespaces random ;
+IN: furnace.sessions
+
+SYMBOL: sessions
+
+[
+ H{ } clone <min-heap> <assoc-heap>
+ 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 <=> ;
+
+: <session> ( -- obj )
+ now dup H{ } clone
+ [ set-session-created set-session-last-seen set-session-namespace ]
+ \ session construct ;
+
+: new-session ( -- obj id )
+ <session> 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 ;
USING: tools.deploy.config ;
H{
+ { deploy-c-types? f }
+ { deploy-ui? f }
+ { deploy-reflection 1 }
{ deploy-math? f }
- { deploy-word-defs? f }
{ deploy-word-props? f }
+ { deploy-word-defs? f }
{ deploy-name "Hello world (console)" }
{ "stop-after-last-window?" t }
- { deploy-c-types? f }
{ deploy-compiler? f }
{ deploy-io 2 }
- { deploy-ui? f }
- { deploy-reflection 1 }
}
: 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 ;
+
: run-template-file ( filename -- )
[
[
+ "quiet" on
file-vocabs
parser-notes off
templating-vocab use+
Chris Double
+Samuel Tardieu
Matthew Willis
{ $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 <lazy-subset> } " 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 <lazy-while> } " 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 <lazy-while> } " 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." }
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? ;
M: lazy-take list? ( object -- bool )
drop t ;
+TUPLE: lazy-until cons quot ;
+
+C: <lazy-until> lazy-until
+
+: luntil ( list quot -- result )
+ <lazy-until> ;
+
+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> lazy-while
+
+: lwhile ( list quot -- result )
+ <lazy-while>
+;
+
+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> lazy-subset
--- /dev/null
+Samuel Tardieu
--- /dev/null
+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" } "." } ;
--- /dev/null
+! 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
--- /dev/null
+! 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
+
+<PRIVATE
+
+TUPLE: erato limit bits latest ;
+
+: ind ( n -- i )
+ 2/ 1- ; inline
+
+: is-prime ( n erato -- bool )
+ >r ind r> erato-bits nth ; inline
+
+: indices ( n erato -- range )
+ erato-limit ind over 3 * ind swap rot <range> ;
+
+: mark-multiples ( n erato -- )
+ over sq over erato-limit <=
+ [ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ;
+
+: <erato> ( n -- erato )
+ dup ind 1+ <bit-array> 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 )
+ <erato> 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile ;
--- /dev/null
+Sieve of Eratosthene
+++ /dev/null
-! 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' [ \"<strong>\" swap \"</strong>\" 3append ] <@ replace ." "\"hello <strong>world</strong> from <strong>factor</strong>\"" }
-{ $example "USE: parser-combinators" "\"hello *world* from _factor_\"\n 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@\n 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ <|>\n replace ." "\"hello <strong>world</strong> from <emphasis>factor</emphasis>\"" }
-{ $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' [ \"<strong>\" swap \"</strong>\" 3append ] <@\n 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ 2array\n replace* ." "\"<strong>hello <emphasis>world</emphasis></strong>\"" }
-{ $see-also search search* replace* } ;
-
+++ /dev/null
-! 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
-
-: tree-write ( object -- )
- {
- { [ dup number? ] [ write1 ] }
- { [ dup string? ] [ write ] }
- { [ dup sequence? ] [ [ tree-write ] each ] }
- { [ t ] [ write ] }
- } cond ;
-
-: search ( string parser -- seq )
- any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
- drop { }
- ] [
- car parse-result-parsed [ ] subset
- ] 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 ;
-
-: replace ( string parser -- result )
- [ (replace) [ tree-write ] each ] string-out ;
-
-: replace* ( string parsers -- result )
- swap [ replace ] reduce ;
-
! 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> ] <@ ;
! 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 ;
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 ;
--- /dev/null
+Chris Double
--- /dev/null
+! 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 } ;
+
--- /dev/null
+! 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
+
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math io io.streams.string sequences strings
+combinators peg memoize arrays ;
+IN: peg.search
+
+: tree-write ( object -- )
+ {
+ { [ dup number? ] [ write1 ] }
+ { [ dup string? ] [ write ] }
+ { [ dup sequence? ] [ [ tree-write ] each ] }
+ { [ t ] [ write ] }
+ } cond ;
+
+MEMO: any-char-parser ( -- parser )
+ [ drop t ] satisfy ;
+
+: search ( string parser -- seq )
+ any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
+ parse-result-ast [ ] subset
+ ] [
+ drop { }
+ ] if ;
+
+
+: (replace) ( string parser -- seq )
+ any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ;
+
+: replace ( string parser -- result )
+ [ (replace) [ tree-write ] each ] string-out ;
+
+
--- /dev/null
+Search and replace using parsing expression grammars
--- /dev/null
+! 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 <range> sum 0 999 5 <range> sum + 0 999 15 <range> 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: max-palindrome ( seq -- palindrome )
+ natural-sort [ palindrome? ] find-last nip ;
+
+PRIVATE>
+
+: 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
+! --------
+
+<PRIVATE
+
+: source-008 ( -- str )
+ {
+ "73167176531330624919225119674426574742355349194934"
+ "96983520312774506326239578318016984801869478851843"
+ "85861560789112949495459501737958331952853208805511"
+ "12540698747158523863050715693290963295227443043557"
+ "66896648950445244523161731856403098711121722383113"
+ "62229893423380308135336276614282806444486645238749"
+ "30358907296290491560440772390713810515859307960866"
+ "70172427121883998797908792274921901699720888093776"
+ "65727333001053367881220235421809751254540594752243"
+ "52584907711670556013604839586446706324415722155397"
+ "53697817977846174064955149290862569321978468622482"
+ "83972241375657056057490261407972968652414535100474"
+ "82166370484403199890008895243450658541227588666881"
+ "16427171479924442928230863465674813919123162824586"
+ "17866458359124566529476545682848912883142607690042"
+ "24219022671055626321111109370544217506941658960408"
+ "07198403850962455444362981230987879927244284909188"
+ "84580156166097919133875499200524063689912560717606"
+ "05886116467109405077541002256983155200055935729725"
+ "71636269561882670428252483600823257530420752963450"
+ } concat ;
+
+PRIVATE>
+
+: 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
--- /dev/null
+! 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
+
+<PRIVATE
+
+: next-pq ( p1 q1 -- p2 q2 )
+ ! p > 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
--- /dev/null
+! 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
--- /dev/null
+! 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
+! --------
+
+<PRIVATE
+
+: horizontal ( -- matrix )
+ {
+ { 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 }
+ } ;
+
+: vertical ( -- matrix )
+ horizontal flip ;
+
+: pad-front ( matrix -- matrix )
+ [
+ length [ 0 <repetition> ] each
+ ] keep [ append ] map ;
+
+: pad-back ( matrix -- matrix )
+ <reversed> [
+ length [ 0 <repetition> ] each
+ ] keep [ <reversed> 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
--- /dev/null
+! 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
--- /dev/null
+! 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
+! --------
+
+<PRIVATE
+
+: source-013 ( -- seq )
+ {
+ 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
+ } ;
+
+PRIVATE>
+
+: 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
--- /dev/null
+! 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
+
+<PRIVATE
+
+: next-collatz ( n -- n )
+ dup even? [ 2 / ] [ 3 * 1+ ] if ;
+
+: longest ( seq seq -- seq )
+ 2dup length swap length > [ 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
+! -------------------
+
+<PRIVATE
+
+: worth-calculating? ( n -- ? )
+ {
+ [ dup 1- 3 mod zero? ]
+ [ dup 1- 3 / even? ]
+ } && nip ;
+
+PRIVATE>
+
+: 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
--- /dev/null
+! 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
+! --------
+
+<PRIVATE
+
+: grid-paths ( n -- n )
+ dup 2 * swap nCk ;
+
+PRIVATE>
+
+: euler015 ( -- answer )
+ 20 grid-paths ;
+
+! [ euler015 ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler015
--- /dev/null
+! 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
--- /dev/null
+! 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
+! --------
+
+<PRIVATE
+
+: units ( n -- )
+ {
+ "zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
+ "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
+ "seventeen" "eighteen" "nineteen"
+ } nth % ;
+
+: tenths ( n -- )
+ {
+ f f "twenty" "thirty" "fourty" "fifty" "sixty" "seventy" "eighty" "ninety"
+ } nth % ;
+
+DEFER: make-english
+
+: maybe-add ( n sep -- )
+ over 0 = [ 2drop ] [ % make-english ] if ;
+
+: 0-99 ( n -- )
+ dup 20 < [ units ] [ 10 /mod swap tenths "-" maybe-add ] if ;
+
+: 0-999 ( n -- )
+ 100 /mod swap
+ dup 0 = [ drop 0-99 ] [ units " hundred" % " and " maybe-add ] if ;
+
+: make-english ( n -- )
+ 1000 /mod swap
+ dup 0 = [ drop 0-999 ] [ 0-999 " thousand" % " and " maybe-add ] if ;
+
+PRIVATE>
+
+: >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
--- /dev/null
+Aaron Schaefer
--- /dev/null
+Aaron Schaefer
--- /dev/null
+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
--- /dev/null
+! 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
+
+<PRIVATE
+
+: clean-stack ( quot -- )
+ infer dup effect-out swap effect-in - [ drop ] times ;
+
+: ave-benchmarks ( seq -- pair )
+ flip [ mean round ] map ;
+
+PRIVATE>
+
+: 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
--- /dev/null
+Averaging code execution times
--- /dev/null
+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.
+
+<PRIVATE
+
+: count-shifts ( seq width -- n )
+ >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 * ;
--- /dev/null
+! 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
+
+<PRIVATE
+
+: problem-prompt ( -- n )
+ "Which problem number from Project Euler would you like to solve?"
+ print readln string>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
--- /dev/null
+Project Euler example solutions
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors ;
+USING: arrays math.parser sorting strings ;
IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: partition ( seq quot -- trueseq falseseq )
over >r 2pusher >r >r each r> r> r> drop ; inline
+
+: 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 ;
[
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
- deploy-name get
] bind
] keep stage2 open-in-explorer ;
! 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 ;
#! 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
: 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 }
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
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 ;
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 ;
<table>
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-
<tr>
<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
</tr>
<tr>
<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
+<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
</tr>
<tr>
<td><% "modes" render-template %></td>
</tr>
+<!--
+<tr>
+<th align="right">Channel:</th>
+<td><input type="TEXT" name="channel" value="#concatenative" /></td>
+</tr>
+-->
+
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
<tr>
<th align="right" valign="top">Content:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
</tr>
</table>
+<input type="hidden" name="n" value="<% "n" get number>string write %>" />
+<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
<input type="SUBMIT" value="Annotate" />
</form>
-<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %>
+<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
<select name="mode">
<% modes keys natural-sort [
- <option dup "factor" = [ "true" =selected ] when option> write </option>
+ <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
] each %>
</select>
-<% USING: furnace namespaces ; %>
+<% USING: continuations furnace namespaces ; %>
<%
"New paste" "title" set
<tr>
<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
</tr>
<tr>
<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
+<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
</tr>
<tr>
</tr>
-->
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
<tr>
<th align="right" valign="top">Content:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
</tr>
</table>
+<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
<input type="SUBMIT" value="Submit paste" />
</form>
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 ;
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 -- )
<annotation> 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
border: 1px solid #C1DAD7;
padding: 10px;
}
+
+.error {
+ color: red;
+}
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences sequences.private assocs arrays ;
+USING: kernel sequences sequences.private assocs arrays vectors ;
IN: xml.data
TUPLE: name space tag url ;
2dup attr@ nip [
2nip set-second
] [
- >r assure-name swap 2array r> push
+ [ >r assure-name swap 2array r> ?push ] keep
+ set-delegate
] if* ;
M: attrs assoc-size length ;
M: attrs >alist delegate >alist ;
: >attrs ( assoc -- attrs )
- V{ } assoc-clone-like
- [ >r assure-name r> ] assoc-map
- <attrs> ;
+ dup [
+ V{ } assoc-clone-like
+ [ >r assure-name r> ] assoc-map
+ ] when <attrs> ;
M: attrs assoc-like
drop dup attrs? [ >attrs ] unless ;
M: attrs clear-assoc
- delete-all ;
+ f swap set-delegate ;
M: attrs delete-at
tuck attr@ drop [ swap delete-nth ] [ drop ] if* ;
! 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 ;
+splitting vectors ;
IN: xml.utilities
! * System for words specialized on tag names
! * Common utility functions
: build-tag* ( items name -- tag )
- "" swap "" <name>
- swap >r { } r> <tag> ;
+ assure-name swap >r f r> <tag> ;
: build-tag ( item name -- tag )
>r 1array r> build-tag* ;
+: standard-prolog ( -- prolog )
+ T{ prolog f "1.0" "iso-8859-1" f } ;
+
: build-xml ( tag -- xml )
- T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
+ standard-prolog { } rot { } <xml> ;
: children>string ( tag -- string )
tag-children
GENERIC# xml-find 1 ( quot tag -- tag ) inline
M: tag xml-find
- [ call ] 2keep spin [
+ [ call ] 2keep swap rot [
f swap
[ nip over >r swap xml-find r> swap dup ] find
2drop ! leaves result of quot
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
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
- swap [
- dup tag?
- [ "id" swap at over = ]
- [ drop f ] if
- ] xml-find nip ;
-
-: (get-tag) ( name elem -- ? )
+: tag-named? ( name elem -- ? )
dup tag? [ names-match? ] [ 2drop f ] if ;
: tag-named* ( tag name/string -- matching-tag )
- assure-name swap [ dupd (get-tag) ] xml-find nip ;
+ assure-name swap [ dupd tag-named? ] xml-find nip ;
: tags-named* ( tag name/string -- tags-seq )
- assure-name swap [ dupd (get-tag) ] xml-subset nip ;
+ assure-name swap [ dupd tag-named? ] xml-subset nip ;
: 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 [ (get-tag) ] curry* find nip ;
+ assure-name swap [ tag-named? ] curry* find nip ;
: tags-named ( tag name/string -- tags-seq )
- assure-name swap [ (get-tag) ] curry* subset ;
+ assure-name swap [ tag-named? ] curry* subset ;
: assert-tag ( name name -- )
names-match? [ "Unexpected XML tag found" throw ] unless ;
+
+: insert-children ( children tag -- )
+ dup tag-children [ push-all ]
+ [ >r V{ } like r> set-tag-children ] if ;
+
+: 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 ;
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() {
echo "OS, ARCH, or WORD is empty. Please report this"
exit 5
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() {
}
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 ;;
projects / factor.git / commitdiff