: apply-combination ( m combo -- seq )
[ combination-indices ] keep seq>> nths ;
+: combinations-quot ( seq k quot -- seq quot )
+ [ <combo> [ choose [0,b) ] keep ] dip
+ '[ _ apply-combination @ ] ; inline
+
PRIVATE>
+: each-combination ( seq k quot -- )
+ combinations-quot each ; inline
+
+: map-combinations ( seq k quot -- )
+ combinations-quot map ; inline
+
+: map>assoc-combinations ( seq k quot exemplar -- )
+ [ combinations-quot ] dip map>assoc ; inline
+
: combination ( m seq k -- seq )
<combo> apply-combination ;
: all-combinations ( seq k -- seq )
- <combo> [ choose [0,b) ] keep
- '[ _ apply-combination ] map ;
-
-: each-combination ( seq k quot -- )
- [ <combo> [ choose [0,b) ] keep ] dip
- '[ _ apply-combination @ ] each ; inline
-
-: map-combinations ( seq k quot -- )
- [ <combo> [ choose [0,b) ] keep ] dip
- '[ _ apply-combination @ ] map ; inline
+ [ ] combinations-quot map ;
: reduce-combinations ( seq k identity quot -- result )
[ -rot ] dip each-combination ; inline
-
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax quotations sequences ;
+USING: assocs help.markup help.syntax quotations sequences ;
IN: sequences.product
HELP: product-sequence
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
+HELP: product-map-as
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "exemplar" sequence } { "sequence" sequence } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence the same type as the " { $snippet "exemplar" } " sequence." } ;
+
+HELP: product-map>assoc
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- key value )" } } { "exemplar" assoc } { "assoc" assoc } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output assoc." } ;
+
HELP: product-each
{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
product-sequence
<product-sequence>
product-map
+ product-map-as
+ product-map>assoc
product-each
} ;
! (c)2009 Joe Groff bsd license
-USING: accessors arrays kernel locals math sequences ;
+USING: accessors arrays assocs kernel locals math sequences ;
IN: sequences.product
TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
[ ns sequences nths quot call ns lengths product-iter ] until
] unless ; inline
-:: product-map ( sequences quot -- sequence )
+:: product-map-as ( sequences quot exemplar -- sequence )
0 :> i!
- sequences [ length ] [ * ] map-reduce sequences
+ sequences [ length ] [ * ] map-reduce exemplar
[| result |
sequences [ quot call i result set-nth i 1 + i! ] product-each
result
] new-like ; inline
+: product-map ( sequences quot -- sequence )
+ over product-map-as ; inline
+
+:: product-map>assoc ( sequences quot exemplar -- assoc )
+ 0 :> i!
+ sequences [ length ] [ * ] map-reduce { }
+ [| result |
+ sequences [ quot call 2array i result set-nth i 1 + i! ] product-each
+ result
+ ] new-like exemplar assoc-like ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel math io calendar grouping
-calendar.format calendar.model fonts arrays models models.arrow
-namespaces ui.gadgets ui.gadgets.labels ui ;
+USING: accessors calendar.format calendar.model fonts fry
+grouping kernel math models.arrow namespaces sequences ui
+ui.gadgets.labels ;
IN: lcd
-: lcd-digit ( row digit -- str )
- dup CHAR: : = [ drop 10 ] [ CHAR: 0 - ] if swap {
+: lcd-digit ( digit row -- str )
+ [ dup CHAR: : = [ drop 10 ] [ CHAR: 0 - ] if ] dip {
" _ _ _ _ _ _ _ _ "
" | | | _| _| |_| |_ |_ | |_| |_| * "
" |_| | |_ _| | _| |_| | |_| | * "
" "
} nth 4 <groups> nth ;
-: lcd-row ( num row -- string )
- [ swap lcd-digit ] curry { } map-as concat ;
+: lcd-row ( row digit -- string )
+ '[ _ lcd-digit ] { } map-as concat ;
: lcd ( digit-str -- string )
- 4 [ lcd-row ] with map "\n" join ;
+ 4 iota [ lcd-row ] with map "\n" join ;
-: hh:mm:ss ( timestamp -- string )
- [ hour>> ] [ minute>> ] [ second>> >fixnum ] tri
- 3array [ pad-00 ] map ":" join ;
-
-: <time-display> ( timestamp -- gadget )
- [ hh:mm:ss lcd ] <arrow> <label-control>
+: <time-display> ( model -- gadget )
+ [ timestamp>hms lcd ] <arrow> <label-control>
"99:99:99" lcd >>string
monospace-font >>font ;
-USING: help.markup help.syntax strings ;
+USING: help.markup help.syntax math sequences strings ;
IN: poker
-HELP: <hand>
-{ $values { "str" string } { "hand" "a new " { $link hand } } }
-{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
+HELP: best-holdem-hand
+{ $values { "hand" sequence } { "n" integer } { "cards" sequence } }
+{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "seq" } "." }
{ $examples
- { $example "USING: kernel math.order poker prettyprint ;"
- "\"AC KC QC JC TC\" \"7C 6D 5H 4S 2C\" [ <hand> ] bi@ <=> ." "+lt+" }
{ $example "USING: kernel poker prettyprint ;"
- "\"TC 9C 8C 7C 6C\" \"TH 9H 8H 7H 6H\" [ <hand> ] bi@ = ." "t" }
-}
-{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
-
-HELP: best-hand
-{ $values { "str" string } { "hand" "a new " { $link hand } } }
-{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
-{ $examples
- { $example "USING: kernel poker prettyprint ;"
- "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" }
+ "HAND{ AS KD JC KH 2D 2S KC } best-holdem-hand drop value>hand-name ."
+ """"Full House""""
+ }
} ;
-HELP: >cards
-{ $values { "hand" hand } { "str" string } }
-{ $description "Outputs a string representation of a hand's cards." }
-{ $examples
- { $example "USING: poker prettyprint ;"
- "\"AC KC QC JC TC\" <hand> >cards ." "\"AC KC QC JC TC\"" }
-} ;
-
-HELP: >value
-{ $values { "hand" hand } { "str" string } }
-{ $description "Outputs a string representation of a hand's value." }
-{ $examples
- { $example "USING: poker prettyprint ;"
- "\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
-}
-{ $notes "This should not be used as a basis for hand comparison." } ;
-
HELP: <deck>
-{ $values { "deck" "a new " { $link deck } } }
-{ $description "Creates a standard deck of 52 cards." } ;
-
-HELP: shuffle
-{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } }
-{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ;
+{ $values { "deck" sequence } }
+{ $description "Returns a vector containing a standard, unshuffled deck of 52 cards." } ;
[ 529159 ] [ "5s" >ckf ] unit-test
[ 33589533 ] [ "jc" >ckf ] unit-test
-[ 7462 ] [ "7C 5D 4H 3S 2C" <hand> value>> ] unit-test
-[ 1601 ] [ "KD QS JC TH 9S" <hand> value>> ] unit-test
-[ 11 ] [ "AC AD AH AS KC" <hand> value>> ] unit-test
-[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
-[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
+[ 7462 ] [ "7C 5D 4H 3S 2C" string>value ] unit-test
+[ 1601 ] [ "KD QS JC TH 9S" string>value ] unit-test
+[ 11 ] [ "AC AD AH AS KC" string>value ] unit-test
+[ 9 ] [ "6C 5C 4C 3C 2C" string>value ] unit-test
+[ 1 ] [ "AC KC QC JC TC" string>value ] unit-test
-[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
-[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
-[ "Four of a Kind" ] [ "AC AD AH AS KC" <hand> >value ] unit-test
-[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] unit-test
+[ "High Card" ] [ "7C 5D 4H 3S 2C" string>hand-name ] unit-test
+[ "Straight" ] [ "KD QS JC TH 9S" string>hand-name ] unit-test
+[ "Four of a Kind" ] [ "AC AD AH AS KC" string>hand-name ] unit-test
+[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" string>hand-name ] unit-test
-[ "6C 5C 4C 3C 2C" ] [ "6C 5C 4C 3C 2C" <hand> >cards ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ string>value ] bi@ > ] unit-test
+[ t ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ string>value ] bi@ < ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ string>value ] bi@ = ] unit-test
-[ +gt+ ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
-[ +lt+ ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
-[ +eq+ ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ <=> ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ string>value ] bi@ = ] unit-test
-[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ <hand> ] bi@ = ] unit-test
+[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ string>value ] bi@ = ] unit-test
-[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
-[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
-
-[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test
+[ 190 ] [ "AS KD JC KH 2D 2S KC" string>value ] unit-test
! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! Copyright (c) 2009 Doug Coleman.
! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt
-USING: accessors arrays ascii binary-search combinators kernel locals math
- math.bitwise math.combinatorics math.order poker.arrays random sequences
- sequences.product splitting ;
+USING: accessors arrays ascii assocs binary-search combinators
+fry kernel locals math math.bitwise math.combinatorics
+math.order math.statistics poker.arrays random sequences
+sequences.product splitting grouping lexer strings ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
:: (>ckf) ( rank suit -- n )
rank rank suit rank card-bitfield ;
-: >ckf ( str -- n )
- #! Cactus Kev Format
- >upper 1 cut (>ckf) ;
+#! Cactus Kev Format
+GENERIC: >ckf ( string -- n )
-: parse-cards ( str -- seq )
+M: string >ckf >upper 1 cut (>ckf) ;
+M: integer >ckf ;
+
+: parse-cards ( string -- seq )
" " split [ >ckf ] map ;
: flush? ( cards -- ? )
] if
] if ;
-: >card-rank ( card -- str )
+: >card-rank ( card -- string )
-8 shift HEX: F bitand RANK_STR nth ;
-: >card-suit ( card -- str )
+: >card-suit ( card -- string )
{
{ [ dup 15 bit? ] [ drop "C" ] }
{ [ dup 14 bit? ] [ drop "D" ] }
[ drop "S" ]
} cond ;
-: hand-rank ( value -- rank )
+: value>rank ( value -- rank )
{
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
-: card>string ( card -- str )
+: card>string ( n -- string )
[ >card-rank ] [ >card-suit ] bi append ;
PRIVATE>
-TUPLE: hand
- { cards sequence }
- { value integer initial: 9999 } ;
-
-M: hand <=> [ value>> ] compare ;
-M: hand equal?
- over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
-
-: <hand> ( str -- hand )
- parse-cards dup hand-value hand boa ;
-
-: best-hand ( str -- hand )
- parse-cards 5 hand new
- [ dup hand-value hand boa min ] reduce-combinations ;
+: <deck> ( -- deck )
+ RANK_STR SUIT_STR 2array
+ [ concat >ckf ] V{ } product-map-as ;
-: >cards ( hand -- str )
- cards>> [ card>string ] map " " join ;
+: best-holdem-hand ( hand -- n cards )
+ 5 [ [ hand-value ] [ ] bi ] { } map>assoc-combinations
+ infimum first2 ;
-: >value ( hand -- str )
- value>> hand-rank VALUE_STR nth ;
+: value>string ( n -- string )
+ value>rank VALUE_STR nth ;
-TUPLE: deck
- { cards sequence } ;
+: hand>card-names ( hand -- string )
+ [ card>string ] map ;
-: <deck> ( -- deck )
- RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
+: string>value ( string -- value )
+ parse-cards best-holdem-hand drop ;
: shuffle ( deck -- deck )
[ randomize ] change-cards ;
+ERROR: no-card card deck ;
+
+: draw-specific-card ( card deck -- card )
+ [ >ckf ] dip
+ 2dup index [ swap remove-nth! drop ] [ no-card ] if* ;
+
+: start-hands ( seq -- seq' deck )
+ <deck> [ '[ [ _ draw-specific-card ] map ] map ] keep ;
+
+:: holdem-hand% ( hole1 deck community n -- x )
+ community length 5 swap - 2 + :> #samples
+ n [
+ drop
+ deck #samples sample :> sampled
+ sampled 2 cut :> ( hole2 community2 )
+ hole1 community community2 3append :> hand1
+ hole2 community community2 3append :> hand2
+ hand1 hand2 [ best-holdem-hand 2array ] bi@ <=> +lt+ =
+ ] count ;
+
+:: compare-holdem-hands ( holes deck n -- seq )
+ n [
+ holes deck 5 sample '[
+ [ _ append best-holdem-hand drop ] keep
+ ] { } map>assoc infimum second
+ ] replicate histogram ;
+
+: (best-omaha-hand) ( seq -- pair )
+ 4 cut
+ [ 2 all-combinations ] [ 3 all-combinations ] bi*
+ 2array [ concat [ best-holdem-hand drop ] keep ] { } product-map>assoc ;
+
+: best-omaha-hand ( seq -- n cards ) (best-omaha-hand) infimum first2 ;
+
+:: compare-omaha-hands ( holes deck n -- seq )
+ n [
+ holes deck 5 sample '[
+ [ _ append best-omaha-hand drop ] keep
+ ] { } map>assoc infimum second
+ ] replicate histogram ;
+
+ERROR: bad-suit-symbol ch ;
+
+: symbol>suit ( ch -- ch' )
+ ch>upper
+ H{
+ { CHAR: ♠ CHAR: S }
+ { CHAR: ♦ CHAR: D }
+ { CHAR: ♥ CHAR: H }
+ { CHAR: ♣ CHAR: C }
+ { CHAR: S CHAR: S }
+ { CHAR: D CHAR: D }
+ { CHAR: H CHAR: H }
+ { CHAR: C CHAR: C }
+ } ?at [ bad-suit-symbol ] unless ;
+
+: card> ( string -- card )
+ 1 over [ symbol>suit ] change-nth >ckf ;
+
+: value>hand-name ( value -- string )
+ value>rank VALUE_STR nth ;
+
+SYNTAX: HAND{
+ "}" parse-tokens [ card> ] { } map-as suffix! ;
projects / factor.git / commitdiff