poker: simplify a bit.

locals-and-roots
John Benediktsson 2016-04-14 14:07:37 -07:00
parent 950f42eedd
commit 4945269664
1 changed files with 21 additions and 55 deletions

View File

@ -31,25 +31,6 @@ IN: poker
! b = bit turned on depending on rank of card
! x = bit turned off, not used
CONSTANT: CLUB 8
CONSTANT: DIAMOND 4
CONSTANT: HEART 2
CONSTANT: SPADE 1
CONSTANT: DEUCE 0
CONSTANT: TREY 1
CONSTANT: FOUR 2
CONSTANT: FIVE 3
CONSTANT: SIX 4
CONSTANT: SEVEN 5
CONSTANT: EIGHT 6
CONSTANT: NINE 7
CONSTANT: TEN 8
CONSTANT: JACK 9
CONSTANT: QUEEN 10
CONSTANT: KING 11
CONSTANT: ACE 12
CONSTANT: STRAIGHT_FLUSH 0
CONSTANT: FOUR_OF_A_KIND 1
CONSTANT: FULL_HOUSE 2
@ -60,43 +41,24 @@ CONSTANT: TWO_PAIR 6
CONSTANT: ONE_PAIR 7
CONSTANT: HIGH_CARD 8
CONSTANT: SUIT_STR { "C" "D" "H" "S" }
CONSTANT: SUITS { "C" "D" "H" "S" }
CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
CONSTANT: RANKS { "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: VALUES { "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 )
RANK_STR index { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
: card-suit ( suit -- n )
SUITS index 3 swap - 2^ ;
: card-rank ( rank -- n )
{
{ "2" [ DEUCE ] }
{ "3" [ TREY ] }
{ "4" [ FOUR ] }
{ "5" [ FIVE ] }
{ "6" [ SIX ] }
{ "7" [ SEVEN ] }
{ "8" [ EIGHT ] }
{ "9" [ NINE ] }
{ "T" [ TEN ] }
{ "J" [ JACK ] }
{ "Q" [ QUEEN ] }
{ "K" [ KING ] }
{ "A" [ ACE ] }
} case ;
RANKS index ;
: card-suit ( suit -- n )
{
{ "C" [ CLUB ] }
{ "D" [ DIAMOND ] }
{ "H" [ HEART ] }
{ "S" [ SPADE ] }
} case ;
: card-rank-prime ( rank -- n )
card-rank { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
: card-rank-bit ( rank -- n )
RANK_STR index 1 swap shift ;
card-rank 2^ ;
: card-bitfield ( rank rank suit rank -- n )
{
@ -113,6 +75,7 @@ CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
GENERIC: >ckf ( string -- n )
M: string >ckf >upper 1 cut (>ckf) ;
M: integer >ckf ;
: parse-cards ( string -- seq )
@ -142,14 +105,18 @@ M: integer >ckf ;
bitxor values-table nth ;
: hand-value ( cards -- value )
dup flush? [ flushes-table lookup ] [
dup unique5-table lookup dup 0 > [ nip ] [
dup flush? [
flushes-table lookup
] [
dup unique5-table lookup dup 0 > [
nip
] [
drop prime-bits perfect-hash-find
] if
] if ;
: >card-rank ( card -- string )
-8 shift 0xF bitand RANK_STR nth ;
-8 shift 0xF bitand RANKS nth ;
: >card-suit ( card -- string )
{
@ -178,7 +145,7 @@ M: integer >ckf ;
PRIVATE>
: <deck> ( -- deck )
RANK_STR SUIT_STR 2array
RANKS SUITS 2array
[ concat >ckf ] V{ } product-map-as randomize ;
: best-holdem-hand ( hand -- n cards )
@ -186,7 +153,7 @@ PRIVATE>
infimum first2 ;
: value>string ( n -- string )
value>rank VALUE_STR nth ;
value>rank VALUES nth ;
: hand>card-names ( hand -- string )
[ card>string ] map ;
@ -238,8 +205,7 @@ ERROR: no-card card deck ;
ERROR: bad-suit-symbol ch ;
: symbol>suit ( ch -- ch' )
ch>upper
H{
ch>upper H{
{ CHAR: ♠ CHAR: S }
{ CHAR: ♦ CHAR: D }
{ CHAR: ♥ CHAR: H }
@ -254,7 +220,7 @@ ERROR: bad-suit-symbol ch ;
1 over [ symbol>suit ] change-nth >ckf ;
: value>hand-name ( value -- string )
value>rank VALUE_STR nth ;
value>rank VALUES nth ;
: string>hand-name ( string -- string' )
string>value value>hand-name ;