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 ;
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
18 ! Bitfield Format for Card Values:
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
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
54 CONSTANT: STRAIGHT_FLUSH 0
55 CONSTANT: FOUR_OF_A_KIND 1
56 CONSTANT: FULL_HOUSE 2
59 CONSTANT: THREE_OF_A_KIND 5
64 CONSTANT: SUIT_STR { "C" "D" "H" "S" }
66 CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
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" }
71 : card-rank-prime ( rank -- n )
72 RANK_STR index { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
74 : card-rank ( rank -- n )
91 : card-suit ( suit -- n )
99 : card-rank-bit ( rank -- n )
100 RANK_STR index 1 swap shift ;
102 : card-bitfield ( rank rank suit rank -- n )
107 { card-rank-prime 0 }
110 :: (>ckf) ( rank suit -- n )
111 rank rank suit rank card-bitfield ;
114 GENERIC: >ckf ( string -- n )
116 M: string >ckf >upper 1 cut (>ckf) ;
119 : parse-cards ( string -- seq )
120 " " split [ >ckf ] map ;
122 : flush? ( cards -- ? )
123 HEX: F000 [ bitand ] reduce 0 = not ;
125 : rank-bits ( cards -- q )
126 0 [ bitor ] reduce -16 shift ;
128 : lookup ( cards table -- value )
129 [ rank-bits ] dip nth ;
131 : map-product ( seq quot -- n )
132 [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
134 : prime-bits ( cards -- q )
135 [ HEX: FF bitand ] map-product ;
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
144 [ -8 shift HEX: 1FF bitand adjustments-table nth ]
145 [ dup 2 shift w+ -19 shift ] bi
146 bitxor values-table nth ;
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
155 : >card-rank ( card -- string )
156 -8 shift HEX: F bitand RANK_STR nth ;
158 : >card-suit ( card -- string )
160 { [ dup 15 bit? ] [ drop "C" ] }
161 { [ dup 14 bit? ] [ drop "D" ] }
162 { [ dup 13 bit? ] [ drop "H" ] }
166 : value>rank ( value -- rank )
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
179 : card>string ( n -- string )
180 [ >card-rank ] [ >card-suit ] bi append ;
185 RANK_STR SUIT_STR 2array
186 [ concat >ckf ] V{ } product-map-as randomize ;
188 : best-holdem-hand ( hand -- n cards )
189 5 [ [ hand-value ] [ ] bi ] { } map>assoc-combinations
192 : value>string ( n -- string )
193 value>rank VALUE_STR nth ;
195 : hand>card-names ( hand -- string )
196 [ card>string ] map ;
198 : string>value ( string -- value )
199 parse-cards best-holdem-hand drop ;
201 ERROR: no-card card deck ;
203 : draw-specific-card ( card deck -- card )
205 2dup index [ swap remove-nth! drop ] [ no-card ] if* ;
207 : start-hands ( seq -- seq' deck )
208 <deck> [ '[ [ _ draw-specific-card ] map ] map ] keep ;
210 :: holdem-hand% ( hole1 deck community n -- x )
211 community length 5 swap - 2 + :> #samples
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+ =
221 :: compare-holdem-hands ( holes deck n -- seq )
223 holes deck 5 sample '[
224 [ _ append best-holdem-hand drop ] keep
225 ] { } map>assoc infimum second
226 ] replicate histogram ;
228 : (best-omaha-hand) ( seq -- pair )
230 [ 2 all-combinations ] [ 3 all-combinations ] bi*
231 2array [ concat [ best-holdem-hand drop ] keep ] { } product-map>assoc ;
233 : best-omaha-hand ( seq -- n cards ) (best-omaha-hand) infimum first2 ;
235 :: compare-omaha-hands ( holes deck n -- seq )
237 holes deck 5 sample '[
238 [ _ append best-omaha-hand drop ] keep
239 ] { } map>assoc infimum second
240 ] replicate histogram ;
242 ERROR: bad-suit-symbol ch ;
244 : symbol>suit ( ch -- ch' )
255 } ?at [ bad-suit-symbol ] unless ;
257 : card> ( string -- card )
258 1 over [ symbol>suit ] change-nth >ckf ;
260 : value>hand-name ( value -- string )
261 value>rank VALUE_STR nth ;
263 : string>hand-name ( string -- string' )
264 string>value value>hand-name ;
267 "}" [ card> ] map-tokens suffix! ;