extra/poker/poker.factor

   1 ! Copyright (c) 2009 Aaron Schaefer.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii binary-search combinators kernel locals math
   4     math.bitwise math.order poker.arrays sequences splitting ;
   5 IN: poker
   6
   7 ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
   8 ! the Senzee Perfect Hash Optimization:
   9 !     http://www.suffecool.net/poker/evaluator.html
  10 !     http://www.senzee5.com/2006/06/some-perfect-hash.html
  11
  12 <PRIVATE
  13
  14 ! Bitfield Format for Card Values:
  15
  16 !     +-------------------------------------+
  17 !     | xxxbbbbb bbbbbbbb ssssrrrr xxpppppp |
  18 !     +-------------------------------------+
  19 !       xxxAKQJT 98765432 CDHSrrrr xxpppppp
  20 !     +-------------------------------------+
  21 !     | 00001000 00000000 01001011 00100101 |  King of Diamonds
  22 !     | 00000000 00001000 00010011 00000111 |  Five of Spades
  23 !     | 00000010 00000000 10001001 00011101 |  Jack of Clubs
  24
  25 ! p = prime number value of rank (deuce = 2, trey = 3, four = 5, ..., ace = 41)
  26 ! r = rank of card (deuce = 0, trey = 1, four = 2, ..., ace = 12)
  27 ! s = bit turned on depending on suit of card
  28 ! b = bit turned on depending on rank of card
  29 ! x = bit turned off, not used
  30
  31 CONSTANT: CLUB     8
  32 CONSTANT: DIAMOND  4
  33 CONSTANT: HEART    2
  34 CONSTANT: SPADE    1
  35
  36 CONSTANT: DEUCE  0
  37 CONSTANT: TREY   1
  38 CONSTANT: FOUR   2
  39 CONSTANT: FIVE   3
  40 CONSTANT: SIX    4
  41 CONSTANT: SEVEN  5
  42 CONSTANT: EIGHT  6
  43 CONSTANT: NINE   7
  44 CONSTANT: TEN    8
  45 CONSTANT: JACK   9
  46 CONSTANT: QUEEN  10
  47 CONSTANT: KING   11
  48 CONSTANT: ACE    12
  49
  50 CONSTANT: STRAIGHT_FLUSH   1
  51 CONSTANT: FOUR_OF_A_KIND   2
  52 CONSTANT: FULL_HOUSE       3
  53 CONSTANT: FLUSH            4
  54 CONSTANT: STRAIGHT         5
  55 CONSTANT: THREE_OF_A_KIND  6
  56 CONSTANT: TWO_PAIR         7
  57 CONSTANT: ONE_PAIR         8
  58 CONSTANT: HIGH_CARD        9
  59
  60 CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
  61
  62 CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
  63     "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
  64
  65 : card-rank-prime ( rank -- n )
  66     RANK_STR index { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
  67
  68 : card-rank ( rank -- n )
  69     {
  70         { "2" [ DEUCE ] }
  71         { "3" [ TREY  ] }
  72         { "4" [ FOUR  ] }
  73         { "5" [ FIVE  ] }
  74         { "6" [ SIX   ] }
  75         { "7" [ SEVEN ] }
  76         { "8" [ EIGHT ] }
  77         { "9" [ NINE  ] }
  78         { "T" [ TEN   ] }
  79         { "J" [ JACK  ] }
  80         { "Q" [ QUEEN ] }
  81         { "K" [ KING  ] }
  82         { "A" [ ACE   ] }
  83     } case ;
  84
  85 : card-suit ( suit -- n )
  86     {
  87         { "C" [ CLUB    ] }
  88         { "D" [ DIAMOND ] }
  89         { "H" [ HEART   ] }
  90         { "S" [ SPADE   ] }
  91     } case ;
  92
  93 : card-rank-bit ( rank -- n )
  94     RANK_STR index 1 swap shift ;
  95
  96 : card-bitfield ( rank rank suit rank -- n )
  97     {
  98         { card-rank-bit 16 }
  99         { card-suit 12 }
 100         { card-rank 8 }
 101         { card-rank-prime 0 }
 102     } bitfield ;
 103
 104 :: (>ckf) ( rank suit -- n )
 105     rank rank suit rank card-bitfield ;
 106
 107 : >ckf ( str -- n )
 108     #! Cactus Kev Format
 109     >upper 1 cut (>ckf) ;
 110
 111 : flush? ( cards -- ? )
 112     HEX: F000 [ bitand ] reduce 0 = not ;
 113
 114 : rank-bits ( cards -- q )
 115     0 [ bitor ] reduce -16 shift ;
 116
 117 : lookup ( cards table -- value )
 118     [ rank-bits ] dip nth ;
 119
 120 : unique5? ( cards -- ? )
 121     unique5-table lookup 0 > ;
 122
 123 : map-product ( seq quot -- n )
 124     [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
 125
 126 : prime-bits ( cards -- q )
 127     [ HEX: FF bitand ] map-product ;
 128
 129 : perfect-hash-find ( q -- value )
 130     #! magic to convert a hand's unique identifying bits to the
 131     #! proper index for fast lookup in a table of hand values
 132     HEX: E91AAA35 +
 133     dup -16 shift bitxor
 134     dup   8 shift w+
 135     dup  -4 shift bitxor
 136     [ -8 shift HEX: 1FF bitand adjustments-table nth ]
 137     [ dup 2 shift w+ -19 shift ] bi
 138     bitxor values-table nth ;
 139
 140 : hand-value ( cards -- value )
 141     {
 142         { [ dup flush?   ] [ flushes-table lookup ] }
 143         { [ dup unique5? ] [ unique5-table lookup ] }
 144         [ prime-bits perfect-hash-find ]
 145     } cond ;
 146
 147 : >card-rank ( card -- str )
 148     -8 shift HEX: F bitand RANK_STR nth ;
 149
 150 : >card-suit ( card -- str )
 151     {
 152         { [ dup 15 bit? ] [ drop "C" ] }
 153         { [ dup 14 bit? ] [ drop "D" ] }
 154         { [ dup 13 bit? ] [ drop "H" ] }
 155         [ drop "S" ]
 156     } cond ;
 157
 158 : hand-rank ( hand -- rank )
 159     value>> {
 160         { [ dup 6185 > ] [ drop HIGH_CARD ] }        ! 1277 high card
 161         { [ dup 3325 > ] [ drop ONE_PAIR ] }         ! 2860 one pair
 162         { [ dup 2467 > ] [ drop TWO_PAIR ] }         !  858 two pair
 163         { [ dup 1609 > ] [ drop THREE_OF_A_KIND ] }  !  858 three-kind
 164         { [ dup 1599 > ] [ drop STRAIGHT ] }         !   10 straights
 165         { [ dup 322 > ]  [ drop FLUSH ] }            ! 1277 flushes
 166         { [ dup 166 > ]  [ drop FULL_HOUSE ] }       !  156 full house
 167         { [ dup 10 > ]   [ drop FOUR_OF_A_KIND ] }   !  156 four-kind
 168         [ drop STRAIGHT_FLUSH ]                      !   10 straight-flushes
 169     } cond ;
 170
 171 PRIVATE>
 172
 173 TUPLE: hand
 174     { cards sequence }
 175     { value integer } ;
 176
 177 M: hand <=> [ value>> ] compare ;
 178 M: hand equal?
 179     over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
 180
 181 : <hand> ( str -- hand )
 182     " " split [ >ckf ] map
 183     dup hand-value hand boa ;
 184
 185 : >cards ( hand -- str )
 186     cards>> [
 187         [ >card-rank ] [ >card-suit ] bi append
 188     ] map " " join ;
 189
 190 : >value ( hand -- str )
 191     hand-rank VALUE_STR nth ;