Add Haskell solution for Problem 54

Haskell/p054.hs

@@ -0,0 +1,216 @@
+-- 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        Player 2
+--                Pair of Fives     Pair of Eights
+--
+--  2	 	5D 8C 9S JS AC    2C 5C 7D 8S QH        Player 1
+--      Highest card Ace   Highest card Queen
+--
+--  3	 	2D 9C AS AH AC    3D 6D 7D TD QD        Player 2
+--        Three Aces      Flush with Diamonds
+--
+--  4	 	4D 6S 9H QH QC    3D 6D 7H QD QS        Player 1
+--       Pair of Queens    Pair of Queens
+--      Highest card Nine Highest card Seven
+--
+--  5	 	2H 2D 4C 4D 4S    3C 3D 3S 9S 9D        Player 1
+--         Full House  	    Full House
+--      With Three Fours  With Three Threes
+--
+--      The file, p054_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?
+
+import Data.List
+import Data.Function
+import System.IO
+
+data Value = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King | Ace
+             deriving (Eq, Ord, Show, Read, Bounded, Enum)
+data Suit = Hearts | Diamonds | Clubs | Spades deriving (Eq, Show)
+
+data Card = Card { value :: Value
+                 , suit :: Suit
+                 } deriving (Eq, Show)
+
+instance Ord Card where
+    (Card v1 _) `compare` (Card v2 _) = v1 `compare` v2
+
+type Hand = [Card]
+
+data PokerGame = PokerGame { player1 :: Hand
+                           , player2 :: Hand
+                           } deriving (Eq, Show)
+
+getValue :: Char -> Value
+getValue '2' = Two
+getValue '3' = Three
+getValue '4' = Four
+getValue '5' = Five
+getValue '6' = Six
+getValue '7' = Seven
+getValue '8' = Eight
+getValue '9' = Nine
+getValue 'T' = Ten
+getValue 'J' = Jack
+getValue 'Q' = Queen
+getValue 'K' = King
+getValue 'A' = Ace
+
+getSuit :: Char -> Suit
+getSuit 'H' = Hearts
+getSuit 'D' = Diamonds
+getSuit 'C' = Clubs
+getSuit 'S' = Spades
+
+readCard :: String -> Card
+readCard (v:s:_) = Card{value=getValue v,suit=getSuit s}
+
+readGame :: String -> PokerGame
+readGame g = PokerGame{player1=map readCard (take 5 (words g)), player2=map readCard (take 5 (reverse (words g)))} 
+
+royalFlush :: Hand -> Bool
+royalFlush h =
+    let hs = sort h
+    in length (head (groupBy ((==) `on` suit) hs)) == 5 && [Ten .. Ace] == map value hs
+
+straightFlush :: Hand -> Bool
+straightFlush h = 
+    let hs@(x:_) = sort h
+        start = value x
+    in length (head (groupBy ((==) `on` suit) hs)) == 5 &&
+        take 5 [start..] == map value hs
+
+fourOfAKind :: Hand -> Bool
+fourOfAKind h =
+    length (maximumBy (compare `on` length) (groupBy ((==) `on` value) (sort h))) == 4
+
+fullHouse :: Hand -> Bool
+fullHouse h =
+    let hs = sort h
+    in length (minimumBy (compare `on` length) (groupBy ((==) `on` value) hs)) == 2 &&
+       length (maximumBy (compare `on` length) (groupBy ((==) `on` value) hs)) == 3
+
+flush :: Hand -> Bool
+flush h =
+    length (groupBy ((==) `on` suit) h) == 1
+
+straight :: Hand -> Bool
+straight h =
+     let hs@(x:_) = sort h
+         start = value x
+     in take 5 [start..] == map value hs
+
+three :: Hand -> Bool
+three h =
+    length (maximumBy (compare `on` length) (groupBy ((==) `on` value) (sort h))) == 3
+
+twoPairs :: Hand -> Bool
+twoPairs h =
+    let hs = sort h
+        g_hs = sortBy (flip compare `on` length) (groupBy ((==) `on` value) hs)
+    in length (head g_hs) == 2 && length (head (tail g_hs)) == 2
+
+pair :: Hand -> Bool
+pair h =
+    length (maximumBy (compare `on` length) (groupBy ((==) `on` value) (sort h))) == 2
+
+findPairVal :: Hand -> Card
+findPairVal h =
+    head $ concat $ sortBy (flip compare `on` length) (groupBy ((==) `on` value) (sort h))
+
+playGame :: PokerGame -> Int
+playGame g
+    | royalFlush $ player1 g = 1
+    | royalFlush $ player2 g = -1
+    | straightFlush (player1 g) && not (straightFlush (player2 g)) = 1
+    | straightFlush (player2 g) && not (straightFlush (player1 g)) = -1
+    | straightFlush (player1 g) && straightFlush (player2 g) =
+        if minimum (player1 g) > minimum (player2 g) then 1 else -1
+    | fourOfAKind (player1 g) && not (fourOfAKind (player2 g)) = 1
+    | fourOfAKind (player2 g) && not (fourOfAKind (player1 g)) = -1
+    | fourOfAKind (player1 g) && fourOfAKind (player2 g) =
+        let (_:x:_) = sort $ player1 g
+            (_:y:_) = sort $ player2 g
+        in if value x > value y then 1 else -1
+    | fullHouse (player1 g) && not (fullHouse (player2 g)) = 1
+    | fullHouse (player2 g) && not (fullHouse (player1 g)) = -1
+    | fullHouse (player1 g) && fullHouse (player2 g) =
+        let (_:_:x:_) = sort $ player1 g
+            (_:_:y:_) = sort $ player2 g
+        in if value x > value y then 1 else -1
+    | flush (player1 g) && not (flush (player2 g)) = 1
+    | flush (player2 g) && not (flush (player1 g)) = -1
+    | flush (player1 g) && flush (player2 g) =
+        if maximum (player1 g) > maximum (player2 g) then 1 else -1
+    | straight (player1 g) && not (straight (player2 g)) = 1
+    | straight (player2 g) && not (straight (player1 g)) = -1
+    | straight (player1 g) && straight (player2 g) = 
+        if minimum (player1 g) > minimum (player2 g) then 1 else -1
+    | three (player1 g) && not (three (player2 g)) = 1
+    | three (player2 g) && not (three (player1 g)) = -1
+    | three (player1 g) && three (player2 g) = 
+        let (_:_:x:_) = sort $ player1 g
+            (_:_:y:_) = sort $ player2 g
+        in if value x > value y then 1 else -1
+    | twoPairs (player1 g) && not (twoPairs (player2 g)) = 1
+    | twoPairs (player2 g) && not (twoPairs (player1 g)) = -1
+    | twoPairs (player1 g) && twoPairs (player2 g) =
+        let (v:w:x:y:z:_) = sort $ player1 g
+            (a:b:c:d:e:_) = sort $ player2 g
+        in if value y > value d then 1
+           else if value y < value d then -1
+           else if value w > value b then 1
+           else if value w < value b then -1
+           else if value z > value e then 1
+           else if value z < value e then -1
+           else if value x > value c then 1
+           else if value x < value c then -1
+           else if value v > value a then 1
+           else -1
+    | pair (player1 g) && not (pair (player2 g)) = 1
+    | pair (player2 g) && not (pair (player1 g)) = -1
+    | pair (player1 g) && pair (player2 g) = 
+        let p1 = findPairVal (player1 g)
+            p2 = findPairVal (player2 g)
+            xs = reverse . sort $ player1 g
+            ys = reverse . sort $ player2 g
+        in if p1 > p2 then 1
+           else if p2 > p1 then -1
+           else if xs > ys then 1
+           else -1
+    | otherwise =
+        let xs = reverse . sort $ player1 g
+            ys = reverse . sort $ player2 g
+        in if xs > ys then 1 else -1
+
+main = do
+    withFile "p054_poker.txt" ReadMode (\handle -> do
+        contents <- hGetContents handle
+        let games = map readGame (lines contents)
+            result = sum $ filter (==1) $ map playGame games
+        putStrLn $ "Project Euler, Problem 54\n"
+            ++ "Answer: " ++ show result)