Merge branch 'master' of git://projects.elasticdog.com/git/factor
Slava Pestov
commit
2f91323624
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
5-card poker hand evaluator
|
||||
Poker hand evaluator
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 -- ? )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -
|
||||
|
|
|
|||
Loading…
Reference in New Issue