Merge branch 'master' of git://factorcode.org/git/factor

basis/circular/circular-docs.factor

@@ -1,7 +1,7 @@
 ! 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>
@@ -33,12 +33,12 @@ HELP: circular
 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." } ;
@@ -48,6 +48,13 @@ HELP: rotate-circular
     { "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:"
@@ -63,8 +70,10 @@ ARTICLE: "circular" "Circular sequences"
 }
 "Pushing new elements:"
 { $subsections
-    push-circular
+    circular-push
-    push-growing-circular
+    growing-circular-push
-} ;
+}
+"Iterating over a circular until a stop condition:"
+{ $subsections circular-while } ;
 
 ABOUT: "circular"

basis/circular/circular-tests.factor

@@ -23,7 +23,7 @@ IN: circular.tests
 [ "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
 
@@ -34,11 +34,11 @@ IN: circular.tests
 [ { } ] [ 3 <growing-circular> >array ] unit-test
 [ { 1 2 } ] [
     3 <growing-circular>
-    [ 1 swap push-growing-circular ] keep
+    [ 1 swap growing-circular-push ] keep
-    [ 2 swap push-growing-circular ] keep >array
+    [ 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

basis/circular/circular.factor

@@ -1,57 +1,79 @@
 ! 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
+TUPLE: circular { seq read-only } { start integer } ;
-! arbitrary element in the underlying sequence.
-TUPLE: circular seq start ;
 
 : <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 -- )
+: growing-circular-push ( elt circular -- )
-    dup full? [ push-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

basis/io/files/info/unix/unix-docs.factor

@@ -4,6 +4,18 @@ USING: classes help.markup help.syntax io.streams.string
 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" }
@@ -231,8 +243,12 @@ ARTICLE: "unix-file-permissions" "Unix file permissions"
     other-write?
     other-execute?
 }
-"Writing all file permissions:"
+"Changing file permissions:"
-{ $subsections set-file-permissions }
+{ $subsections
+    add-file-permissions
+    remove-file-permissions
+    set-file-permissions
+}
 "Writing individual file permissions:"
 { $subsections
     set-uid

basis/io/files/info/unix/unix.factor

@@ -5,7 +5,7 @@ sequences combinators combinators.short-circuit alien.c-types
 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
 
@@ -134,6 +134,9 @@ CONSTANT: OTHER-ALL     OCT: 0000007
 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? ;
@@ -176,6 +179,12 @@ CONSTANT: OTHER-EXECUTE OCT: 0000001
 : 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 ;
 

basis/math/combinatorics/combinatorics.factor

@@ -103,23 +103,26 @@ C: <combo> combo
 : 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
+    [ ] combinations-quot map ;
-    '[ _ 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
 
 : reduce-combinations ( seq k identity quot -- result )
     [ -rot ] dip each-combination ; inline
-

basis/math/statistics/statistics-docs.factor

@@ -38,7 +38,7 @@ HELP: range
 
 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 ."

basis/math/statistics/statistics.factor

@@ -89,9 +89,14 @@ PRIVATE>
     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 - ;

basis/sequences/parser/parser.factor

@@ -83,7 +83,7 @@ TUPLE: sequence-parser sequence n ;
     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= [

basis/sequences/product/product-docs.factor

@@ -1,5 +1,5 @@
 ! (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
@@ -44,6 +44,14 @@ HELP: product-map
 { $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" } "." }
@@ -57,6 +65,8 @@ ARTICLE: "sequences.product" "Product sequences"
     product-sequence
     <product-sequence>
     product-map
+    product-map-as
+    product-map>assoc
     product-each
 } ;
 

basis/sequences/product/product.factor

@@ -1,5 +1,5 @@
 ! (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 } ;
@@ -55,11 +55,21 @@ M: product-sequence nth
         [ 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

basis/xml/tokenize/tokenize.factor

@@ -86,7 +86,7 @@ HINTS: next* { spot } ;
     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>
@@ -147,7 +147,7 @@ HINTS: next* { spot } ;
 :: 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

core/sequences/sequences-docs.factor

@@ -1002,7 +1002,7 @@ HELP: pusher
            "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
@@ -1671,6 +1671,19 @@ ARTICLE: "sequences-comparing" "Comparing sequences"
 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
@@ -1708,6 +1721,8 @@ $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"

extra/lcd/lcd.factor

@@ -1,30 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel math io calendar grouping
+USING: accessors calendar.format calendar.model fonts fry
-calendar.format calendar.model fonts arrays models models.arrow
+grouping kernel math models.arrow namespaces sequences ui
-namespaces ui.gadgets ui.gadgets.labels ui ;
+ui.gadgets.labels ;
 IN: lcd
 
-: lcd-digit ( row digit -- str )
+: lcd-digit ( digit row -- str )
-    dup CHAR: : = [ drop 10 ] [ CHAR: 0 - ] if swap {
+    [ dup CHAR: : = [ drop 10 ] [ CHAR: 0 - ] if ] dip {
         "  _       _  _       _   _   _   _   _      "
         " | |  |   _| _| |_| |_  |_    | |_| |_|  *  "
         " |_|  |  |_  _|   |  _| |_|   | |_|   |  *  "
         "                                            "
     } nth 4 <groups> nth ;
 
-: lcd-row ( num row -- string )
+: lcd-row ( row digit -- string )
-    [ swap lcd-digit ] curry { } map-as concat ;
+    '[ _ 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 )
+: <time-display> ( model -- gadget )
-    [ hour>> ] [ minute>> ] [ second>> >fixnum ] tri
+    [ timestamp>hms lcd ] <arrow> <label-control>
-    3array [ pad-00 ] map ":" join ;
-
-: <time-display> ( timestamp -- gadget )
-    [ hh:mm:ss lcd ] <arrow> <label-control>
     "99:99:99" lcd >>string
     monospace-font >>font ;
 

extra/poker/poker-docs.factor

@@ -1,46 +1,16 @@
-USING: help.markup help.syntax strings ;
+USING: help.markup help.syntax math sequences strings ;
 IN: poker
 
-HELP: <hand>
+HELP: best-holdem-hand
-{ $values { "str" string } { "hand" "a new " { $link hand } } }
+{ $values { "hand" sequence } { "n" integer } { "cards" sequence } }
-{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
+{ $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 } } }
+{ $values { "deck" sequence } }
-{ $description "Creates a standard deck of 52 cards." } ;
+{ $description "Returns a vector containing a standard, shuffled 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." } ;

extra/poker/poker-tests.factor

@@ -1,30 +1,28 @@
-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
+[ 7462 ] [ "7C 5D 4H 3S 2C" string>value ] unit-test
-[ 1601 ] [ "KD QS JC TH 9S" <hand> value>> ] unit-test
+[ 1601 ] [ "KD QS JC TH 9S" string>value ] unit-test
-[ 11 ] [ "AC AD AH AS KC" <hand> value>> ] unit-test
+[ 11 ] [ "AC AD AH AS KC" string>value ] unit-test
-[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
+[ 9 ] [ "6C 5C 4C 3C 2C" string>value ] unit-test
-[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
+[ 1 ] [ "AC KC QC JC TC" string>value ] unit-test
 
-[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
+[ "High Card" ] [ "7C 5D 4H 3S 2C" string>hand-name ] unit-test
-[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
+[ "Straight" ] [ "KD QS JC TH 9S" string>hand-name ] unit-test
-[ "Four of a Kind" ] [ "AC AD AH AS KC" <hand> >value ] unit-test
+[ "Four of a Kind" ] [ "AC AD AH AS KC" string>hand-name ] unit-test
-[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] 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
+[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ string>value ] 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" [ <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
+[ 190 ] [ "AS KD JC KH 2D 2S KC" string>value ] 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

extra/poker/poker.factor

@@ -1,9 +1,11 @@
 ! 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
+USING: accessors arrays ascii assocs binary-search combinators
-    math.bitwise math.combinatorics math.order poker.arrays random sequences
+fry kernel locals math math.bitwise math.combinatorics
-    sequences.product splitting ;
+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
@@ -108,11 +110,13 @@ CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
 :: (>ckf) ( rank suit -- n )
     rank rank suit rank card-bitfield ;
 
-: >ckf ( str -- n )
+#! Cactus Kev Format
-    #! Cactus Kev Format
+GENERIC: >ckf ( string -- n )
-    >upper 1 cut (>ckf) ;
 
-: parse-cards ( str -- seq )
+M: string >ckf >upper 1 cut (>ckf) ;
+M: integer >ckf ;
+
+: parse-cards ( string -- seq )
     " " split [ >ckf ] map ;
 
 : flush? ( cards -- ? )
@@ -148,10 +152,10 @@ CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
         ] 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" ] }
@@ -159,7 +163,7 @@ CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
         [ 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
@@ -172,38 +176,92 @@ CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
         [ 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 ;
+    RANK_STR SUIT_STR 2array
+    [ concat >ckf ] V{ } product-map-as randomize ;
 
-: shuffle ( deck -- deck )
+: best-holdem-hand ( hand -- n cards )
-    [ randomize ] change-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! ;

extra/project-euler/054/054.factor

@@ -76,7 +76,7 @@ IN: project-euler.054
 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)

extra/project-euler/186/186.factor

@@ -45,7 +45,7 @@ IN: project-euler.186
     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 ;