-! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! Copyright (c) 2009 Aaron Schaefer, Doug Coleman. 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 ;
+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 strings ;
+FROM: sequences => change-nth ;
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 )
- #! Cactus Kev Format
- >upper 1 cut (>ckf) ;
+#! Cactus Kev Format
+GENERIC: >ckf ( string -- n )
-: parse-cards ( str -- seq )
+M: string >ckf >upper 1 cut (>ckf) ;
+M: integer >ckf ;
+
+: parse-cards ( string -- seq )
" " split [ >ckf ] map ;
: flush? ( cards -- ? )
- HEX: F000 [ bitand ] reduce 0 = not ;
+ 0xF000 [ bitand ] reduce 0 = not ;
: rank-bits ( cards -- q )
0 [ bitor ] reduce -16 shift ;
[ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
: prime-bits ( cards -- q )
- [ HEX: FF bitand ] map-product ;
+ [ 0xFF bitand ] map-product ;
: perfect-hash-find ( q -- value )
#! magic to convert a hand's unique identifying bits to the
#! proper index for fast lookup in a table of hand values
- HEX: E91AAA35 +
+ 0xE91AAA35 +
dup -16 shift bitxor
dup 8 shift w+
dup -4 shift bitxor
- [ -8 shift HEX: 1FF bitand adjustments-table nth ]
+ [ -8 shift 0x1FF bitand adjustments-table nth ]
[ dup 2 shift w+ -19 shift ] bi
bitxor values-table nth ;
] if
] if ;
-: >card-rank ( card -- str )
- -8 shift HEX: F bitand RANK_STR nth ;
+: >card-rank ( card -- string )
+ -8 shift 0xF 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 ;
-
-: >cards ( hand -- str )
- cards>> [ card>string ] map " " join ;
-
-: >value ( hand -- str )
- 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 ;
-
+ RANK_STR SUIT_STR 2array
+ [ concat >ckf ] V{ } product-map-as randomize ;
+
+: best-holdem-hand ( hand -- n cards )
+ 5 [ [ hand-value ] [ ] bi ] { } map>assoc-combinations
+ infimum first2 ;
+
+: value>string ( n -- string )
+ value>rank VALUE_STR nth ;
+
+: hand>card-names ( hand -- string )
+ [ card>string ] map ;
+
+: string>value ( string -- value )
+ parse-cards best-holdem-hand drop ;
+
+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 ] compare +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 ;
+
+: string>hand-name ( string -- string' )
+ string>value value>hand-name ;
+
+SYNTAX: HAND{
+ "}" [ card> ] map-tokens suffix! ;