Merge commit 'slava/master'
commit
0de2e117f5
|
@ -1,7 +1,8 @@
|
|||
! Copyright 2007 Ryan Murphy
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel math tools.test heaps heaps.private ;
|
||||
USING: arrays kernel math namespaces tools.test
|
||||
heaps heaps.private ;
|
||||
IN: temporary
|
||||
|
||||
[ <min-heap> heap-pop ] unit-test-fails
|
||||
|
@ -33,3 +34,16 @@ IN: temporary
|
|||
|
||||
[ 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
|
||||
|
|
|
@ -3,6 +3,19 @@
|
|||
USING: kernel math sequences arrays assocs ;
|
||||
IN: heaps
|
||||
|
||||
MIXIN: priority-queue
|
||||
|
||||
GENERIC: heap-push ( value key heap -- )
|
||||
GENERIC: heap-push-all ( assoc heap -- )
|
||||
GENERIC: heap-peek ( heap -- value key )
|
||||
GENERIC: heap-pop* ( heap -- )
|
||||
GENERIC: heap-pop ( heap -- value key )
|
||||
GENERIC: heap-delete ( key heap -- )
|
||||
GENERIC: heap-delete* ( key heap -- old ? )
|
||||
GENERIC: heap-empty? ( heap -- ? )
|
||||
GENERIC: heap-length ( heap -- n )
|
||||
GENERIC# heap-pop-while 2 ( heap pred quot -- )
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: heap data ;
|
||||
|
||||
|
@ -19,6 +32,9 @@ TUPLE: max-heap ;
|
|||
|
||||
: <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
|
||||
|
@ -85,19 +101,19 @@ DEFER: down-heap
|
|||
|
||||
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
|
||||
|
@ -106,8 +122,19 @@ PRIVATE>
|
|||
heap-data pop*
|
||||
] if ;
|
||||
|
||||
: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
|
||||
M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
|
||||
|
||||
: heap-empty? ( heap -- ? ) heap-data empty? ;
|
||||
M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
|
||||
|
||||
: heap-length ( heap -- n ) heap-data length ;
|
||||
M: priority-queue heap-length ( heap -- n ) heap-data length ;
|
||||
|
||||
: (heap-pop-while) ( heap pred quot -- )
|
||||
pick heap-empty? [
|
||||
3drop
|
||||
] [
|
||||
[ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
|
||||
roll [ (heap-pop-while) ] [ 3drop ] if
|
||||
] if ;
|
||||
|
||||
M: priority-queue heap-pop-while ( heap pred quot -- )
|
||||
[ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;
|
||||
|
|
|
@ -0,0 +1,46 @@
|
|||
USING: assocs assoc-heaps heaps heaps.private kernel tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[
|
||||
T{
|
||||
assoc-heap
|
||||
f
|
||||
H{ { 2 1 } }
|
||||
T{ min-heap T{ heap f V{ { 1 2 } } } }
|
||||
}
|
||||
] [ H{ } clone <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
|
|
@ -0,0 +1,48 @@
|
|||
USING: assocs heaps kernel sequences ;
|
||||
IN: assoc-heaps
|
||||
|
||||
TUPLE: assoc-heap assoc heap ;
|
||||
|
||||
INSTANCE: assoc-heap assoc
|
||||
INSTANCE: assoc-heap priority-queue
|
||||
|
||||
C: <assoc-heap> assoc-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 ;
|
|
@ -1,4 +1,5 @@
|
|||
USING: delegate kernel arrays tools.test ;
|
||||
IN: temporary
|
||||
|
||||
TUPLE: hello this that ;
|
||||
C: <hello> hello
|
||||
|
|
|
@ -1,54 +1,54 @@
|
|||
! Copyright (C) 2006 Chris Double. All Rights Reserved.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.test parser-combinators lazy-lists fjsc ;
|
||||
USING: kernel tools.test peg fjsc ;
|
||||
IN: temporary
|
||||
|
||||
{ T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
|
||||
"55 2abc1 100" 'expression' parse-1
|
||||
{ T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
|
||||
"55 2abc1 100" 'expression' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
|
||||
"[ 55 2abc1 100 ]" 'quotation' parse-1
|
||||
{ T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
|
||||
"[ 55 2abc1 100 ]" 'quotation' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
|
||||
"{ 55 2abc1 100 }" 'array' parse-1
|
||||
{ T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
|
||||
"{ 55 2abc1 100 }" 'array' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-stack-effect f { } { "d" "e" "f" } } } [
|
||||
"( -- d e f )" 'stack-effect' parse-1
|
||||
{ T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [
|
||||
"( -- d e f )" 'stack-effect' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [
|
||||
"( a b c -- d e f )" 'stack-effect' parse-1
|
||||
{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [
|
||||
"( a b c -- d e f )" 'stack-effect' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-stack-effect f { "a" "b" "c" } { } } } [
|
||||
"( a b c -- )" 'stack-effect' parse-1
|
||||
{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [
|
||||
"( a b c -- )" 'stack-effect' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-stack-effect f { } { } } } [
|
||||
"( -- )" 'stack-effect' parse-1
|
||||
{ T{ ast-stack-effect f V{ } V{ } } } [
|
||||
"( -- )" 'stack-effect' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ } [
|
||||
": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop
|
||||
{ f } [
|
||||
": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse not
|
||||
] unit-test
|
||||
|
||||
|
||||
{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [
|
||||
"\"abcd\"" 'statement' parse-1
|
||||
{ T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [
|
||||
"\"abcd\"" 'statement' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-expression f { T{ ast-use f "foo" } } } } [
|
||||
"USE: foo" 'statement' parse-1
|
||||
{ T{ ast-expression f V{ T{ ast-use f "foo" } } } } [
|
||||
"USE: foo" 'statement' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-expression f { T{ ast-in f "foo" } } } } [
|
||||
"IN: foo" 'statement' parse-1
|
||||
{ T{ ast-expression f V{ T{ ast-in f "foo" } } } } [
|
||||
"IN: foo" 'statement' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [
|
||||
"USING: foo bar ;" 'statement' parse-1
|
||||
{ T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [
|
||||
"USING: foo bar ;" 'statement' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -1,50 +1,38 @@
|
|||
! Copyright (C) 2006 Chris Double. All Rights Reserved.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel lazy-lists parser-combinators parser-combinators.simple
|
||||
strings promises sequences math math.parser namespaces words
|
||||
quotations arrays hashtables io io.streams.string assocs ;
|
||||
USING: kernel peg strings promises sequences math math.parser
|
||||
namespaces words quotations arrays hashtables io
|
||||
io.streams.string assocs memoize ;
|
||||
IN: fjsc
|
||||
|
||||
TUPLE: ast-number value ;
|
||||
C: <ast-number> 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 )
|
||||
|
@ -56,7 +44,7 @@ C: <ast-hashtable> ast-hashtable
|
|||
digit? not
|
||||
and and and and and ;
|
||||
|
||||
LAZY: 'identifier-ends' ( -- parser )
|
||||
MEMO: 'identifier-ends' ( -- parser )
|
||||
[
|
||||
[ blank? not ] keep
|
||||
[ CHAR: " = not ] keep
|
||||
|
@ -65,99 +53,137 @@ LAZY: 'identifier-ends' ( -- parser )
|
|||
[ letter? not ] keep
|
||||
identifier-middle? not
|
||||
and and and and and
|
||||
] satisfy <!*> ;
|
||||
] satisfy repeat0 ;
|
||||
|
||||
LAZY: 'identifier-middle' ( -- parser )
|
||||
[ identifier-middle? ] satisfy <!+> ;
|
||||
MEMO: 'identifier-middle' ( -- parser )
|
||||
[ identifier-middle? ] satisfy repeat1 ;
|
||||
|
||||
LAZY: 'identifier' ( -- parser )
|
||||
'identifier-ends'
|
||||
'identifier-middle' <&>
|
||||
'identifier-ends' <:&>
|
||||
[ concat >string f <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 ] <@ ;
|
||||
and and
|
||||
] satisfy repeat1 [ >string ] action ;
|
||||
|
||||
LAZY: 'stack-effect' ( -- parser )
|
||||
"(" token sp
|
||||
'effect-name' sp <*> &>
|
||||
"--" token sp <&
|
||||
'effect-name' sp <*> <&>
|
||||
")" token sp <& [ first2 <ast-stack-effect> ] <@ ;
|
||||
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 ;
|
||||
|
||||
LAZY: 'define' ( -- parser )
|
||||
":" token sp
|
||||
'identifier' sp [ ast-identifier-value ] <@ &>
|
||||
'stack-effect' sp <!?> <&>
|
||||
'expression' <:&>
|
||||
";" token sp <& [ first3 <ast-define> ] <@ ;
|
||||
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 ;
|
||||
|
||||
LAZY: 'quotation' ( -- parser )
|
||||
"[" token sp
|
||||
'expression' [ ast-expression-values ] <@ &>
|
||||
"]" token sp <& [ <ast-quotation> ] <@ ;
|
||||
MEMO: 'quotation' ( -- parser )
|
||||
[
|
||||
"[" token sp hide ,
|
||||
'expression' [ ast-expression-values ] action ,
|
||||
"]" token sp hide ,
|
||||
] { } make seq [ first <ast-quotation> ] action ;
|
||||
|
||||
LAZY: 'array' ( -- parser )
|
||||
"{" token sp
|
||||
'expression' [ ast-expression-values ] <@ &>
|
||||
"}" token sp <& [ <ast-array> ] <@ ;
|
||||
MEMO: 'array' ( -- parser )
|
||||
[
|
||||
"{" token sp hide ,
|
||||
'expression' [ ast-expression-values ] action ,
|
||||
"}" token sp hide ,
|
||||
] { } make seq [ first <ast-array> ] action ;
|
||||
|
||||
LAZY: 'word' ( -- parser )
|
||||
"\\" token sp
|
||||
'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ;
|
||||
MEMO: 'word' ( -- parser )
|
||||
[
|
||||
"\\" token sp hide ,
|
||||
'identifier' sp ,
|
||||
] { } make seq [ first ast-identifier-value f <ast-word> ] action ;
|
||||
|
||||
LAZY: 'atom' ( -- parser )
|
||||
'identifier' 'integer' [ <ast-number> ] <@ <|> 'string' [ <ast-string> ] <@ <|> ;
|
||||
MEMO: 'atom' ( -- parser )
|
||||
[
|
||||
'identifier' ,
|
||||
'integer' [ <ast-number> ] action ,
|
||||
'string' [ <ast-string> ] action ,
|
||||
] { } make choice ;
|
||||
|
||||
LAZY: 'comment' ( -- parser )
|
||||
"#!" token sp
|
||||
"!" token sp <|> [
|
||||
dup CHAR: \n = swap CHAR: \r = or not
|
||||
] satisfy <*> <&> [ drop <ast-comment> ] <@ ;
|
||||
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 ;
|
||||
|
||||
LAZY: 'USE:' ( -- parser )
|
||||
"USE:" token sp
|
||||
'identifier' sp &> [ ast-identifier-value <ast-use> ] <@ ;
|
||||
MEMO: 'USE:' ( -- parser )
|
||||
[
|
||||
"USE:" token sp hide ,
|
||||
'identifier' sp ,
|
||||
] { } make seq [ first ast-identifier-value <ast-use> ] action ;
|
||||
|
||||
LAZY: 'IN:' ( -- parser )
|
||||
"IN:" token sp
|
||||
'identifier' sp &> [ ast-identifier-value <ast-in> ] <@ ;
|
||||
MEMO: 'IN:' ( -- parser )
|
||||
[
|
||||
"IN:" token sp hide ,
|
||||
'identifier' sp ,
|
||||
] { } make seq [ first ast-identifier-value <ast-in> ] action ;
|
||||
|
||||
LAZY: 'USING:' ( -- parser )
|
||||
"USING:" token sp
|
||||
'identifier' sp [ ast-identifier-value ] <@ <+> &>
|
||||
";" token sp <& [ <ast-using> ] <@ ;
|
||||
MEMO: 'USING:' ( -- parser )
|
||||
[
|
||||
"USING:" token sp hide ,
|
||||
'identifier' sp [ ast-identifier-value ] action repeat1 ,
|
||||
";" token sp hide ,
|
||||
] { } make seq [ first <ast-using> ] action ;
|
||||
|
||||
LAZY: 'hashtable' ( -- parser )
|
||||
"H{" token sp
|
||||
'expression' [ ast-expression-values ] <@ &>
|
||||
"}" token sp <& [ <ast-hashtable> ] <@ ;
|
||||
MEMO: 'hashtable' ( -- parser )
|
||||
[
|
||||
"H{" token sp hide ,
|
||||
'expression' [ ast-expression-values ] action ,
|
||||
"}" token sp hide ,
|
||||
] { } make seq [ first <ast-hashtable> ] action ;
|
||||
|
||||
LAZY: 'parsing-word' ( -- parser )
|
||||
'USE:'
|
||||
'USING:' <|>
|
||||
'IN:' <|> ;
|
||||
MEMO: 'parsing-word' ( -- parser )
|
||||
[
|
||||
'USE:' ,
|
||||
'USING:' ,
|
||||
'IN:' ,
|
||||
] { } make choice ;
|
||||
|
||||
LAZY: 'expression' ( -- parser )
|
||||
'comment'
|
||||
'parsing-word' sp <|>
|
||||
'quotation' sp <|>
|
||||
'define' sp <|>
|
||||
'array' sp <|>
|
||||
'hashtable' sp <|>
|
||||
'word' sp <|>
|
||||
'atom' sp <|>
|
||||
<*> [ <ast-expression> ] <@ ;
|
||||
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 ;
|
||||
|
||||
LAZY: 'statement' ( -- parser )
|
||||
MEMO: 'statement' ( -- parser )
|
||||
'expression' ;
|
||||
|
||||
GENERIC: (compile) ( ast -- )
|
||||
|
@ -328,7 +354,7 @@ M: wrapper (parse-factor-quotation) ( object -- ast )
|
|||
GENERIC: fjsc-parse ( object -- ast )
|
||||
|
||||
M: string fjsc-parse ( object -- ast )
|
||||
'expression' parse-1 ;
|
||||
'expression' parse parse-result-ast ;
|
||||
|
||||
M: quotation fjsc-parse ( object -- ast )
|
||||
[
|
||||
|
@ -345,11 +371,11 @@ M: quotation fjsc-parse ( object -- ast )
|
|||
] string-out ;
|
||||
|
||||
: fjsc-compile* ( string -- string )
|
||||
'statement' parse-1 fjsc-compile ;
|
||||
'statement' parse parse-result-ast fjsc-compile ;
|
||||
|
||||
: fc* ( string -- string )
|
||||
[
|
||||
'statement' parse-1 ast-expression-values do-expressions
|
||||
'statement' parse parse-result-ast ast-expression-values do-expressions
|
||||
] { } make [ write ] each ;
|
||||
|
||||
|
||||
|
|
|
@ -3,10 +3,6 @@ USE: kernel-internals
|
|||
: bind ( ns quot -- )
|
||||
swap >n call n> drop ;
|
||||
|
||||
: alert ( string -- )
|
||||
#! Display the string in an alert box
|
||||
window { } "" "alert" { "string" } alien-invoke ;
|
||||
|
||||
"browser-dom" set-in
|
||||
|
||||
: elements ( string -- result )
|
||||
|
@ -38,3 +34,6 @@ USE: kernel-internals
|
|||
drop "Click done!" alert
|
||||
] callcc0 ;
|
||||
|
||||
: alert ( string -- )
|
||||
#! Display the string in an alert box
|
||||
window { } "" "alert" { "string" } alien-invoke ;
|
||||
|
|
|
@ -513,6 +513,12 @@ factor.add_word("alien", "set-alien-property", "primitive", function(next) {
|
|||
factor.call_next(next);
|
||||
});
|
||||
|
||||
factor.add_word("alien", "uneval", "primitive", function(next) {
|
||||
var stack = factor.cont.data_stack;
|
||||
stack.push(uneval(stack.pop()));
|
||||
factor.call_next(next);
|
||||
});
|
||||
|
||||
factor.add_word("words", "vocabs", "primitive", function(next) {
|
||||
var stack = factor.cont.data_stack;
|
||||
var result = [];
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2006 Slava Pestov, Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs debugger furnace.sessions furnace.validator
|
||||
hashtables html.elements http http.server.responders
|
||||
http.server.templating
|
||||
io.files kernel namespaces quotations sequences splitting words
|
||||
strings vectors webapps.callback ;
|
||||
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
|
||||
|
||||
|
@ -57,13 +57,17 @@ SYMBOL: validation-errors
|
|||
] 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 ] [ "furnace-session-id" over delete-at lookup-session ] if*
|
||||
"furnace-session-id" over at sessions get-global at [
|
||||
nip
|
||||
] [
|
||||
drop new-session rot "furnace-session-id" swap set-at
|
||||
] if ;
|
||||
new-session rot "furnace-session-id" swap set-at
|
||||
] if* ;
|
||||
|
||||
: quot>query ( seq action -- hash )
|
||||
>r >array r> "action-params" word-prop
|
||||
|
|
|
@ -1,15 +1,23 @@
|
|||
USING: assocs calendar init kernel math.parser namespaces random ;
|
||||
USING: assoc-heaps assocs calendar crypto.sha2 heaps
|
||||
init kernel math.parser namespaces random ;
|
||||
IN: furnace.sessions
|
||||
|
||||
SYMBOL: sessions
|
||||
|
||||
[ H{ } clone sessions set-global ] "furnace.sessions" add-init-hook
|
||||
[
|
||||
H{ } clone <min-heap> <assoc-heap>
|
||||
sessions set-global
|
||||
] "furnace.sessions" add-init-hook
|
||||
|
||||
: new-session-id ( -- str )
|
||||
1 big-random number>string ;
|
||||
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 ]
|
||||
|
@ -21,8 +29,9 @@ TUPLE: session created last-seen user-agent namespace ;
|
|||
: 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 delete-at ;
|
||||
sessions get-global assoc-heap-assoc delete-at ;
|
||||
|
||||
: session> ( str -- obj )
|
||||
session get session-namespace at ;
|
||||
|
|
|
@ -76,6 +76,7 @@ DEFER: <% delimiter
|
|||
: run-template-file ( filename -- )
|
||||
[
|
||||
[
|
||||
"quiet" on
|
||||
file-vocabs
|
||||
parser-notes off
|
||||
templating-vocab use+
|
||||
|
|
|
@ -1,2 +1,3 @@
|
|||
Chris Double
|
||||
Samuel Tardieu
|
||||
Matthew Willis
|
||||
|
|
|
@ -114,6 +114,16 @@ HELP: lsubset
|
|||
{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <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." }
|
||||
|
|
|
@ -100,11 +100,7 @@ M: lazy-cons list? ( object -- bool )
|
|||
dup car swap cdr ;
|
||||
|
||||
: leach ( list quot -- )
|
||||
swap dup nil? [
|
||||
2drop
|
||||
] [
|
||||
uncons swap pick call swap leach
|
||||
] if ;
|
||||
swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
|
||||
|
||||
TUPLE: memoized-cons original car cdr nil? ;
|
||||
|
||||
|
@ -210,6 +206,48 @@ M: lazy-take nil? ( lazy-take -- bool )
|
|||
M: lazy-take list? ( object -- bool )
|
||||
drop t ;
|
||||
|
||||
TUPLE: lazy-until cons quot ;
|
||||
|
||||
C: <lazy-until> 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
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Samuel Tardieu
|
|
@ -0,0 +1,6 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: math.erato
|
||||
|
||||
HELP: lerato
|
||||
{ $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } }
|
||||
{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive). Lazy lists are described in " { $link "lazy-lists" } "." } ;
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists math.erato tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bit-arrays kernel lazy-lists math math.functions math.ranges sequences ;
|
||||
IN: math.erato
|
||||
|
||||
<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 ;
|
|
@ -0,0 +1 @@
|
|||
Sieve of Eratosthene
|
|
@ -1,76 +0,0 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup parser-combinators
|
||||
parser-combinators.replace ;
|
||||
|
||||
HELP: tree-write
|
||||
{ $values
|
||||
{ "object" "an object" } }
|
||||
{ $description
|
||||
"Write the object to the standard output stream, unless "
|
||||
"it is an array, in which case recurse through the array "
|
||||
"writing each object to the stream." }
|
||||
{ $example "USE: parser-combinators" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ;
|
||||
|
||||
HELP: search
|
||||
{ $values
|
||||
{ "string" "a string" }
|
||||
{ "parser" "a parser combinator based parser" }
|
||||
{ "seq" "a sequence" }
|
||||
}
|
||||
{ $description
|
||||
"Returns a sequence containing the parse results of all substrings "
|
||||
"from the input string that successfully parse using the "
|
||||
"parser."
|
||||
}
|
||||
|
||||
{ $example "USE: parser-combinators" "\"one 123 two 456\" 'integer' search ." "{ 123 456 }" }
|
||||
{ $example "USE: parser-combinators" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' <|> search ." "{ 123 \"hello\" 456 }" }
|
||||
{ $see-also search* replace replace* } ;
|
||||
|
||||
HELP: search*
|
||||
{ $values
|
||||
{ "string" "a string" }
|
||||
{ "parsers" "a sequence of parser combinator based parsers" }
|
||||
{ "seq" "a sequence" }
|
||||
}
|
||||
{ $description
|
||||
"Returns a sequence containing the parse results of all substrings "
|
||||
"from the input string that successfully parse using any of the "
|
||||
"parsers in the 'parsers' sequence."
|
||||
}
|
||||
|
||||
{ $example "USE: parser-combinators" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array search* ." "{ 123 \"hello\" 456 }" }
|
||||
{ $see-also search replace replace* } ;
|
||||
|
||||
HELP: replace
|
||||
{ $values
|
||||
{ "string" "a string" }
|
||||
{ "parser" "a parser combinator based parser" }
|
||||
{ "result" "a string" }
|
||||
}
|
||||
{ $description
|
||||
"Returns a copy of the original string but with all substrings that "
|
||||
"successfully parse with the given parser replaced with "
|
||||
"the result of that parser."
|
||||
}
|
||||
{ $example "USING: parser-combinators math.parser ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] <@ replace ." "\"one 246 two 912\"" }
|
||||
{ $example "USE: parser-combinators" "\"hello *world* from *factor*\" 'bold' [ \"<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* } ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel strings math sequences lazy-lists words
|
||||
math.parser promises ;
|
||||
IN: parser-combinators
|
||||
math.parser promises parser-combinators ;
|
||||
IN: parser-combinators.simple
|
||||
|
||||
: 'digit' ( -- parser )
|
||||
[ digit? ] satisfy [ digit> ] <@ ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
parsing
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences strings namespaces math assocs shuffle
|
||||
vectors arrays combinators.lib memoize ;
|
||||
vectors arrays combinators.lib memoize math.parser ;
|
||||
IN: peg
|
||||
|
||||
TUPLE: parse-result remaining ast ;
|
||||
|
@ -265,3 +265,16 @@ MEMO: delay ( parser -- parser )
|
|||
|
||||
MEMO: list-of ( items separator -- parser )
|
||||
hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ;
|
||||
|
||||
MEMO: 'digit' ( -- parser )
|
||||
[ digit? ] satisfy [ digit> ] action ;
|
||||
|
||||
MEMO: 'integer' ( -- parser )
|
||||
'digit' repeat1 [ 10 swap digits>integer ] action ;
|
||||
|
||||
MEMO: 'string' ( -- parser )
|
||||
[
|
||||
[ CHAR: " = ] satisfy hide ,
|
||||
[ CHAR: " = not ] satisfy repeat0 ,
|
||||
[ CHAR: " = ] satisfy hide ,
|
||||
] { } make seq [ first >string ] action ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
parsing
|
|
@ -0,0 +1 @@
|
|||
Chris Double
|
|
@ -0,0 +1,43 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup peg peg.search ;
|
||||
|
||||
HELP: tree-write
|
||||
{ $values
|
||||
{ "object" "an object" } }
|
||||
{ $description
|
||||
"Write the object to the standard output stream, unless "
|
||||
"it is an array, in which case recurse through the array "
|
||||
"writing each object to the stream." }
|
||||
{ $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ;
|
||||
|
||||
HELP: search
|
||||
{ $values
|
||||
{ "string" "a string" }
|
||||
{ "parser" "a peg based parser" }
|
||||
{ "seq" "a sequence" }
|
||||
}
|
||||
{ $description
|
||||
"Returns a sequence containing the parse results of all substrings "
|
||||
"from the input string that successfully parse using the "
|
||||
"parser."
|
||||
}
|
||||
|
||||
{ $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" }
|
||||
{ $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" }
|
||||
{ $see-also replace } ;
|
||||
|
||||
HELP: replace
|
||||
{ $values
|
||||
{ "string" "a string" }
|
||||
{ "parser" "a peg based parser" }
|
||||
{ "result" "a string" }
|
||||
}
|
||||
{ $description
|
||||
"Returns a copy of the original string but with all substrings that "
|
||||
"successfully parse with the given parser replaced with "
|
||||
"the result of that parser."
|
||||
}
|
||||
{ $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" }
|
||||
{ $see-also search } ;
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel math math.parser arrays tools.test peg peg.search ;
|
||||
IN: temporary
|
||||
|
||||
{ V{ 123 456 } } [
|
||||
"abc 123 def 456" 'integer' search
|
||||
] unit-test
|
||||
|
||||
{ V{ 123 "hello" 456 } } [
|
||||
"one 123 \"hello\" two 456" 'integer' 'string' 2array choice search
|
||||
] unit-test
|
||||
|
||||
{ "abc 246 def 912" } [
|
||||
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
|
||||
] unit-test
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math io io.streams.string sequences strings
|
||||
lazy-lists combinators parser-combinators.simple ;
|
||||
IN: parser-combinators
|
||||
combinators peg memoize arrays ;
|
||||
IN: peg.search
|
||||
|
||||
: tree-write ( object -- )
|
||||
{
|
||||
|
@ -12,26 +12,21 @@ IN: parser-combinators
|
|||
{ [ t ] [ write ] }
|
||||
} cond ;
|
||||
|
||||
MEMO: any-char-parser ( -- parser )
|
||||
[ drop t ] satisfy ;
|
||||
|
||||
: search ( string parser -- seq )
|
||||
any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
|
||||
drop { }
|
||||
any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
|
||||
parse-result-ast [ ] subset
|
||||
] [
|
||||
car parse-result-parsed [ ] subset
|
||||
drop { }
|
||||
] if ;
|
||||
|
||||
: search* ( string parsers -- seq )
|
||||
unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
|
||||
drop { }
|
||||
] [
|
||||
car parse-result-parsed [ ] subset
|
||||
] if ;
|
||||
|
||||
: (replace) ( string parser -- seq )
|
||||
any-char-parser <|> <*> parse-1 ;
|
||||
any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ;
|
||||
|
||||
: replace ( string parser -- result )
|
||||
[ (replace) [ tree-write ] each ] string-out ;
|
||||
|
||||
: replace* ( string parsers -- result )
|
||||
swap [ replace ] reduce ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Search and replace using parsing expression grammars
|
|
@ -0,0 +1 @@
|
|||
parsing
|
|
@ -0,0 +1 @@
|
|||
parsing
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.ranges sequences ;
|
||||
IN: project-euler.001
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=1
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! If we list all the natural numbers below 10 that are multiples of 3 or 5, we
|
||||
! get 3, 5, 6 and 9. The sum of these multiples is 23.
|
||||
|
||||
! Find the sum of all the multiples of 3 or 5 below 1000.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
! Inclusion-exclusion principle
|
||||
|
||||
: euler001 ( -- answer )
|
||||
0 999 3 <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
|
|
@ -0,0 +1,34 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences ;
|
||||
IN: project-euler.002
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=2
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! Each new term in the Fibonacci sequence is generated by adding the previous
|
||||
! two terms. By starting with 1 and 2, the first 10 terms will be:
|
||||
|
||||
! 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
|
||||
|
||||
! Find the sum of all the even-valued terms in the sequence which do not exceed one million.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: last2 ( seq -- elt last )
|
||||
reverse first2 swap ;
|
||||
|
||||
: fib-up-to ( n -- seq )
|
||||
{ 0 } 1 [ pick dupd < ] [ add dup last2 + ] [ ] while drop nip ;
|
||||
|
||||
: euler002 ( -- answer )
|
||||
1000000 fib-up-to [ even? ] subset sum ;
|
||||
|
||||
! [ euler002 ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
|
||||
MAIN: euler002
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math project-euler.common sequences ;
|
||||
IN: project-euler.003
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=3
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! The prime factors of 13195 are 5, 7, 13 and 29.
|
||||
|
||||
! What is the largest prime factor of the number 317584931803?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: largest-prime-factor ( n -- factor )
|
||||
prime-factors supremum ;
|
||||
|
||||
: euler003 ( -- answer )
|
||||
317584931803 largest-prime-factor ;
|
||||
|
||||
! [ euler003 ] 100 ave-time
|
||||
! 404 ms run / 9 ms GC ave time - 100 trials
|
||||
|
||||
MAIN: euler003
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators.lib hashtables kernel math math.parser math.ranges
|
||||
sequences sorting ;
|
||||
IN: project-euler.004
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=4
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! A palindromic number reads the same both ways. The largest palindrome made
|
||||
! from the product of two 2-digit numbers is 9009 = 91 * 99.
|
||||
|
||||
! Find the largest palindrome made from the product of two 3-digit numbers.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: palindrome? ( n -- ? )
|
||||
number>string dup reverse = ;
|
||||
|
||||
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
|
||||
swap [ swap [ 2array ] map-with ] map-with concat ;
|
||||
|
||||
<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
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions sequences ;
|
||||
IN: project-euler.005
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=5
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! 2520 is the smallest number that can be divided by each of the numbers from 1
|
||||
! to 10 without any remainder.
|
||||
|
||||
! What is the smallest number that is evenly divisible by all of the numbers from 1 to 20?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: euler005 ( -- answer )
|
||||
20 1 [ 1+ lcm ] reduce ;
|
||||
|
||||
! [ euler005 ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
|
||||
MAIN: euler005
|
|
@ -0,0 +1,39 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.ranges sequences ;
|
||||
IN: project-euler.006
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=6
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! The sum of the squares of the first ten natural numbers is,
|
||||
! 1² + 2² + ... + 10² = 385
|
||||
|
||||
! The square of the sum of the first ten natural numbers is,
|
||||
! (1 + 2 + ... + 10)² = 55² = 3025
|
||||
|
||||
! Hence the difference between the sum of the squares of the first ten natural
|
||||
! numbers and the square of the sum is 3025 385 = 2640.
|
||||
|
||||
! Find the difference between the sum of the squares of the first one hundred
|
||||
! natural numbers and the square of the sum.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: sum-of-squares ( seq -- n )
|
||||
0 [ sq + ] reduce ;
|
||||
|
||||
: square-of-sums ( seq -- n )
|
||||
0 [ + ] reduce sq ;
|
||||
|
||||
: euler006 ( -- answer )
|
||||
1 100 [a,b] dup sum-of-squares swap square-of-sums - abs ;
|
||||
|
||||
! [ euler006 ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
|
||||
MAIN: euler006
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.miller-rabin ;
|
||||
IN: project-euler.007
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=7
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! By listing the first six prime numbers: 2, 3, 5, 7, 11, and 13, we can see
|
||||
! that the 6th prime is 13.
|
||||
|
||||
! What is the 10001st prime number?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: nth-prime ( n -- n )
|
||||
2 swap 1- [ next-prime ] times ;
|
||||
|
||||
: euler007 ( -- answer )
|
||||
10001 nth-prime ;
|
||||
|
||||
! [ euler007 ] time
|
||||
! 19230 ms run / 487 ms GC time
|
||||
|
||||
MAIN: euler007
|
|
@ -0,0 +1,72 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math.parser project-euler.common sequences ;
|
||||
IN: project-euler.008
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=8
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! Find the greatest product of five consecutive digits in the 1000-digit number.
|
||||
|
||||
! 73167176531330624919225119674426574742355349194934
|
||||
! 96983520312774506326239578318016984801869478851843
|
||||
! 85861560789112949495459501737958331952853208805511
|
||||
! 12540698747158523863050715693290963295227443043557
|
||||
! 66896648950445244523161731856403098711121722383113
|
||||
! 62229893423380308135336276614282806444486645238749
|
||||
! 30358907296290491560440772390713810515859307960866
|
||||
! 70172427121883998797908792274921901699720888093776
|
||||
! 65727333001053367881220235421809751254540594752243
|
||||
! 52584907711670556013604839586446706324415722155397
|
||||
! 53697817977846174064955149290862569321978468622482
|
||||
! 83972241375657056057490261407972968652414535100474
|
||||
! 82166370484403199890008895243450658541227588666881
|
||||
! 16427171479924442928230863465674813919123162824586
|
||||
! 17866458359124566529476545682848912883142607690042
|
||||
! 24219022671055626321111109370544217506941658960408
|
||||
! 07198403850962455444362981230987879927244284909188
|
||||
! 84580156166097919133875499200524063689912560717606
|
||||
! 05886116467109405077541002256983155200055935729725
|
||||
! 71636269561882670428252483600823257530420752963450
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
<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
|
|
@ -0,0 +1,55 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions namespaces sequences sorting ;
|
||||
IN: project-euler.009
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=9
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! A Pythagorean triplet is a set of three natural numbers, a < b < c, for which,
|
||||
! a² + b² = c²
|
||||
|
||||
! For example, 3² + 4² = 9 + 16 = 25 = 5².
|
||||
|
||||
! There exists exactly one Pythagorean triplet for which a + b + c = 1000.
|
||||
! Find the product abc.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
! Algorithm adapted from http://www.friesian.com/pythag.com
|
||||
|
||||
<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
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel lazy-lists math math.erato math.functions math.ranges
|
||||
namespaces sequences ;
|
||||
IN: project-euler.010
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=10
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17.
|
||||
|
||||
! Find the sum of all the primes below one million.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
! Sieve of Eratosthenes and lazy summing
|
||||
|
||||
: euler010 ( -- answer )
|
||||
0 1000000 lerato [ + ] leach ;
|
||||
|
||||
! TODO: solution is still too slow for 1000000, probably due to seq-diff
|
||||
! calling member? for each number that we want to remove
|
||||
|
||||
! [ euler010 ] time
|
||||
! 765 ms run / 7 ms GC time
|
||||
|
||||
MAIN: euler010
|
|
@ -0,0 +1,107 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces project-euler.common sequences ;
|
||||
IN: project-euler.011
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=11
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! In the 20x20 grid below, four numbers along a diagonal line have been marked
|
||||
! in red.
|
||||
|
||||
! 08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08
|
||||
! 49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00
|
||||
! 81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65
|
||||
! 52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91
|
||||
! 22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80
|
||||
! 24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50
|
||||
! 32 98 81 28 64 23 67 10 26 38 40 67 59 54 70 66 18 38 64 70
|
||||
! 67 26 20 68 02 62 12 20 95 63 94 39 63 08 40 91 66 49 94 21
|
||||
! 24 55 58 05 66 73 99 26 97 17 78 78 96 83 14 88 34 89 63 72
|
||||
! 21 36 23 09 75 00 76 44 20 45 35 14 00 61 33 97 34 31 33 95
|
||||
! 78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92
|
||||
! 16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57
|
||||
! 86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58
|
||||
! 19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40
|
||||
! 04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66
|
||||
! 88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69
|
||||
! 04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36
|
||||
! 20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16
|
||||
! 20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54
|
||||
! 01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48
|
||||
|
||||
! The product of these numbers is 26 * 63 * 78 * 14 = 1788696.
|
||||
|
||||
! What is the greatest product of four numbers in any direction (up, down,
|
||||
! left, right, or diagonally) in the 20x20 grid?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
<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
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math project-euler.common ;
|
||||
IN: project-euler.012
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=12
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! The sequence of triangle numbers is generated by adding the natural numbers.
|
||||
! So the 7th triangle number would be 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28. The first
|
||||
! ten terms would be:
|
||||
|
||||
! 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ...
|
||||
|
||||
! Let us list the factors of the first seven triangle numbers:
|
||||
|
||||
! 1: 1
|
||||
! 3: 1,3
|
||||
! 6: 1,2,3,6
|
||||
! 10: 1,2,5,10
|
||||
! 15: 1,3,5,15
|
||||
! 21: 1,3,7,21
|
||||
! 28: 1,2,4,7,14,28
|
||||
|
||||
! We can see that the 7th triangle number, 28, is the first triangle number to
|
||||
! have over five divisors.
|
||||
|
||||
! Which is the first triangle number to have over five-hundred divisors?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: nth-triangle ( n -- n )
|
||||
dup 1+ * 2 / ;
|
||||
|
||||
: euler012 ( -- answer )
|
||||
2 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
|
||||
|
||||
! [ euler012 ] 10 ave-time
|
||||
! 5413 ms run / 1 ms GC ave time - 10 trials
|
||||
|
||||
MAIN: euler012
|
|
@ -0,0 +1,233 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math.parser sequences ;
|
||||
IN: project-euler.013
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=13
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! Work out the first ten digits of the sum of the following one-hundred
|
||||
! 50-digit numbers.
|
||||
|
||||
! 37107287533902102798797998220837590246510135740250
|
||||
! 46376937677490009712648124896970078050417018260538
|
||||
! 74324986199524741059474233309513058123726617309629
|
||||
! 91942213363574161572522430563301811072406154908250
|
||||
! 23067588207539346171171980310421047513778063246676
|
||||
! 89261670696623633820136378418383684178734361726757
|
||||
! 28112879812849979408065481931592621691275889832738
|
||||
! 44274228917432520321923589422876796487670272189318
|
||||
! 47451445736001306439091167216856844588711603153276
|
||||
! 70386486105843025439939619828917593665686757934951
|
||||
! 62176457141856560629502157223196586755079324193331
|
||||
! 64906352462741904929101432445813822663347944758178
|
||||
! 92575867718337217661963751590579239728245598838407
|
||||
! 58203565325359399008402633568948830189458628227828
|
||||
! 80181199384826282014278194139940567587151170094390
|
||||
! 35398664372827112653829987240784473053190104293586
|
||||
! 86515506006295864861532075273371959191420517255829
|
||||
! 71693888707715466499115593487603532921714970056938
|
||||
! 54370070576826684624621495650076471787294438377604
|
||||
! 53282654108756828443191190634694037855217779295145
|
||||
! 36123272525000296071075082563815656710885258350721
|
||||
! 45876576172410976447339110607218265236877223636045
|
||||
! 17423706905851860660448207621209813287860733969412
|
||||
! 81142660418086830619328460811191061556940512689692
|
||||
! 51934325451728388641918047049293215058642563049483
|
||||
! 62467221648435076201727918039944693004732956340691
|
||||
! 15732444386908125794514089057706229429197107928209
|
||||
! 55037687525678773091862540744969844508330393682126
|
||||
! 18336384825330154686196124348767681297534375946515
|
||||
! 80386287592878490201521685554828717201219257766954
|
||||
! 78182833757993103614740356856449095527097864797581
|
||||
! 16726320100436897842553539920931837441497806860984
|
||||
! 48403098129077791799088218795327364475675590848030
|
||||
! 87086987551392711854517078544161852424320693150332
|
||||
! 59959406895756536782107074926966537676326235447210
|
||||
! 69793950679652694742597709739166693763042633987085
|
||||
! 41052684708299085211399427365734116182760315001271
|
||||
! 65378607361501080857009149939512557028198746004375
|
||||
! 35829035317434717326932123578154982629742552737307
|
||||
! 94953759765105305946966067683156574377167401875275
|
||||
! 88902802571733229619176668713819931811048770190271
|
||||
! 25267680276078003013678680992525463401061632866526
|
||||
! 36270218540497705585629946580636237993140746255962
|
||||
! 24074486908231174977792365466257246923322810917141
|
||||
! 91430288197103288597806669760892938638285025333403
|
||||
! 34413065578016127815921815005561868836468420090470
|
||||
! 23053081172816430487623791969842487255036638784583
|
||||
! 11487696932154902810424020138335124462181441773470
|
||||
! 63783299490636259666498587618221225225512486764533
|
||||
! 67720186971698544312419572409913959008952310058822
|
||||
! 95548255300263520781532296796249481641953868218774
|
||||
! 76085327132285723110424803456124867697064507995236
|
||||
! 37774242535411291684276865538926205024910326572967
|
||||
! 23701913275725675285653248258265463092207058596522
|
||||
! 29798860272258331913126375147341994889534765745501
|
||||
! 18495701454879288984856827726077713721403798879715
|
||||
! 38298203783031473527721580348144513491373226651381
|
||||
! 34829543829199918180278916522431027392251122869539
|
||||
! 40957953066405232632538044100059654939159879593635
|
||||
! 29746152185502371307642255121183693803580388584903
|
||||
! 41698116222072977186158236678424689157993532961922
|
||||
! 62467957194401269043877107275048102390895523597457
|
||||
! 23189706772547915061505504953922979530901129967519
|
||||
! 86188088225875314529584099251203829009407770775672
|
||||
! 11306739708304724483816533873502340845647058077308
|
||||
! 82959174767140363198008187129011875491310547126581
|
||||
! 97623331044818386269515456334926366572897563400500
|
||||
! 42846280183517070527831839425882145521227251250327
|
||||
! 55121603546981200581762165212827652751691296897789
|
||||
! 32238195734329339946437501907836945765883352399886
|
||||
! 75506164965184775180738168837861091527357929701337
|
||||
! 62177842752192623401942399639168044983993173312731
|
||||
! 32924185707147349566916674687634660915035914677504
|
||||
! 99518671430235219628894890102423325116913619626622
|
||||
! 73267460800591547471830798392868535206946944540724
|
||||
! 76841822524674417161514036427982273348055556214818
|
||||
! 97142617910342598647204516893989422179826088076852
|
||||
! 87783646182799346313767754307809363333018982642090
|
||||
! 10848802521674670883215120185883543223812876952786
|
||||
! 71329612474782464538636993009049310363619763878039
|
||||
! 62184073572399794223406235393808339651327408011116
|
||||
! 66627891981488087797941876876144230030984490851411
|
||||
! 60661826293682836764744779239180335110989069790714
|
||||
! 85786944089552990653640447425576083659976645795096
|
||||
! 66024396409905389607120198219976047599490197230297
|
||||
! 64913982680032973156037120041377903785566085089252
|
||||
! 16730939319872750275468906903707539413042652315011
|
||||
! 94809377245048795150954100921645863754710598436791
|
||||
! 78639167021187492431995700641917969777599028300699
|
||||
! 15368713711936614952811305876380278410754449733078
|
||||
! 40789923115535562561142322423255033685442488917353
|
||||
! 44889911501440648020369068063960672322193204149535
|
||||
! 41503128880339536053299340368006977710650566631954
|
||||
! 81234880673210146739058568557934581403627822703280
|
||||
! 82616570773948327592232845941706525094512325230608
|
||||
! 22918802058777319719839450180888072429661980811197
|
||||
! 77158542502016545090413245809786882778948721859617
|
||||
! 72107838435069186155435662884062257473692284509516
|
||||
! 20849603980134001723930671666823555245252804609722
|
||||
! 53503534226472524250874054075591789781264330331690
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
<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
|
|
@ -0,0 +1,79 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators.lib kernel math math.ranges namespaces sequences
|
||||
sorting ;
|
||||
IN: project-euler.014
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=14
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! The following iterative sequence is defined for the set of positive integers:
|
||||
|
||||
! n -> n / 2 (n is even)
|
||||
! n -> 3n + 1 (n is odd)
|
||||
|
||||
! Using the rule above and starting with 13, we generate the following
|
||||
! sequence:
|
||||
|
||||
! 13 -> 40 -> 20 -> 10 -> 5 -> 16 -> 8 -> 4 -> 2 -> 1
|
||||
|
||||
! It can be seen that this sequence (starting at 13 and finishing at 1)
|
||||
! contains 10 terms. Although it has not been proved yet (Collatz Problem), it
|
||||
! is thought that all starting numbers finish at 1.
|
||||
|
||||
! Which starting number, under one million, produces the longest chain?
|
||||
|
||||
! NOTE: Once the chain starts the terms are allowed to go above one million.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
! Brute force
|
||||
|
||||
<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
|
|
@ -0,0 +1,33 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.combinatorics ;
|
||||
IN: project-euler.015
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=15
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! Starting in the top left corner of a 2x2 grid, there are 6 routes (without
|
||||
! backtracking) to the bottom right corner.
|
||||
|
||||
! How many routes are there through a 20x20 grid?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
<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
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math.functions math.parser sequences ;
|
||||
IN: project-euler.016
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=16
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! 2^15 = 32768 and the sum of its digits is 3 + 2 + 7 + 6 + 8 = 26.
|
||||
|
||||
! What is the sum of the digits of the number 2^1000?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: number>digits ( n -- seq )
|
||||
number>string string>digits ;
|
||||
|
||||
: euler016 ( -- answer )
|
||||
2 1000 ^ number>digits sum ;
|
||||
|
||||
! [ euler016 ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
|
||||
MAIN: euler016
|
|
@ -0,0 +1,65 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces sequences strings ;
|
||||
IN: project-euler.017
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=17
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! If the numbers 1 to 5 are written out in words: one, two, three, four, five;
|
||||
! there are 3 + 3 + 5 + 4 + 4 = 19 letters used in total.
|
||||
|
||||
! If all the numbers from 1 to 1000 (one thousand) inclusive were written out
|
||||
! in words, how many letters would be used?
|
||||
|
||||
! NOTE: Do not count spaces or hyphens. For example, 342 (three hundred and
|
||||
! forty-two) contains 23 letters and 115 (one hundred and fifteen) contains
|
||||
! 20 letters.
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
<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
|
|
@ -0,0 +1 @@
|
|||
Aaron Schaefer
|
|
@ -0,0 +1 @@
|
|||
Aaron Schaefer
|
|
@ -0,0 +1,24 @@
|
|||
USING: arrays help.markup help.syntax math memory quotations sequences system tools.time ;
|
||||
IN: project-euler.ave-time
|
||||
|
||||
HELP: collect-benchmarks
|
||||
{ $values { "quot" quotation } { "n" integer } { "seq" sequence } }
|
||||
{ $description "Runs a quotation " { $snippet "n" } " times, collecting the wall clock time and the time spent in the garbage collector into pairs inside of a sequence." }
|
||||
{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run."
|
||||
$nl
|
||||
"A nicer word for interactive use is " { $link ave-time } "." } ;
|
||||
|
||||
HELP: ave-time
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and the average time spent in the garbage collector." }
|
||||
{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." }
|
||||
{ $examples
|
||||
"This word can be used to compare performance of the non-optimizing and optimizing compilers."
|
||||
$nl
|
||||
"First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:"
|
||||
{ $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run / 6 ms GC ave time - 10 trials" }
|
||||
"Now we define a word and compile it with the optimizing word compiler. This results is faster execution:"
|
||||
{ $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run / 13 ms GC ave time - 10 trials" }
|
||||
} ;
|
||||
|
||||
{ benchmark collect-benchmarks gc-time millis time ave-time } related-words
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays effects inference io kernel math math.functions math.parser
|
||||
math.statistics namespaces sequences tools.time ;
|
||||
IN: project-euler.ave-time
|
||||
|
||||
<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
|
|
@ -0,0 +1 @@
|
|||
Averaging code execution times
|
|
@ -0,0 +1 @@
|
|||
tools
|
|
@ -0,0 +1,61 @@
|
|||
USING: arrays kernel hashtables math math.functions math.miller-rabin
|
||||
math.ranges namespaces sequences combinators.lib ;
|
||||
IN: project-euler.common
|
||||
|
||||
! A collection of words used by more than one Project Euler solution.
|
||||
|
||||
<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 * ;
|
|
@ -0,0 +1,44 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.files kernel math.parser namespaces sequences strings
|
||||
vocabs vocabs.loader system project-euler.ave-time
|
||||
project-euler.001 project-euler.002 project-euler.003 project-euler.004
|
||||
project-euler.005 project-euler.006 project-euler.007 project-euler.008
|
||||
project-euler.009 project-euler.010 project-euler.011 project-euler.012
|
||||
project-euler.013 project-euler.014 project-euler.015 project-euler.016 ;
|
||||
IN: project-euler
|
||||
|
||||
<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
|
|
@ -0,0 +1 @@
|
|||
Project Euler example solutions
|
|
@ -0,0 +1 @@
|
|||
examples
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006 Chris Double. All Rights Reserved.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel furnace fjsc parser-combinators namespaces
|
||||
USING: kernel furnace fjsc peg namespaces
|
||||
lazy-lists io io.files furnace.validator sequences
|
||||
http.client http.server http.server.responders
|
||||
webapps.file html ;
|
||||
|
@ -11,7 +11,7 @@ IN: webapps.fjsc
|
|||
#! Compile the factor code as a string, outputting the http
|
||||
#! response containing the javascript.
|
||||
serving-text
|
||||
'expression' parse-1 fjsc-compile
|
||||
'expression' parse parse-result-ast fjsc-compile
|
||||
write flush ;
|
||||
|
||||
! The 'compile' action results in an URL that looks like
|
||||
|
@ -25,7 +25,7 @@ IN: webapps.fjsc
|
|||
: compile-url ( url -- )
|
||||
#! Compile the factor code at the given url, return the javascript.
|
||||
dup "http:" head? [ "Unable to access remote sites." throw ] when
|
||||
"http://" host rot 3append http-get 2nip compile "();" write flush ;
|
||||
"http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ;
|
||||
|
||||
\ compile-url {
|
||||
{ "url" v-required }
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: calendar furnace furnace.validator io.files kernel
|
||||
namespaces sequences store http.server.responders html
|
||||
math.parser rss xml.writer ;
|
||||
math.parser rss xml.writer xmode.code2html ;
|
||||
IN: webapps.pastebin
|
||||
|
||||
TUPLE: pastebin pastes ;
|
||||
|
|
Loading…
Reference in New Issue