steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://projects.elasticdog.com/git/factor

db4
Slava Pestov 2009-05-08 16:26:27 -05:00
parent 367724f41e 58fdffee87
commit 2f91323624
20 changed files with 292 additions and 99 deletions

70
basis/math/combinatorics/combinatorics-docs.factor
View File

@ -1,37 +1,93 @@
USING: help.markup help.syntax kernel math math.order sequences ;
USING: help.markup help.syntax kernel math math.order multiline sequences ;
IN: math.combinatorics
HELP: factorial
{ $values { "n" "a non-negative integer" } { "n!" integer } }
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"4 factorial ." "24" }
} ;
HELP: nPk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"10 4 nPk ." "5040" }
} ;
HELP: nCk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"10 4 nCk ." "210" }
} ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"1 3 permutation ." "{ 0 2 1 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
} ;
HELP: all-permutations
{ $values { "seq" sequence } { "seq" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
} ;
HELP: each-permutation
{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } }
{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ;
HELP: inverse-permutation
{ $values { "seq" sequence } { "permutation" sequence } }
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" }
} ;
HELP: combination
{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"6 7 iota 4 combination ." "{ 0 1 3 6 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" }
} ;
HELP: all-combinations
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
<" {
{ "a" "b" }
{ "a" "c" }
{ "a" "d" }
{ "b" "c" }
{ "b" "d" }
{ "c" "d" }
}"> } } ;
HELP: each-combination
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ;
IN: math.combinatorics.private

51
basis/math/combinatorics/combinatorics-tests.factor
View File

