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