From 68d7137a16dbf3ee2f9543582e771d67cb06b1a0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 24 Apr 2009 02:16:05 -0400 Subject: [PATCH 01/22] Fix minor inconsistency in reference to var name --- extra/benchmark/pidigits/pidigits.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor index 5de5cc5e99..0f8a98e6f9 100644 --- a/extra/benchmark/pidigits/pidigits.factor +++ b/extra/benchmark/pidigits/pidigits.factor @@ -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 ) From 9981f6534fd7a9d80abcbdeae45c43438adf2165 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 1 May 2009 20:46:25 -0400 Subject: [PATCH 02/22] Use iota in Project Euler solutions --- extra/project-euler/001/001.factor | 6 +++--- extra/project-euler/005/005.factor | 6 +++--- extra/project-euler/030/030.factor | 2 +- extra/project-euler/048/048.factor | 4 ++-- extra/project-euler/055/055.factor | 2 +- extra/project-euler/057/057.factor | 16 ++++++++-------- 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 0d4f5fb1bd..e4c8a20cb3 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -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 iota [ [ 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 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ; ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor index 7fef29a6b9..8512bc97fa 100644 --- a/extra/project-euler/005/005.factor +++ b/extra/project-euler/005/005.factor @@ -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) diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor index 54d48660d5..7c8334cfd4 100644 --- a/extra/project-euler/030/030.factor +++ b/extra/project-euler/030/030.factor @@ -38,7 +38,7 @@ IN: project-euler.030 PRIVATE> : euler030 ( -- answer ) - 325537 [ dup sum-fifth-powers = ] filter sum 1- ; + 325537 iota [ dup sum-fifth-powers = ] filter sum 1- ; ! [ euler030 ] 100 ave-time ! 1700 ms ave run time - 64.84 SD (100 trials) diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor index e56b9e9548..640a3a68f6 100644 --- a/extra/project-euler/048/048.factor +++ b/extra/project-euler/048/048.factor @@ -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 diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor index 43f380b3ba..6154e29717 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -61,7 +61,7 @@ IN: project-euler.055 PRIVATE> : euler055 ( -- answer ) - 10000 [ lychrel? ] count ; + 10000 iota [ lychrel? ] count ; ! [ euler055 ] 100 ave-time ! 478 ms ave run time - 30.63 SD (100 trials) diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor index 681a17dd9e..0c434f4506 100644 --- a/extra/project-euler/057/057.factor +++ b/extra/project-euler/057/057.factor @@ -11,14 +11,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 +35,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 iota [ 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 From e59e051c749201d85d754966b10aa2dd65cb636e Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 1 May 2009 22:26:49 -0400 Subject: [PATCH 03/22] Use [0,b) and iota where appropriate --- extra/project-euler/001/001.factor | 4 ++-- extra/project-euler/018/018.factor | 4 ++-- extra/project-euler/027/027.factor | 5 ++--- extra/project-euler/030/030.factor | 4 ++-- extra/project-euler/032/032.factor | 2 +- extra/project-euler/055/055.factor | 4 ++-- extra/project-euler/057/057.factor | 5 +++-- extra/project-euler/150/150.factor | 7 ++++--- 8 files changed, 18 insertions(+), 17 deletions(-) diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index e4c8a20cb3..204527418b 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -47,14 +47,14 @@ PRIVATE> : euler001b ( -- answer ) - 1000 iota [ [ 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 iota [ { 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) diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index 9c7c4fee74..9189323121 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -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> diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor index 4bcfb66a94..f7bffbf665 100644 --- a/extra/project-euler/027/027.factor +++ b/extra/project-euler/027/027.factor @@ -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 : euler030 ( -- answer ) - 325537 iota [ 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) diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 64c9ec445e..814f8a5a63 100755 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -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 -- ? ) diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor index 6154e29717..07525fe6a4 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -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 iota [ lychrel? ] count ; + 10000 [0,b) [ lychrel? ] count ; ! [ euler055 ] 100 ave-time ! 478 ms ave run time - 30.63 SD (100 trials) diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor index 0c434f4506..97789944fe 100644 --- a/extra/project-euler/057/057.factor +++ b/extra/project-euler/057/057.factor @@ -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 @@ -35,7 +36,7 @@ IN: project-euler.057 >fraction [ number>string length ] bi@ > ; inline : euler057 ( -- answer ) - 0 1000 iota [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; + 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ; ! [ euler057 ] 100 ave-time ! 1728 ms ave run time - 80.81 SD (100 trials) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 314698534f..eeb4b0c315 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -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 - From 17fa5ac5f1c20b1503f43bef37347311787e8b85 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 May 2009 02:06:52 -0400 Subject: [PATCH 04/22] Add deck generation and shuffling to poker vocab --- extra/poker/poker-tests.factor | 2 +- extra/poker/poker.factor | 31 ++++++++++++++++++++++--------- 2 files changed, 23 insertions(+), 10 deletions(-) diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index ad371a6bff..e2d89620e6 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -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 diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index e8e9fa23c5..15e9a96d42 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -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.order poker.arrays random sequences sequences.product + splitting ; IN: poker ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with @@ -57,6 +59,8 @@ CONSTANT: TWO_PAIR 7 CONSTANT: ONE_PAIR 8 CONSTANT: HIGH_CARD 9 +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" @@ -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 ; @@ -165,6 +172,9 @@ 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 @@ -176,13 +186,16 @@ M: hand equal? over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ; : ( str -- hand ) - " " split [ >ckf ] map - dup hand-value hand boa ; + parse-cards dup hand-value hand boa ; : >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 ; + +: ( -- deck ) + RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ; + +ALIAS: shuffle randomize + From 71022f9940e6e047e8574a972fc98bb030405df0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 5 May 2009 22:43:07 -0400 Subject: [PATCH 05/22] Add combination support to math.combinatorics --- basis/math/combinatorics/combinatorics.factor | 72 ++++++++++++++----- 1 file changed, 56 insertions(+), 16 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index afdf4e378e..0ca306b68c 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -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 fry kernel locals math math.order math.ranges mirrors + namespaces sequences sorting ; IN: math.combinatorics [ 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 + + ] [ 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,15 +42,6 @@ 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 ; @@ -53,3 +57,39 @@ PRIVATE> : inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + + +! Combinadic-based combination methodology + +TUPLE: combination + { n integer } + { k integer } ; + +C: combination + +> ] [ k>> ] bi nCk 1 - ] dip - ; + +: largest-value ( a b x -- v ) + #! TODO: use a binary search instead of find-last + [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; + +:: 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' + +: initial-values ( combination m -- a b x ) + [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ; + +: combinadic ( combination m -- combinadic ) + initial-values [ over 0 > ] [ next-values ] produce + [ 3drop ] dip ; + +PRIVATE> + +: combination ( m combination -- seq ) + swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ; From eaeda30bb1f586d2c18e4d5804055ac1423c81cf Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 01:17:35 -0400 Subject: [PATCH 06/22] Combinations now map to input sequences directly --- basis/math/combinatorics/combinatorics.factor | 47 +++++++++++++------ 1 file changed, 33 insertions(+), 14 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 0ca306b68c..dd71ded8c2 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -52,7 +52,7 @@ PRIVATE> [ [ 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 ) @@ -61,16 +61,13 @@ PRIVATE> ! Combinadic-based combination methodology -TUPLE: combination - { n integer } - { k integer } ; - -C: combination - > ] [ k>> ] bi nCk 1 - ] dip - ; +TUPLE: combo + { seq sequence } + { k integer } ; + +C: combo : largest-value ( a b x -- v ) #! TODO: use a binary search instead of find-last @@ -82,14 +79,36 @@ C: combination x v b nCk - ! x' v ; ! v == a' -: initial-values ( combination m -- a b x ) - [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ; +: dual-index ( combo m -- x ) + [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ; -: combinadic ( combination m -- combinadic ) +: initial-values ( combo m -- a b x ) + [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ; + +: combinadic ( combo m -- combinadic ) initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; +: combination-indices ( m combo -- seq ) + [ swap combinadic ] keep + seq>> length 1 - swap [ - ] with map ; + +: apply-combination ( m combo -- seq ) + [ combination-indices ] keep seq>> nths ; + +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + PRIVATE> -: combination ( m combination -- seq ) - swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ; +: combination ( m seq k -- seq ) + apply-combination ; + +: all-combinations ( seq k -- seq ) + [ choose [0,b) ] keep + '[ _ apply-combination ] map ; + +: each-combination ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] each ; inline + From c9b97f3f9205c5c0066382a222afd66b0c772b36 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 19:33:58 -0400 Subject: [PATCH 07/22] Add tests for combinations --- .../combinatorics/combinatorics-tests.factor | 51 ++++++++++++++----- 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 5ef435a4e0..8cd02399bc 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -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 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 + [ { "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 5 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 3 dual-index ] unit-test +[ 0 ] [ 9 5 3 dual-index ] unit-test +[ 179 ] [ 72 10 5 dual-index ] unit-test + +[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 5 251 combinadic ] unit-test + +[ { 0 1 2 } ] [ 0 5 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 3 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 From 678f603aa5495f92285303f375635410b20c00cc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 20:18:21 -0400 Subject: [PATCH 08/22] Clean up combinations a bit --- basis/math/combinatorics/combinatorics.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index dd71ded8c2..b2e21e429a 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -46,7 +46,8 @@ PRIVATE> [ 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 @@ -69,6 +70,9 @@ TUPLE: combo C: combo +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + : largest-value ( a b x -- v ) #! TODO: use a binary search instead of find-last [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; @@ -79,26 +83,23 @@ C: combo x v b nCk - ! x' v ; ! v == a' -: dual-index ( combo m -- x ) - [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ; +: dual-index ( m combo -- m' ) + choose 1 - swap - ; -: initial-values ( combo m -- a b x ) - [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ; +: 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 ) - [ swap combinadic ] keep + [ tuck dual-index combinadic ] keep seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; -: choose ( combo -- nCk ) - [ seq>> length ] [ k>> ] bi nCk ; - PRIVATE> : combination ( m seq k -- seq ) From 78037d8d0558d01abdc0609bddf23b53fe7cc6c0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 20:46:41 -0400 Subject: [PATCH 09/22] Use binary-search instead of find-last for combinations --- basis/math/combinatorics/combinatorics.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index b2e21e429a..5bda23f738 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry kernel locals math math.order math.ranges mirrors - namespaces sequences sorting ; +USING: accessors assocs binary-search fry kernel locals math math.order + math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics combo [ seq>> length ] [ k>> ] bi nCk ; : largest-value ( a b x -- v ) - #! TODO: use a binary search instead of find-last - [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; + 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' From b84a3158fa47b9507fd495a75e7cfa63fe72691d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:27:04 -0400 Subject: [PATCH 10/22] Add docs for combination words --- .../combinatorics/combinatorics-docs.factor | 70 +++++++++++++++++-- 1 file changed, 63 insertions(+), 7 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 514c808ee0..7f40969b95 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -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 From 83e75166668a614c845e7d215805ca18b2112de6 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:31:37 -0400 Subject: [PATCH 11/22] Use iota where necessary in tests --- .../combinatorics/combinatorics-tests.factor | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 8cd02399bc..1bc4bbc825 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -28,9 +28,9 @@ IN: math.combinatorics.tests [ { 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 +[ { 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 @@ -45,24 +45,24 @@ IN: math.combinatorics.tests [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test -[ 2598960 ] [ 52 5 choose ] unit-test +[ 2598960 ] [ 52 iota 5 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 3 dual-index ] unit-test -[ 0 ] [ 9 5 3 dual-index ] unit-test -[ 179 ] [ 72 10 5 dual-index ] unit-test +[ 9 ] [ 0 5 iota 3 dual-index ] unit-test +[ 0 ] [ 9 5 iota 3 dual-index ] unit-test +[ 179 ] [ 72 10 iota 5 dual-index ] unit-test [ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test -[ { 4 3 2 1 0 } ] [ 10 5 0 combinadic ] unit-test -[ { 8 6 3 1 0 } ] [ 10 5 72 combinadic ] unit-test -[ { 9 8 7 6 5 } ] [ 10 5 251 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test -[ { 0 1 2 } ] [ 0 5 3 combination-indices ] unit-test -[ { 2 3 4 } ] [ 9 5 3 combination-indices ] unit-test +[ { 0 1 2 } ] [ 0 5 iota 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 iota 3 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 From 5e4e1ee48fe313dc7771b83306ac0b7a53aad376 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:44:25 -0400 Subject: [PATCH 12/22] Make a deck of cards an actual tuple --- extra/poker/poker.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index 15e9a96d42..b4353dc925 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -194,8 +194,12 @@ M: hand equal? : >value ( hand -- str ) hand-rank VALUE_STR nth ; +TUPLE: deck + { cards sequence } ; + : ( -- deck ) - RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ; + RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ; -ALIAS: shuffle randomize +: shuffle ( deck -- deck ) + [ randomize ] change-cards ; From e2c73b543a59a0c68fd0d8cc8442eaedfdf0b6cd Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:19:23 -0400 Subject: [PATCH 13/22] Add >5 card evaluator word to poker vocab --- extra/poker/poker.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b4353dc925..df8d93d9fa 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -2,8 +2,8 @@ ! 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.order poker.arrays random sequences sequences.product - splitting ; + 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 @@ -194,6 +194,9 @@ M: hand equal? : >value ( hand -- str ) hand-rank VALUE_STR nth ; +: best-hand ( str -- hand ) + " " split 5 all-combinations [ " " join ] map infimum ; + TUPLE: deck { cards sequence } ; From 0878006bd0d7b783062272a0eef1b57663995c59 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:29:44 -0400 Subject: [PATCH 14/22] Speed up best-hand by not converting to ckf repeatedly --- extra/poker/poker.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index df8d93d9fa..a749be239b 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -195,7 +195,8 @@ M: hand equal? hand-rank VALUE_STR nth ; : best-hand ( str -- hand ) - " " split 5 all-combinations [ " " join ] map infimum ; + parse-cards 5 all-combinations + [ dup hand-value hand boa ] map infimum ; TUPLE: deck { cards sequence } ; From 5e82d794df12897d34bc2b7a31549f2195c64048 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:56:33 -0400 Subject: [PATCH 15/22] Eliminate stack shuffling by using bi in PE #25 --- extra/project-euler/025/025.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 80a933dc63..5dfe7b9f56 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -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 ; Date: Thu, 7 May 2009 11:20:01 -0400 Subject: [PATCH 16/22] Add docs for best-hand in poker vocab --- extra/poker/poker-docs.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index 09019a29d7..ad2131870e 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -28,3 +28,11 @@ HELP: >value "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; + +HELP: best-hand +{ $values { "str" string } { "hand" "a new 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 KH\" best-hand >value ." "\"Full House\"" } +} ; From 246fb6672ea8b039538708be5dbd0f71c1781b7a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 16:54:49 -0400 Subject: [PATCH 17/22] Minor logical rearrangement --- extra/poker/poker-docs.factor | 16 ++++++++-------- extra/poker/poker.factor | 8 ++++---- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index ad2131870e..ab0a59ed4f 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -12,6 +12,14 @@ HELP: } { $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 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 KH\" best-hand >value ." "\"Full House\"" } +} ; + HELP: >cards { $values { "hand" "a hand" } { "str" string } } { $description "Outputs a string representation of a hand's cards." } @@ -28,11 +36,3 @@ HELP: >value "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; - -HELP: best-hand -{ $values { "str" string } { "hand" "a new 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 KH\" best-hand >value ." "\"Full House\"" } -} ; diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index a749be239b..b7661b83db 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -188,16 +188,16 @@ M: hand equal? : ( str -- hand ) parse-cards dup hand-value hand boa ; +: best-hand ( str -- hand ) + parse-cards 5 all-combinations + [ dup hand-value hand boa ] map infimum ; + : >cards ( hand -- str ) cards>> [ card>string ] map " " join ; : >value ( hand -- str ) hand-rank VALUE_STR nth ; -: best-hand ( str -- hand ) - parse-cards 5 all-combinations - [ dup hand-value hand boa ] map infimum ; - TUPLE: deck { cards sequence } ; From 7f6998a8154babe8dcbb36a710372d0abd86b562 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 18:33:55 -0400 Subject: [PATCH 18/22] Make next-odd public again as it's used elsewhere --- basis/math/miller-rabin/miller-rabin.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 9fd604a003..cb1d3723b4 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -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 @@ -13,8 +13,6 @@ IN: math.miller-rabin : next-even ( m -- n ) >even 2 + ; -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) @@ -29,12 +27,14 @@ TUPLE: positive-even-expected n ; ] [ r iota [ 2^ s * a swap n ^mod n - -1 = - ] any? not + ] any? not ] if ] any? not ; PRIVATE> +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; + : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } From d9e4f6e9cbe1df7a5f979d594a681147d9f490cc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 18:50:46 -0400 Subject: [PATCH 19/22] Update docs/summary for poker vocab --- extra/poker/poker-docs.factor | 16 ++++++++++++---- extra/poker/summary.txt | 2 +- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index ab0a59ed4f..388239d549 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ; IN: poker HELP: -{ $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 ;" @@ -13,7 +13,7 @@ HELP: { $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 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 ;" @@ -21,7 +21,7 @@ HELP: best-hand } ; 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 ;" @@ -29,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\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; + +HELP: +{ $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." } ; diff --git a/extra/poker/summary.txt b/extra/poker/summary.txt index c8efe851c8..8dbbe9bd74 100644 --- a/extra/poker/summary.txt +++ b/extra/poker/summary.txt @@ -1 +1 @@ -5-card poker hand evaluator +Poker hand evaluator From f465a013d7e93ea118df8634abf2a3cf2c2ed1d0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 21:23:58 -0400 Subject: [PATCH 20/22] Speed up best-hands a bit using reduce and add a test --- basis/math/combinatorics/combinatorics.factor | 7 +++++++ extra/poker/poker-tests.factor | 2 ++ extra/poker/poker.factor | 6 +++--- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 5bda23f738..bc09f9fe0f 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -116,3 +116,10 @@ PRIVATE> [ [ choose [0,b) ] keep ] dip '[ _ apply-combination @ ] each ; inline +: map-combinations ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] map ; inline + +: reduce-combinations ( seq k identity quot -- result ) + [ -rot ] dip each-combination ; inline + diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index e2d89620e6..3c8e5159ab 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -26,3 +26,5 @@ IN: poker.tests [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test + +[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b7661b83db..baebb25572 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -179,7 +179,7 @@ PRIVATE> TUPLE: hand { cards sequence } - { value integer } ; + { value integer initial: 9999 } ; M: hand <=> [ value>> ] compare ; M: hand equal? @@ -189,8 +189,8 @@ M: hand equal? parse-cards dup hand-value hand boa ; : best-hand ( str -- hand ) - parse-cards 5 all-combinations - [ dup hand-value hand boa ] map infimum ; + parse-cards 5 hand new + [ dup hand-value hand boa min ] reduce-combinations ; : >cards ( hand -- str ) cards>> [ card>string ] map " " join ; From 3a636d67c45c948d6c07f1ac3225b96da43c6fd7 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 23:11:44 -0400 Subject: [PATCH 21/22] Fix typo in poker test/doc example --- extra/poker/poker-docs.factor | 2 +- extra/poker/poker-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index 388239d549..fef47b859c 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -17,7 +17,7 @@ HELP: best-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 KH\" best-hand >value ." "\"Full House\"" } + "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" } } ; HELP: >cards diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index 3c8e5159ab..6b05178462 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -27,4 +27,4 @@ IN: poker.tests [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test -[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test +[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test From 58fdffee87af3e14a4e9a0f5db5d76c3ea01ca1d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 8 May 2009 02:24:12 -0400 Subject: [PATCH 22/22] Make lookup indices zero-based for poker values --- extra/poker/poker.factor | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index baebb25572..a5a5a93628 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -49,21 +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 ) @@ -159,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 @@ -196,7 +196,7 @@ M: hand equal? cards>> [ card>string ] map " " join ; : >value ( hand -- str ) - hand-rank VALUE_STR nth ; + value>> hand-rank VALUE_STR nth ; TUPLE: deck { cards sequence } ;