! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string sequences
-math kernel ;
+math kernel quotations ;
IN: circular
HELP: <circular-string>
HELP: growing-circular
{ $description "A circular sequence that is growable." } ;
-HELP: push-circular
+HELP: circular-push
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element to a " { $link circular } " object." } ;
-HELP: push-growing-circular
+HELP: growing-circular-push
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
{ "circular" circular } }
{ $description "Advances the start index of a circular object by one." } ;
+HELP: circular-while
+{ $values
+ { "circular" circular }
+ { "quot" quotation }
+}
+{ $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ;
+
ARTICLE: "circular" "Circular sequences"
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
"Creating a new circular object:"
}
"Pushing new elements:"
{ $subsections
- push-circular
- push-growing-circular
-} ;
+ circular-push
+ growing-circular-push
+}
+"Iterating over a circular until a stop condition:"
+{ $subsections circular-while } ;
ABOUT: "circular"
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
-[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
+[ "bcd" ] [ 3 <circular-string> "abcd" [ over circular-push ] each >string ] unit-test
[ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
[ { } ] [ 3 <growing-circular> >array ] unit-test
[ { 1 2 } ] [
3 <growing-circular>
- [ 1 swap push-growing-circular ] keep
- [ 2 swap push-growing-circular ] keep >array
+ [ 1 swap growing-circular-push ] keep
+ [ 2 swap growing-circular-push ] keep >array
] unit-test
[ { 3 4 5 } ] [
3 <growing-circular> dup { 1 2 3 4 5 } [
- swap push-growing-circular
+ swap growing-circular-push
] with each >array
] unit-test
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
USING: kernel sequences math sequences.private strings
-accessors ;
+accessors locals fry ;
IN: circular
-! a circular sequence wraps another sequence, but begins at an
-! arbitrary element in the underlying sequence.
-TUPLE: circular seq start ;
+TUPLE: circular { seq read-only } { start integer } ;
: <circular> ( seq -- circular )
- 0 circular boa ;
+ 0 circular boa ; inline
<PRIVATE
+
: circular-wrap ( n circular -- n circular )
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
+
PRIVATE>
-M: circular length seq>> length ;
+M: circular length seq>> length ; inline
-M: circular virtual@ circular-wrap seq>> ;
+M: circular virtual@ circular-wrap seq>> ; inline
-M: circular virtual-exemplar seq>> ;
+M: circular virtual-exemplar seq>> ; inline
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
- circular-wrap (>>start) ;
+ circular-wrap (>>start) ; inline
: rotate-circular ( circular -- )
- [ 1 ] dip change-circular-start ;
+ [ 1 ] dip change-circular-start ; inline
-: push-circular ( elt circular -- )
+: circular-push ( elt circular -- )
[ set-first ] [ rotate-circular ] bi ;
: <circular-string> ( n -- circular )
- 0 <string> <circular> ;
+ 0 <string> <circular> ; inline
INSTANCE: circular virtual-sequence
-TUPLE: growing-circular < circular length ;
+TUPLE: growing-circular < circular { length integer } ;
-M: growing-circular length length>> ;
+M: growing-circular length length>> ; inline
<PRIVATE
: full? ( circular -- ? )
- [ length ] [ seq>> length ] bi = ;
+ [ length ] [ seq>> length ] bi = ; inline
PRIVATE>
-: push-growing-circular ( elt circular -- )
- dup full? [ push-circular ]
+: growing-circular-push ( elt circular -- )
+ dup full? [ circular-push ]
[ [ 1 + ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
- { } new-sequence 0 0 growing-circular boa ;
+ { } new-sequence 0 0 growing-circular boa ; inline
+
+TUPLE: circular-iterator
+ { circular read-only } { n integer } { last-start integer } ;
+
+: <circular-iterator> ( circular -- obj )
+ 0 0 circular-iterator boa ; inline
+
+<PRIVATE
+
+: (circular-while) ( iterator quot: ( obj -- ? ) -- )
+ [ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
+ rot [ [ dup n>> >>last-start ] dip ] when
+ over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
+ 2drop
+ ] [
+ [ [ 1 + ] change-n ] dip (circular-while)
+ ] if ; inline recursive
+
+PRIVATE>
+
+: circular-while ( circular quot: ( obj -- ? ) -- )
+ [ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline
strings math calendar io.files.info io.files.info.unix ;
IN: io.files.unix
+HELP: add-file-permissions
+{ $values
+ { "path" "a pathname string" }
+ { "n" integer } }
+{ $description "Ensures that the bits from " { $snippet "n" } " are set in the Unix file permissions for a given file." } ;
+
+HELP: remove-file-permissions
+{ $values
+ { "path" "a pathname string" }
+ { "n" integer } }
+{ $description "Ensures that the bits from " { $snippet "n" } " are cleared in the Unix file permissions for a given file." } ;
+
HELP: file-group-id
{ $values
{ "path" "a pathname string" }
other-write?
other-execute?
}
-"Writing all file permissions:"
-{ $subsections set-file-permissions }
+"Changing file permissions:"
+{ $subsections
+ add-file-permissions
+ remove-file-permissions
+ set-file-permissions
+}
"Writing individual file permissions:"
{ $subsections
set-uid
vocabs.loader calendar calendar.unix io.files.info
io.files.types io.backend io.directories unix unix.stat
unix.time unix.users unix.groups classes.struct
-specialized-arrays ;
+specialized-arrays literals ;
SPECIALIZED-ARRAY: timeval
IN: io.files.info.unix
CONSTANT: OTHER-READ OCT: 0000004
CONSTANT: OTHER-WRITE OCT: 0000002
CONSTANT: OTHER-EXECUTE OCT: 0000001
+CONSTANT: ALL-READ OCT: 0000444
+CONSTANT: ALL-WRITE OCT: 0000222
+CONSTANT: ALL-EXECUTE OCT: 0000111
: uid? ( obj -- ? ) UID file-mode? ;
: gid? ( obj -- ? ) GID file-mode? ;
: file-permissions ( path -- n )
normalize-path file-info permissions>> ;
+: add-file-permissions ( path n -- )
+ over file-permissions bitor set-file-permissions ;
+
+: remove-file-permissions ( path n -- )
+ over file-permissions [ bitnot ] dip bitand set-file-permissions ;
+
M: unix copy-file-and-info ( from to -- )
[ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
: 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
-
HELP: minmax
{ $values { "seq" sequence } { "min" real } { "max" real } }
-{ $description "Finds the minimum and maximum elements of " { $snippet "seq" } " in one pass." }
+{ $description "Finds the minimum and maximum elements of " { $snippet "seq" } " in one pass. Throws an error on an empty sequence." }
{ $examples
{ $example "USING: arrays math.statistics prettyprint ;"
"{ 1 2 3 } minmax 2array ."
histogram >alist
[ ] [ [ [ second ] bi@ > ] 2keep ? ] map-reduce first ;
+ERROR: empty-sequence ;
+
: minmax ( seq -- min max )
- #! find the min and max of a seq in one pass
- [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
+ [
+ empty-sequence
+ ] [
+ [ first dup ] keep [ [ min ] [ max ] bi-curry bi* ] each
+ ] if-empty ;
: range ( seq -- x )
minmax swap - ;
sequence length <growing-circular> :> growing
sequence-parser
[
- current growing push-growing-circular
+ current growing growing-circular-push
sequence growing sequence=
] take-until :> found
growing sequence sequence= [
! (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
spot get '[ _ char>> blank? not ] skip-until ;
: string-matches? ( string circular spot -- ? )
- char>> over push-circular sequence= ;
+ char>> over circular-push sequence= ;
: take-string ( match -- string )
dup length <circular-string>
:: parse-text ( -- string )
3 f <array> <circular> :> circ
depth get zero? :> no-text [| char |
- char circ push-circular
+ char circ circular-push
circ assure-no-]]>
no-text [ char blank? char CHAR: < = or [
char 1string t pre/post-content
"10 [ even? ] pusher [ each ] dip ."
"V{ 0 2 4 6 8 }"
}
-{ $notes "Used to implement the " { $link filter } " word." } ;
+{ $notes "Used to implement the " { $link filter } " word. Compare this word with " { $link accumulator } ", which is an unfiltering version." } ;
HELP: trim-head
{ $values
ARTICLE: "sequences-f" "The f object as a sequence"
"The " { $link f } " object supports the sequence protocol in a trivial way. It responds with a length of zero and throws an out of bounds error when an attempt is made to access elements." ;
+ARTICLE: "sequences-combinator-implementation" "Implementing sequence combinators"
+"Creating a new sequence unconditionally:"
+{ $subsections
+ accumulator
+ accumulator-for
+}
+"Creating a new sequence conditionally:"
+{ $subsections
+ pusher
+ pusher-for
+ 2pusher
+} ;
+
ARTICLE: "sequences" "Sequence operations"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Using sequences for control flow:"
{ $subsections "sequences-if" }
"For inner loops:"
-{ $subsections "sequences-unsafe" } ;
+{ $subsections "sequences-unsafe" }
+"Implemeting sequence combinators:"
+{ $subsections "sequences-combinator-implementation" } ;
ABOUT: "sequences"
! 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, shuffled deck of 52 cards." } ;
-USING: accessors kernel math.order poker poker.private tools.test ;
+USING: accessors kernel math math.order poker poker.private
+tools.test ;
IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test
[ 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 ;
-
-: >cards ( hand -- str )
- cards>> [ card>string ] map " " join ;
-
-: >value ( hand -- str )
- value>> hand-rank VALUE_STR nth ;
-
-TUPLE: deck
- { cards sequence } ;
-
: <deck> ( -- deck )
- RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
-
-: shuffle ( deck -- deck )
- [ randomize ] change-cards ;
-
+ RANK_STR SUIT_STR 2array
+ [ concat >ckf ] V{ } product-map-as randomize ;
+
+: best-holdem-hand ( hand -- n cards )
+ 5 [ [ hand-value ] [ ] bi ] { } map>assoc-combinations
+ infimum first2 ;
+
+: value>string ( n -- string )
+ value>rank VALUE_STR nth ;
+
+: hand>card-names ( hand -- string )
+ [ card>string ] map ;
+
+: string>value ( string -- value )
+ parse-cards best-holdem-hand drop ;
+
+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 ;
+
+: string>hand-name ( string -- string' )
+ string>value value>hand-name ;
+
+SYNTAX: HAND{
+ "}" parse-tokens [ card> ] { } map-as suffix! ;
PRIVATE>
: euler054 ( -- answer )
- source-054 [ [ <hand> ] map first2 before? ] count ;
+ source-054 [ [ string>value ] map first2 before? ] count ;
! [ euler054 ] 100 ave-time
! 34 ms ave run time - 2.65 SD (100 trials)
55 [1,b] [ (generator) ] map <circular> ;
: advance ( lag -- )
- [ { 0 31 } swap nths sum 1000000 rem ] keep push-circular ;
+ [ { 0 31 } swap nths sum 1000000 rem ] keep circular-push ;
: next ( lag -- n )
[ first ] [ advance ] bi ;
projects / factor.git / commitdiff