-! 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, 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 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
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 )
:: (>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 )
+
+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 ;
: lookup ( cards table -- value )
[ rank-bits ] dip nth ;
-: unique5? ( cards -- ? )
- unique5-table lookup 0 > ;
-
: map-product ( seq quot -- n )
[ 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 ;
: hand-value ( cards -- value )
- {
- { [ dup flush? ] [ flushes-table lookup ] }
- { [ dup unique5? ] [ unique5-table lookup ] }
- [ prime-bits perfect-hash-find ]
- } cond ;
+ dup flush? [ flushes-table lookup ] [
+ dup unique5-table lookup dup 0 > [ nip ] [
+ drop prime-bits perfect-hash-find
+ ] 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 ;
-PRIVATE>
-
-TUPLE: hand
- { cards sequence }
- { value integer } ;
-
-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 ;
-
-: hand-rank ( hand -- rank )
- value>> {
+: value>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
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
-: >value ( hand -- str )
- hand-rank VALUE_STR nth ;
+: card>string ( n -- string )
+ [ >card-rank ] [ >card-suit ] bi append ;
+
+PRIVATE>
-: >cards ( hand -- str )
- cards>> [
- [ >card-rank ] [ >card-suit ] bi append
- ] map " " join ;
+: <deck> ( -- deck )
+ 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! ;
projects / factor.git / blobdiff