-USING: help.markup help.syntax strings ;
+USING: help.markup help.syntax math sequences strings ;
IN: poker
-HELP: <hand>
-{ $values { "str" string } { "hand" "a new " { $link hand } } }
-{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
+HELP: best-holdem-hand
+{ $values { "hand" sequence } { "n" integer } { "cards" sequence } }
+{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "seq" } "." }
{ $examples
- { $example "USING: kernel math.order poker prettyprint ;"
- "\"AC KC QC JC TC\" \"7C 6D 5H 4S 2C\" [ <hand> ] bi@ <=> ." "+lt+" }
{ $example "USING: kernel poker prettyprint ;"
- "\"TC 9C 8C 7C 6C\" \"TH 9H 8H 7H 6H\" [ <hand> ] bi@ = ." "t" }
-}
-{ $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\"" }
+ "HAND{ AS KD JC KH 2D 2S KC } best-holdem-hand drop value>hand-name ."
+ """"Full House""""
+ }
} ;
-HELP: >cards
-{ $values { "hand" hand } { "str" string } }
-{ $description "Outputs a string representation of a hand's cards." }
-{ $examples
- { $example "USING: poker prettyprint ;"
- "\"AC KC QC JC TC\" <hand> >cards ." "\"AC KC QC JC TC\"" }
-} ;
-
-HELP: >value
-{ $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." } ;
+{ $values { "deck" sequence } }
+{ $description "Returns a vector containing a standard, unshuffled deck of 52 cards." } ;
[ 529159 ] [ "5s" >ckf ] unit-test
[ 33589533 ] [ "jc" >ckf ] unit-test
-[ 7462 ] [ "7C 5D 4H 3S 2C" <hand> value>> ] unit-test
-[ 1601 ] [ "KD QS JC TH 9S" <hand> value>> ] unit-test
-[ 11 ] [ "AC AD AH AS KC" <hand> value>> ] unit-test
-[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
-[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
+[ 7462 ] [ "7C 5D 4H 3S 2C" string>value ] unit-test
+[ 1601 ] [ "KD QS JC TH 9S" string>value ] unit-test
+[ 11 ] [ "AC AD AH AS KC" string>value ] unit-test
+[ 9 ] [ "6C 5C 4C 3C 2C" string>value ] unit-test
+[ 1 ] [ "AC KC QC JC TC" string>value ] unit-test
-[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
-[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
-[ "Four of a Kind" ] [ "AC AD AH AS KC" <hand> >value ] unit-test
-[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] unit-test
+[ "High Card" ] [ "7C 5D 4H 3S 2C" string>hand-name ] unit-test
+[ "Straight" ] [ "KD QS JC TH 9S" string>hand-name ] unit-test
+[ "Four of a Kind" ] [ "AC AD AH AS KC" string>hand-name ] unit-test
+[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" string>hand-name ] unit-test
-[ "6C 5C 4C 3C 2C" ] [ "6C 5C 4C 3C 2C" <hand> >cards ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ string>value ] bi@ > ] unit-test
+[ t ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ string>value ] bi@ < ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ string>value ] bi@ = ] unit-test
-[ +gt+ ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
-[ +lt+ ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
-[ +eq+ ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ <=> ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ string>value ] bi@ = ] unit-test
-[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ <hand> ] bi@ = ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ string>value ] bi@ = ] unit-test
-[ 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
+[ 190 ] [ "AS KD JC KH 2D 2S KC" string>value ] unit-test
! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! Copyright (c) 2009 Doug Coleman.
! 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 ;
+USING: accessors arrays ascii assocs binary-search combinators
+fry kernel locals math math.bitwise math.combinatorics
+math.order math.statistics poker.arrays random sequences
+sequences.product splitting grouping lexer ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
:: (>ckf) ( rank suit -- n )
rank rank suit rank card-bitfield ;
-: >ckf ( str -- n )
+: >ckf ( string -- n )
#! Cactus Kev Format
>upper 1 cut (>ckf) ;
-: parse-cards ( str -- seq )
+: parse-cards ( string -- seq )
" " split [ >ckf ] map ;
: flush? ( cards -- ? )
] if
] if ;
-: >card-rank ( card -- str )
+: >card-rank ( card -- string )
-8 shift HEX: F bitand RANK_STR nth ;
-: >card-suit ( card -- str )
+: >card-suit ( card -- string )
{
{ [ dup 15 bit? ] [ drop "C" ] }
{ [ dup 14 bit? ] [ drop "D" ] }
[ drop "S" ]
} cond ;
-: hand-rank ( value -- rank )
+: value>rank ( value -- rank )
{
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
-: card>string ( card -- str )
+: card>string ( n -- string )
[ >card-rank ] [ >card-suit ] bi append ;
PRIVATE>
-TUPLE: hand
- { cards sequence }
- { value integer initial: 9999 } ;
-
-M: hand <=> [ value>> ] compare ;
-M: hand equal?
- over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
-
-: <hand> ( str -- hand )
- parse-cards dup hand-value hand boa ;
-
-: best-hand ( str -- hand )
- parse-cards 5 hand new
- [ dup hand-value hand boa min ] reduce-combinations ;
+: <deck> ( -- deck )
+ RANK_STR SUIT_STR 2array
+ [ concat >ckf ] V{ } product-map-as ;
-: >cards ( hand -- str )
- cards>> [ card>string ] map " " join ;
+: best-holdem-hand ( hand -- n cards )
+ 5 [ [ hand-value ] [ ] bi ] { } map>assoc-combinations
+ infimum first2 ;
-: >value ( hand -- str )
- value>> hand-rank VALUE_STR nth ;
+: value>string ( n -- string )
+ value>rank VALUE_STR nth ;
-TUPLE: deck
- { cards sequence } ;
+: hand>card-names ( hand -- string )
+ [ card>string ] map ;
-: <deck> ( -- deck )
- RANK_STR SUIT_STR 2array [ concat >ckf ] V{ } product-map-as deck boa ;
+: string>value ( string -- value )
+ parse-cards best-holdem-hand drop ;
: shuffle ( deck -- deck )
[ randomize ] change-cards ;
-: draw-card ( deck -- card ) cards>> pop ;
+ERROR: no-card card deck ;
+
+: draw-specific-card ( card deck -- card )
+ [ >ckf ] dip
+ 2dup index [ swap remove-nth! drop ] [ no-card ] if* ;
+
+: start-hands ( seq -- seq' deck )
+ <deck> [ '[ [ _ draw-specific-card ] map ] map ] keep ;
+
+:: holdem-hand% ( hole1 deck community n -- x )
+ community length 5 swap - 2 + :> #samples
+ n [
+ drop
+ deck #samples sample :> sampled
+ sampled 2 cut :> ( hole2 community2 )
+ hole1 community community2 3append :> hand1
+ hole2 community community2 3append :> hand2
+ hand1 hand2 [ best-holdem-hand 2array ] bi@ <=> +lt+ =
+ ] count ;
+
+:: compare-holdem-hands ( holes deck n -- seq )
+ n [
+ holes deck 5 sample '[
+ [ _ append best-holdem-hand drop ] keep
+ ] { } map>assoc infimum second
+ ] replicate histogram ;
+
+: (best-omaha-hand) ( seq -- pair )
+ 4 cut
+ [ 2 all-combinations ] [ 3 all-combinations ] bi*
+ 2array [ concat [ best-holdem-hand drop ] keep ] { } product-map>assoc ;
+
+: best-omaha-hand ( seq -- n cards ) (best-omaha-hand) infimum first2 ;
+
+:: compare-omaha-hands ( holes deck n -- seq )
+ n [
+ holes deck 5 sample '[
+ [ _ append best-omaha-hand drop ] keep
+ ] { } map>assoc infimum second
+ ] replicate histogram ;
+
+ERROR: bad-suit-symbol ch ;
+
+: symbol>suit ( ch -- ch' )
+ ch>upper
+ H{
+ { CHAR: ♠ CHAR: S }
+ { CHAR: ♦ CHAR: D }
+ { CHAR: ♥ CHAR: H }
+ { CHAR: ♣ CHAR: C }
+ { CHAR: S CHAR: S }
+ { CHAR: D CHAR: D }
+ { CHAR: H CHAR: H }
+ { CHAR: C CHAR: C }
+ } ?at [ bad-suit-symbol ] unless ;
+
+: card> ( string -- card )
+ 1 over [ symbol>suit ] change-nth >ckf ;
+
+: value>hand-name ( value -- string )
+ value>rank VALUE_STR nth ;
+
+SYNTAX: HAND{
+ "}" parse-tokens [ card> ] { } map-as suffix! ;
projects / factor.git / commitdiff