@ -1,18 +1,6 @@
USING: math.combinatorics math.combinatorics.private tools.test ;
IN: math.combinatorics.tests
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
[ 1 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test
@ -31,6 +19,19 @@ IN: math.combinatorics.tests
[ 2598960 ] [ 52 5 nCk ] unit-test
[ 2598960 ] [ 52 47 nCk ] unit-test
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test
[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test
[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
@ -43,3 +44,29 @@ IN: math.combinatorics.tests
[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
[ 2598960 ] [ 52 iota 5 <combo> choose ] unit-test
[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test
[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test
[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test
[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test
[ 9 ] [ 0 5 iota 3 <combo> dual-index ] unit-test
[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
[ { 0 1 2 } ] [ 0 5 iota 3 <combo> combination-indices ] unit-test
[ { 2 3 4 } ] [ 9 5 iota 3 <combo> combination-indices ] unit-test
[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
[ { { "a" "b" } { "a" "c" }
{ "a" "d" } { "b" "c" }
{ "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test

106
basis/math/combinatorics/combinatorics.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
namespaces sequences sorting fry ;
USING: accessors assocs binary-search fry kernel locals math math.order
math.ranges mirrors namespaces sequences sorting ;
IN: math.combinatorics
<PRIVATE
@ -12,14 +12,27 @@ IN: math.combinatorics
: twiddle ( n k -- n k )
2dup - dupd > [ dupd - ] when ; inline
! See this article for explanation of the factoradic-based permutation methodology:
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
PRIVATE>
: factorial ( n -- n! )
1 [ 1 + * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
: nCk ( n k -- nCk )
twiddle [ nPk ] keep factorial / ;
! Factoradic-based permutation methodology
<PRIVATE
: factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ;
0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
[ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
[ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
@ -29,27 +42,84 @@ IN: math.combinatorics
PRIVATE>
: factorial ( n -- n! )
1 [ 1+ * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
: nCk ( n k -- nCk )
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
[ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
[ length factorial ] keep '[ _ permutation ] map ;
[ length factorial ] keep
'[ _ permutation ] map ;
: each-permutation ( seq quot -- )
[ [ length factorial ] keep ] dip
'[ _ permutation @ ] each ; inline
: reduce-permutations ( seq initial quot -- result )
: reduce-permutations ( seq identity quot -- result )
swapd each-permutation ; inline
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
! Combinadic-based combination methodology
<PRIVATE
TUPLE: combo
{ seq sequence }
{ k integer } ;
C: <combo> combo
: choose ( combo -- nCk )
[ seq>> length ] [ k>> ] bi nCk ;
: largest-value ( a b x -- v )
dup 0 = [
drop 1 - nip
] [
[ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
] if ;
:: next-values ( a b x -- a' b' x' v )
a b x largest-value dup :> v ! a'
b 1 - ! b'
x v b nCk - ! x'
v ; ! v == a'
: dual-index ( m combo -- m' )
choose 1 - swap - ;
: initial-values ( combo m -- n k m )
[ [ seq>> length ] [ k>> ] bi ] dip ;
: combinadic ( combo m -- combinadic )
initial-values [ over 0 > ] [ next-values ] produce
[ 3drop ] dip ;
: combination-indices ( m combo -- seq )
[ tuck dual-index combinadic ] keep
seq>> length 1 - swap [ - ] with map ;
: apply-combination ( m combo -- seq )
[ combination-indices ] keep seq>> nths ;
PRIVATE>
: combination ( m seq k -- seq )
<combo> apply-combination ;
: all-combinations ( seq k -- seq )
<combo> [ choose [0,b) ] keep
'[ _ apply-combination ] map ;
: each-combination ( seq k quot -- )
[ <combo> [ choose [0,b) ] keep ] dip
'[ _ apply-combination @ ] each ; inline
: map-combinations ( seq k quot -- )
[ <combo> [ choose [0,b) ] keep ] dip
'[ _ apply-combination @ ] map ; inline
: reduce-combinations ( seq k identity quot -- result )
[ -rot ] dip each-combination ; inline

4
basis/math/miller-rabin/miller-rabin.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (c) 2008-2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel locals math math.functions math.ranges
random sequences sets combinators.short-circuit math.bitwise
@ -27,7 +27,7 @@ IN: math.miller-rabin
] [
r iota [
2^ s * a swap n ^mod n - -1 =
] any? not
] any? not
] if
] any? not ;

2
extra/benchmark/pidigits/pidigits.factor
View File

@ -18,7 +18,7 @@ IN: benchmark.pidigits
: >matrix ( q s r t -- z )
4array 2 group ;
: produce ( z n -- z' )
: produce ( z y -- z' )
[ 10 ] dip -10 * 0 1 >matrix swap m. ;
: gen-x ( x -- matrix )

22
extra/poker/poker-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ;
IN: poker
HELP: <hand>
{ $values { "str" string } { "hand" "a new hand" } }
{ $values { "str" string } { "hand" "a new " { $link hand } } }
{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
{ $examples
{ $example "USING: kernel math.order poker prettyprint ;"
@ -12,8 +12,16 @@ HELP: <hand>
}
{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
HELP: best-hand
{ $values { "str" string } { "hand" "a new " { $link hand } } }
{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
{ $examples
{ $example "USING: kernel poker prettyprint ;"
"\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" }
} ;
HELP: >cards
{ $values { "hand" "a hand" } { "str" string } }
{ $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's cards." }
{ $examples
{ $example "USING: poker prettyprint ;"
@ -21,10 +29,18 @@ HELP: >cards
} ;
HELP: >value
{ $values { "hand" "a hand" } { "str" string } }
{ $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's value." }
{ $examples
{ $example "USING: poker prettyprint ;"
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
}
{ $notes "This should not be used as a basis for hand comparison." } ;
HELP: <deck>
{ $values { "deck" "a new " { $link deck } } }
{ $description "Creates a standard deck of 52 cards." } ;
HELP: shuffle
{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } }
{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ;

4
extra/poker/poker-tests.factor
View File

@ -1,4 +1,4 @@
USING: accessors poker poker.private tools.test math.order kernel ;
USING: accessors kernel math.order poker poker.private tools.test ;
IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test
@ -26,3 +26,5 @@ IN: poker.tests
[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test

67
extra/poker/poker.factor
View File

@ -1,7 +1,9 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii binary-search combinators kernel locals math
math.bitwise math.order poker.arrays sequences splitting ;
! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt
USING: accessors arrays ascii binary-search combinators kernel locals math
math.bitwise math.combinatorics math.order poker.arrays random sequences
sequences.product splitting ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
@ -47,19 +49,21 @@ CONSTANT: QUEEN 10
CONSTANT: KING 11
CONSTANT: ACE 12
CONSTANT: STRAIGHT_FLUSH 1
CONSTANT: FOUR_OF_A_KIND 2
CONSTANT: FULL_HOUSE 3
CONSTANT: FLUSH 4
CONSTANT: STRAIGHT 5
CONSTANT: THREE_OF_A_KIND 6
CONSTANT: TWO_PAIR 7
CONSTANT: ONE_PAIR 8
CONSTANT: HIGH_CARD 9
CONSTANT: STRAIGHT_FLUSH 0
CONSTANT: FOUR_OF_A_KIND 1
CONSTANT: FULL_HOUSE 2
CONSTANT: FLUSH 3
CONSTANT: STRAIGHT 4
CONSTANT: THREE_OF_A_KIND 5
CONSTANT: TWO_PAIR 6
CONSTANT: ONE_PAIR 7
CONSTANT: HIGH_CARD 8
CONSTANT: SUIT_STR { "C" "D" "H" "S" }
CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
"Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
: card-rank-prime ( rank -- n )
@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
#! Cactus Kev Format
>upper 1 cut (>ckf) ;
: parse-cards ( str -- seq )
" " split [ >ckf ] map ;
: flush? ( cards -- ? )
HEX: F000 [ bitand ] reduce 0 = not ;
@ -152,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
[ drop "S" ]
} cond ;
: hand-rank ( hand -- rank )
value>> {
: hand-rank ( value -- rank )
{
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
@ -165,24 +172,38 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
: card>string ( card -- str )
[ >card-rank ] [ >card-suit ] bi append ;
PRIVATE>
TUPLE: hand
{ cards sequence }
{ value integer } ;
{ value integer initial: 9999 } ;
M: hand <=> [ value>> ] compare ;
M: hand equal?
over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
: <hand> ( str -- hand )
" " split [ >ckf ] map
dup hand-value hand boa ;
parse-cards dup hand-value hand boa ;
: best-hand ( str -- hand )
parse-cards 5 hand new
[ dup hand-value hand boa min ] reduce-combinations ;
: >cards ( hand -- str )
cards>> [
[ >card-rank ] [ >card-suit ] bi append
] map " " join ;
cards>> [ card>string ] map " " join ;
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
value>> hand-rank VALUE_STR nth ;
TUPLE: deck
{ cards sequence } ;
: <deck> ( -- deck )
RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
: shuffle ( deck -- deck )
[ randomize ] change-cards ;

2
extra/poker/summary.txt
View File

@ -1 +1 @@
5-card poker hand evaluator
Poker hand evaluator

6
extra/project-euler/001/001.factor
View File

@ -1,4 +1,4 @@
! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges project-euler.common sequences
sets ;
@ -47,14 +47,14 @@ PRIVATE>
: euler001b ( -- answer )
1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer )
1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)

6
extra/project-euler/005/005.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2007, 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.functions sequences project-euler.common ;
USING: math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.005
! http://projecteuler.net/index.php?section=problems&id=5
@ -18,7 +18,7 @@ IN: project-euler.005
! --------
: euler005 ( -- answer )
20 1 [ 1+ lcm ] reduce ;
20 [1,b] 1 [ lcm ] reduce ;
! [ euler005 ] 100 ave-time
! 0 ms ave run time - 0.14 SD (100 trials)

4
extra/project-euler/018/018.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math project-euler.common sequences ;
USING: kernel math math.ranges project-euler.common sequences ;
IN: project-euler.018
! http://projecteuler.net/index.php?section=problems&id=18
@ -66,7 +66,7 @@ IN: project-euler.018
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
} 15 iota [ 1+ cut swap ] map nip ;
} 15 [1,b] [ cut swap ] map nip ;
PRIVATE>

2
extra/project-euler/025/025.factor
View File

@ -39,7 +39,7 @@ IN: project-euler.025
! Memoized brute force
MEMO: fib ( m -- n )
dup 1 > [ 1- dup fib swap 1- fib + ] when ;
dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ;
<PRIVATE

5
extra/project-euler/027/027.factor
View File

@ -1,7 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.primes project-euler.common sequences
project-euler.common ;
USING: kernel math math.primes math.ranges project-euler.common sequences ;
IN: project-euler.027
! http://projecteuler.net/index.php?section=problems&id=27
@ -47,7 +46,7 @@ IN: project-euler.027
<PRIVATE
: source-027 ( -- seq )
1000 [ prime? ] filter [ dup [ neg ] map append ] keep
1000 [0,b) [ prime? ] filter [ dup [ neg ] map append ] keep
cartesian-product [ first2 < ] filter ;
: quadratic ( b a n -- m )

4
extra/project-euler/030/030.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions project-euler.common sequences ;
USING: kernel math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.030
! http://projecteuler.net/index.php?section=problems&id=30
@ -38,7 +38,7 @@ IN: project-euler.030
PRIVATE>
: euler030 ( -- answer )
325537 [ dup sum-fifth-powers = ] filter sum 1- ;
325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)

2
extra/project-euler/032/032.factor
View File

@ -28,7 +28,7 @@ IN: project-euler.032
: source-032 ( -- seq )
9 factorial iota [
9 permutation [ 1+ ] map 10 digits>integer
9 permutation [ 1 + ] map 10 digits>integer
] map ;
: 1and4 ( n -- ? )

4
extra/project-euler/048/048.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences project-euler.common ;
USING: kernel math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48
@ -17,7 +17,7 @@ IN: project-euler.048
! --------
: euler048 ( -- answer )
1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ;
1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials

4
extra/project-euler/055/055.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser project-euler.common sequences ;
USING: kernel math math.parser math.ranges project-euler.common sequences ;
IN: project-euler.055
! http://projecteuler.net/index.php?section=problems&id=55
@ -61,7 +61,7 @@ IN: project-euler.055
PRIVATE>
: euler055 ( -- answer )
10000 [ lychrel? ] count ;
10000 [0,b) [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
! 478 ms ave run time - 30.63 SD (100 trials)

19
extra/project-euler/057/057.factor
View File

@ -1,6 +1,7 @@
! Copyright (c) 2008 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.parser sequences project-euler.common ;
USING: kernel math math.functions math.parser math.ranges project-euler.common
sequences ;
IN: project-euler.057
! http://projecteuler.net/index.php?section=problems&id=57
@ -11,14 +12,14 @@ IN: project-euler.057
! It is possible to show that the square root of two can be expressed
! as an infinite continued fraction.
! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
! By expanding this for the first four iterations, we get:
! 1 + 1/2 = 3/2 = 1.5
! 1 + 1/(2 + 1/2) = 7/5 = 1.4
! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
! 1 + 1/2 = 3/2 = 1.5
! 1 + 1/(2 + 1/2) = 7/5 = 1.4
! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
! The next three expansions are 99/70, 239/169, and 577/408, but the
! eighth expansion, 1393/985, is the first example where the number of
@ -35,9 +36,9 @@ IN: project-euler.057
>fraction [ number>string length ] bi@ > ; inline
: euler057 ( -- answer )
0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
! [ euler057 ] time
! 3.375118 seconds
! [ euler057 ] 100 ave-time
! 1728 ms ave run time - 80.81 SD (100 trials)
SOLUTION: euler057

7
extra/project-euler/150/150.factor
View File

@ -1,6 +1,7 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: hints kernel locals math math.order sequences sequences.private project-euler.common ;
USING: hints kernel locals math math.order math.ranges project-euler.common
sequences sequences.private ;
IN: project-euler.150
! http://projecteuler.net/index.php?section=problems&id=150
@ -50,13 +51,13 @@ IN: project-euler.150
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
x 1+ [| y |
m x - iota [| z |
m x - [0,b) [| z |
x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi -