extra/poker/poker.factor

   1 ! Copyright (c) 2009 Aaron Schaefer, Doug Coleman. All rights reserved.
   2 ! The contents of this file are licensed under the Simplified BSD License
   3 ! A copy of the license is available at http://factorcode.org/license.txt
   4 USING: accessors arrays ascii assocs binary-search combinators
   5 fry kernel locals math math.bitwise math.combinatorics
   6 math.order math.statistics poker.arrays random sequences
   7 sequences.product splitting grouping lexer strings ;
   8 FROM: sequences => change-nth ;
   9 IN: poker
  10
  11 ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
  12 ! the Senzee Perfect Hash Optimization:
  13 !     http://www.suffecool.net/poker/evaluator.html
  14 !     http://www.senzee5.com/2006/06/some-perfect-hash.html
  15
  16 <PRIVATE
  17
  18 ! Bitfield Format for Card Values:
  19
  20 !     +-------------------------------------+
  21 !     | xxxbbbbb bbbbbbbb ssssrrrr xxpppppp |
  22 !     +-------------------------------------+
  23 !       xxxAKQJT 98765432 CDHSrrrr xxpppppp
  24 !     +-------------------------------------+
  25 !     | 00001000 00000000 01001011 00100101 |  King of Diamonds
  26 !     | 00000000 00001000 00010011 00000111 |  Five of Spades
  27 !     | 00000010 00000000 10001001 00011101 |  Jack of Clubs
  28
  29 ! p = prime number value of rank (deuce = 2, trey = 3, four = 5, ..., ace = 41)
  30 ! r = rank of card (deuce = 0, trey = 1, four = 2, ..., ace = 12)
  31 ! s = bit turned on depending on suit of card
  32 ! b = bit turned on depending on rank of card
  33 ! x = bit turned off, not used
  34
  35 CONSTANT: CLUB     8
  36 CONSTANT: DIAMOND  4
  37 CONSTANT: HEART    2
  38 CONSTANT: SPADE    1
  39
  40 CONSTANT: DEUCE  0
  41 CONSTANT: TREY   1
  42 CONSTANT: FOUR   2
  43 CONSTANT: FIVE   3
  44 CONSTANT: SIX    4
  45 CONSTANT: SEVEN  5
  46 CONSTANT: EIGHT  6
  47 CONSTANT: NINE   7
  48 CONSTANT: TEN    8
  49 CONSTANT: JACK   9
  50 CONSTANT: QUEEN  10
  51 CONSTANT: KING   11
  52 CONSTANT: ACE    12
  53
  54 CONSTANT: STRAIGHT_FLUSH   0
  55 CONSTANT: FOUR_OF_A_KIND   1
  56 CONSTANT: FULL_HOUSE       2
  57 CONSTANT: FLUSH            3
  58 CONSTANT: STRAIGHT         4
  59 CONSTANT: THREE_OF_A_KIND  5
  60 CONSTANT: TWO_PAIR         6
  61 CONSTANT: ONE_PAIR         7
  62 CONSTANT: HIGH_CARD        8
  63
  64 CONSTANT: SUIT_STR { "C" "D" "H" "S" }
  65
  66 CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
  67
  68 CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
  69     "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
  70
  71 : card-rank-prime ( rank -- n )
  72     RANK_STR index { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
  73
  74 : card-rank ( rank -- n )
  75     {
  76         { "2" [ DEUCE ] }
  77         { "3" [ TREY  ] }
  78         { "4" [ FOUR  ] }
  79         { "5" [ FIVE  ] }
  80         { "6" [ SIX   ] }
  81         { "7" [ SEVEN ] }
  82         { "8" [ EIGHT ] }
  83         { "9" [ NINE  ] }
  84         { "T" [ TEN   ] }
  85         { "J" [ JACK  ] }
  86         { "Q" [ QUEEN ] }
  87         { "K" [ KING  ] }
  88         { "A" [ ACE   ] }
  89     } case ;
  90
  91 : card-suit ( suit -- n )
  92     {
  93         { "C" [ CLUB    ] }
  94         { "D" [ DIAMOND ] }
  95         { "H" [ HEART   ] }
  96         { "S" [ SPADE   ] }
  97     } case ;
  98
  99 : card-rank-bit ( rank -- n )
 100     RANK_STR index 1 swap shift ;
 101
 102 : card-bitfield ( rank rank suit rank -- n )
 103     {
 104         { card-rank-bit 16 }
 105         { card-suit 12 }
 106         { card-rank 8 }
 107         { card-rank-prime 0 }
 108     } bitfield ;
 109
 110 :: (>ckf) ( rank suit -- n )
 111     rank rank suit rank card-bitfield ;
 112
 113 #! Cactus Kev Format
 114 GENERIC: >ckf ( string -- n )
 115
 116 M: string >ckf >upper 1 cut (>ckf) ;
 117 M: integer >ckf ;
 118
 119 : parse-cards ( string -- seq )
 120     " " split [ >ckf ] map ;
 121
 122 : flush? ( cards -- ? )
 123     0xF000 [ bitand ] reduce 0 = not ;
 124
 125 : rank-bits ( cards -- q )
 126     0 [ bitor ] reduce -16 shift ;
 127
 128 : lookup ( cards table -- value )
 129     [ rank-bits ] dip nth ;
 130
 131 : map-product ( seq quot -- n )
 132     [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
 133
 134 : prime-bits ( cards -- q )
 135     [ 0xFF bitand ] map-product ;
 136
 137 : perfect-hash-find ( q -- value )
 138     #! magic to convert a hand's unique identifying bits to the
 139     #! proper index for fast lookup in a table of hand values
 140     0xE91AAA35 +
 141     dup -16 shift bitxor
 142     dup   8 shift w+
 143     dup  -4 shift bitxor
 144     [ -8 shift 0x1FF bitand adjustments-table nth ]
 145     [ dup 2 shift w+ -19 shift ] bi
 146     bitxor values-table nth ;
 147
 148 : hand-value ( cards -- value )
 149     dup flush? [ flushes-table lookup ] [
 150         dup unique5-table lookup dup 0 > [ nip ] [
 151             drop prime-bits perfect-hash-find
 152         ] if
 153     ] if ;
 154
 155 : >card-rank ( card -- string )
 156     -8 shift 0xF bitand RANK_STR nth ;
 157
 158 : >card-suit ( card -- string )
 159     {
 160         { [ dup 15 bit? ] [ drop "C" ] }
 161         { [ dup 14 bit? ] [ drop "D" ] }
 162         { [ dup 13 bit? ] [ drop "H" ] }
 163         [ drop "S" ]
 164     } cond ;
 165
 166 : value>rank ( value -- rank )
 167     {
 168         { [ dup 6185 > ] [ drop HIGH_CARD ] }        ! 1277 high card
 169         { [ dup 3325 > ] [ drop ONE_PAIR ] }         ! 2860 one pair
 170         { [ dup 2467 > ] [ drop TWO_PAIR ] }         !  858 two pair
 171         { [ dup 1609 > ] [ drop THREE_OF_A_KIND ] }  !  858 three-kind
 172         { [ dup 1599 > ] [ drop STRAIGHT ] }         !   10 straights
 173         { [ dup 322 > ]  [ drop FLUSH ] }            ! 1277 flushes
 174         { [ dup 166 > ]  [ drop FULL_HOUSE ] }       !  156 full house
 175         { [ dup 10 > ]   [ drop FOUR_OF_A_KIND ] }   !  156 four-kind
 176         [ drop STRAIGHT_FLUSH ]                      !   10 straight-flushes
 177     } cond ;
 178
 179 : card>string ( n -- string )
 180     [ >card-rank ] [ >card-suit ] bi append ;
 181
 182 PRIVATE>
 183
 184 : <deck> ( -- deck )
 185     RANK_STR SUIT_STR 2array
 186     [ concat >ckf ] V{ } product-map-as randomize ;
 187
 188 : best-holdem-hand ( hand -- n cards )
 189     5 [ [ hand-value ] [ ] bi ] { } map>assoc-combinations
 190     infimum first2 ;
 191
 192 : value>string ( n -- string )
 193     value>rank VALUE_STR nth ;
 194
 195 : hand>card-names ( hand -- string )
 196     [ card>string ] map ;
 197
 198 : string>value ( string -- value )
 199     parse-cards best-holdem-hand drop ;
 200
 201 ERROR: no-card card deck ;
 202
 203 : draw-specific-card ( card deck -- card )
 204     [ >ckf ] dip
 205     2dup index [ swap remove-nth! drop ] [ no-card ] if* ;
 206
 207 : start-hands ( seq -- seq' deck )
 208     <deck> [ '[ [ _ draw-specific-card ] map ] map ] keep ;
 209
 210 :: holdem-hand% ( hole1 deck community n -- x )
 211     community length 5 swap - 2 + :> #samples
 212     n [
 213         drop
 214         deck #samples sample :> sampled
 215         sampled 2 cut :> ( hole2 community2 )
 216         hole1 community community2 3append :> hand1
 217         hole2 community community2 3append :> hand2
 218         hand1 hand2 [ best-holdem-hand 2array ] compare +lt+ =
 219     ] count ;
 220
 221 :: compare-holdem-hands ( holes deck n -- seq )
 222     n [
 223         holes deck 5 sample '[
 224             [ _ append best-holdem-hand drop ] keep
 225         ] { } map>assoc infimum second
 226     ] replicate histogram ;
 227
 228 : (best-omaha-hand) ( seq -- pair )
 229     4 cut
 230     [ 2 all-combinations ] [ 3 all-combinations ] bi*
 231     2array [ concat [ best-holdem-hand drop ] keep ] { } product-map>assoc ;
 232
 233 : best-omaha-hand ( seq -- n cards ) (best-omaha-hand) infimum first2 ;
 234
 235 :: compare-omaha-hands ( holes deck n -- seq )
 236     n [
 237         holes deck 5 sample '[
 238             [ _ append best-omaha-hand drop ] keep
 239         ] { } map>assoc infimum second
 240     ] replicate histogram ;
 241
 242 ERROR: bad-suit-symbol ch ;
 243
 244 : symbol>suit ( ch -- ch' )
 245     ch>upper
 246     H{
 247         { CHAR: ♠ CHAR: S }
 248         { CHAR: ♦ CHAR: D }
 249         { CHAR: ♥ CHAR: H }
 250         { CHAR: ♣ CHAR: C }
 251         { CHAR: S CHAR: S }
 252         { CHAR: D CHAR: D }
 253         { CHAR: H CHAR: H }
 254         { CHAR: C CHAR: C }
 255     } ?at [ bad-suit-symbol ] unless ;
 256
 257 : card> ( string -- card )
 258     1 over [ symbol>suit ] change-nth >ckf ;
 259
 260 : value>hand-name ( value -- string )
 261     value>rank VALUE_STR nth ;
 262
 263 : string>hand-name ( string -- string' )
 264     string>value value>hand-name ;
 265
 266 SYNTAX: HAND{
 267     "}" [ card> ] map-tokens suffix! ;