Created
December 21, 2010 20:55
-
-
Save halter73/750588 to your computer and use it in GitHub Desktop.
Haskell solution the Project Euler Problem 54
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Poker | |
import Char | |
import Data.List | |
toValue :: Char -> Value | |
toValue 'A' = Ace | |
toValue 'K' = King | |
toValue 'Q' = Queen | |
toValue 'J' = Jack | |
toValue 'T' = Ten | |
toValue c = toEnum $ (-2 +) $ digitToInt c -- Why can't this be point free? | |
toSuit :: Char -> Suit | |
toSuit 'C' = Clubs | |
toSuit 'D' = Diamonds | |
toSuit 'H' = Hearts | |
toSuit 'S' = Spades | |
toCard :: String -> Card | |
toCard s = Card (toValue $ s !! 0) (toSuit $ s !! 1) | |
main = do | |
cards <- getContents | |
print $ length $ filter (\(x, y) -> hand x > hand y) | |
$ [splitAt 5 $ map toCard (words i) | i <- lines cards] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Poker (Value(..), Suit(..), Card(..), Hand, hand) where | |
import Control.Exception | |
import Data.List | |
data Value = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | |
| Jack | Queen | King | Ace deriving (Eq, Ord, Bounded, Enum, Show) | |
data Suit = Clubs | Diamonds | Hearts | Spades deriving (Eq, Show) | |
data Card = Card {val :: Value, suit :: Suit} deriving (Eq, Show) | |
data HandType = HighCard | |
| OnePair | |
| TwoPairs | |
| ThreeOfAKind | |
| Straight | |
| Flush | |
| FullHouse | |
| FourOfAKind | |
| StraightFlush | |
deriving (Eq, Ord, Show) | |
data Hand = Hand [Card] deriving (Eq, Show) | |
hand :: [Card] -> Hand | |
hand cards = | |
assert (length cards == 5) -- A poker hand most consist of five cards | |
$ assert (nub cards == cards) -- No two cards may have the same suit/val | |
$ Hand $ sortBy (\x y -> val x `compare` val y) cards -- Normalize | |
{-- | |
valCounts takes a Hand and returns a list of (Value, Count) pairs ordered | |
first by count greatest to least and then by value also greatest to least. | |
Example: | |
valCounts (hand [Card Two Clubs, Card Two Hearts, Card King Diamonds, | |
Card King Spades, Card Ace Spades]) | |
== [(King, 2), (Two, 2), (Ace, 1)] -- The result of this expression is True | |
--} | |
valCounts :: Hand -> [(Value, Int)] | |
valCounts (Hand a) = | |
sortBy (\x y -> snd y `compare` snd x) -- Put highest counts first | |
$ nubBy sameVal -- Only keep unique vals and their counts in the list | |
$ reverse -- Make nub keep only the highest count and put high vals first | |
$ scanl1 (\x y -> if sameVal x y then (fst y, snd x + 1) else y) -- inc cnt | |
[(val x, 1) | x <- a] -- Ignore suits, initialize counts to 1 | |
where sameVal x y = fst x == fst y | |
isAceLowStraight :: Hand -> Bool | |
isAceLowStraight (Hand a) = map val a == [Two, Three, Four, Five, Ace] | |
isStraight :: Hand -> Bool | |
isStraight h@(Hand a) | |
| isAceLowStraight h = True | |
| otherwise = | |
vals == take 5 [head vals..] -- equal to straight starting at head? | |
where vals = map val a | |
isFlush :: Hand -> Bool | |
isFlush (Hand a) = (length $ nub $ map suit a) == 1 -- Super easy | |
handType :: Hand -> HandType | |
handType a | |
| isStraight a && isFlush a = StraightFlush | |
| count 0 == 4 = FourOfAKind | |
| count 0 == 3 && count 1 == 2 = FullHouse | |
| isFlush a = Flush | |
| isStraight a = Straight | |
| count 0 == 3 = ThreeOfAKind | |
| count 0 == 2 && count 1 == 2 = TwoPairs | |
| count 0 == 2 = OnePair | |
| otherwise = HighCard | |
where count = (map snd (valCounts a) !!) | |
instance Ord Hand where | |
compare a b | |
| handType a < handType b = LT | |
| handType a > handType b = GT | |
| otherwise = | |
map fst (valCounts a') `compare` map fst (valCounts b') | |
where | |
fixAceLow h@(Hand x) = if isAceLowStraight h | |
then Hand $ drop 4 x ++ take 4 x -- Breaks Hand ordering | |
else h | |
a' = fixAceLow a | |
b' = fixAceLow b |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment