steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://projects.elasticdog.com/git/factor

db4
Slava Pestov 2009-04-05 17:20:47 -05:00
parent 1023fa51f4 8fdc852038
commit 2b042d7cb7
10 changed files with 2561 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/binary-search/binary-search-docs.factor
View File

@ -14,7 +14,7 @@ $nl
HELP: sorted-index
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
{ index index-from last-index last-index-from sorted-index } related-words

1261
extra/poker/arrays/arrays.factor Normal file
View File

File diff suppressed because it is too large Load Diff

1
extra/poker/authors.txt Normal file
View File

@ -0,0 +1 @@
Aaron Schaefer

16
extra/poker/poker-tests.factor Normal file
View File

@ -0,0 +1,16 @@
USING: accessors 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
[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] unit-test

181
extra/poker/poker.factor Normal file
View File

@ -0,0 +1,181 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii binary-search combinators kernel locals math
math.bitwise math.order poker.arrays sequences splitting ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator:
! http://www.suffecool.net/poker/evaluator.html
<PRIVATE
! Bitfield Format for Card Values:
! +-------------------------------------+
! | xxxbbbbb bbbbbbbb ssssrrrr xxpppppp |
! +-------------------------------------+
! xxxAKQJT 98765432 CDHSrrrr xxpppppp
! +-------------------------------------+
! | 00001000 00000000 01001011 00100101 | King of Diamonds
! | 00000000 00001000 00010011 00000111 | Five of Spades
! | 00000010 00000000 10001001 00011101 | Jack of Clubs
! p = prime number value of rank (deuce = 2, trey = 3, four = 5, ..., ace = 41)
! r = rank of card (deuce = 0, trey = 1, four = 2, ..., ace = 12)
! s = bit turned on depending on suit of card
! 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 1
CONSTANT: FOUR_OF_A_KIND 2
CONSTANT: FULL_HOUSE 3
CONSTANT: FLUSH 4
CONSTANT: STRAIGHT 5
CONSTANT: THREE_OF_A_KIND 6
CONSTANT: TWO_PAIR 7
CONSTANT: ONE_PAIR 8
CONSTANT: HIGH_CARD 9
CONSTANT: RANK_STR { "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"
"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-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 ;
: card-suit ( suit -- n )
{
{ "C" [ CLUB ] }
{ "D" [ DIAMOND ] }
{ "H" [ HEART ] }
{ "S" [ SPADE ] }
} case ;
: card-rank-bit ( rank -- n )
RANK_STR index 1 swap shift ;
: card-bitfield ( rank rank suit rank -- n )
{
{ card-rank-bit 16 }
{ card-suit 12 }
{ card-rank 8 }
{ card-rank-prime 0 }
} bitfield ;
:: (>ckf) ( rank suit -- n )
rank rank suit rank card-bitfield ;
: >ckf ( str -- n )
#! Cactus Kev Format
>upper 1 cut (>ckf) ;
: flush? ( cards -- ? )
HEX: F000 [ bitand ] reduce 0 = not ;
: rank-bits ( cards -- q )
0 [ bitor ] reduce -16 shift ;
: lookup ( cards table -- value )
[ rank-bits ] dip nth ;
: unique5? ( cards -- ? )
unique5-table lookup 0 > ;
: map-product ( seq quot -- n )
[ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
: prime-bits ( cards -- q )
[ HEX: FF bitand ] map-product ;
: hand-value ( cards -- value )
{
{ [ dup flush? ] [ flushes-table lookup ] }
{ [ dup unique5? ] [ unique5-table lookup ] }
[
prime-bits products-table sorted-index
values-table nth
]
} cond ;
: >card-rank ( card -- str )
-8 shift HEX: F bitand RANK_STR nth ;
: >card-suit ( card -- str )
{
{ [ dup 15 bit? ] [ drop "C" ] }
{ [ dup 14 bit? ] [ drop "D" ] }
{ [ dup 13 bit? ] [ drop "H" ] }
[ drop "S" ]
} cond ;
PRIVATE>
TUPLE: hand
{ cards sequence }
{ value integer } ;
M: hand <=> [ value>> ] compare ;
M: hand equal?
over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
: <hand> ( str -- hand )
" " split [ >ckf ] map
dup hand-value hand boa ;
: hand-rank ( hand -- rank )
value>> {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
{ [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
{ [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
{ [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
{ [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
{ [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
: >cards ( hand -- str )
cards>> [
[ >card-rank ] [ >card-suit ] bi append
] map " " join ;

1
extra/poker/summary.txt Normal file
View File

@ -0,0 +1 @@
5-card poker hand evaluator

4
extra/project-euler/054/054-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: project-euler.054 tools.test ;
IN: project-euler.054.tests
[ 376 ] [ euler054 ] unit-test

87
extra/project-euler/054/054.factor Normal file
View File

@ -0,0 +1,87 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.encodings.ascii io.files kernel math.order poker
project-euler.common sequences ;
IN: project-euler.054
! http://projecteuler.net/index.php?section=problems&id=54
! DESCRIPTION
! -----------
! In the card game poker, a hand consists of five cards and are ranked, from
! lowest to highest, in the following way:
! * High Card: Highest value card.
! * One Pair: Two cards of the same value.
! * Two Pairs: Two different pairs.
! * Three of a Kind: Three cards of the same value.
! * Straight: All cards are consecutive values.
! * Flush: All cards of the same suit.
! * Full House: Three of a kind and a pair.
! * Four of a Kind: Four cards of the same value.
! * Straight Flush: All cards are consecutive values of same suit.
! * Royal Flush: Ten, Jack, Queen, King, Ace, in same suit.
! The cards are valued in the order:
! 2, 3, 4, 5, 6, 7, 8, 9, 10, Jack, Queen, King, Ace.
! If two players have the same ranked hands then the rank made up of the
! highest value wins; for example, a pair of eights beats a pair of fives (see
! example 1 below). But if two ranks tie, for example, both players have a pair
! of queens, then highest cards in each hand are compared (see example 4
! below); if the highest cards tie then the next highest cards are compared,
! and so on.
! Consider the following five hands dealt to two players:
! Hand Player 1 Player 2 Winner
! ---------------------------------------------------------
! 1 5H 5C 6S 7S KD 2C 3S 8S 8D TD
! Pair of Fives Pair of Eights Player 2
! 2 5D 8C 9S JS AC 2C 5C 7D 8S QH
! Highest card Ace Highest card Queen Player 1
! 3 2D 9C AS AH AC 3D 6D 7D TD QD
! Three Aces Flush with Diamonds Player 2
! 4 4D 6S 9H QH QC 3D 6D 7H QD QS
! Pair of Queens Pair of Queens
! Highest card Nine Highest card Seven Player 1
! 5 2H 2D 4C 4D 4S 3C 3D 3S 9S 9D
! Full House Full House
! With Three Fours With Three Threes Player 1
! The file, poker.txt, contains one-thousand random hands dealt to two players.
! Each line of the file contains ten cards (separated by a single space): the
! first five are Player 1's cards and the last five are Player 2's cards. You
! can assume that all hands are valid (no invalid characters or repeated
! cards), each player's hand is in no specific order, and in each hand there is
! a clear winner.
! How many hands does Player 1 win?
! SOLUTION
! --------
<PRIVATE
: source-054 ( -- seq )
"resource:extra/project-euler/054/poker.txt" ascii file-lines
[ [ 14 head-slice ] [ 14 tail-slice* ] bi 2array ] map ;
: player1-win? ( hand1 hand2 -- ? )
before? ; inline
PRIVATE>
: euler054 ( -- answer )
source-054 [ [ <hand> ] map first2 player1-win? ] count ;
! [ euler054 ] 100 ave-time
! 36 ms ave run time - 2.71 SD (100 trials)
SOLUTION: euler054

1000
extra/project-euler/054/poker.txt Normal file
View File

File diff suppressed because it is too large Load Diff

18
extra/project-euler/project-euler.factor
View File

@ -1,4 +1,4 @@
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! Copyright (c) 2007, 2008, 2009 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
@ -14,14 +14,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.049 project-euler.052 project-euler.053 project-euler.055
project-euler.056 project-euler.057 project-euler.059 project-euler.067
project-euler.071 project-euler.073 project-euler.075 project-euler.076
project-euler.079 project-euler.092 project-euler.097 project-euler.099
project-euler.100 project-euler.116 project-euler.117 project-euler.134
project-euler.148 project-euler.150 project-euler.151 project-euler.164
project-euler.169 project-euler.173 project-euler.175 project-euler.186
project-euler.190 project-euler.203 project-euler.215 ;
project-euler.049 project-euler.052 project-euler.053 project-euler.054
project-euler.055 project-euler.056 project-euler.057 project-euler.059
project-euler.067 project-euler.071 project-euler.073 project-euler.075
project-euler.076 project-euler.079 project-euler.092 project-euler.097
project-euler.099 project-euler.100 project-euler.116 project-euler.117
project-euler.134 project-euler.148 project-euler.150 project-euler.151
project-euler.164 project-euler.169 project-euler.173 project-euler.175
project-euler.186 project-euler.190 project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE