Project Euler Problem 54 in Haskell

Question

I wrote an implementation in Haskell for Project Euler Problem 54:

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?

import Data.Monoid(mappend)
import Data.List(sortBy, sort, group, nub, elemIndex)
import Control.Arrow((&&&), (***))
import Data.Maybe(fromJust)
import Control.Monad(join)

type Hand = String
type Values = [Int]
data Ranking = HighCard | Pair | TwoPair | ThreeOfAKind | Straight | Flush | FullHouse | FourOfAKind  | StraightFlush deriving (Eq, Ord)
data HandValue = HandValue Ranking Values
instance Eq HandValue where
  HandValue r1 v1 == HandValue r2 v2 = r1 == r2 && v1 == v2
instance Ord HandValue where
  HandValue r1 v1 `compare` HandValue r2 v2 = (r1 `compare` r2) `mappend` (v1 `compare` v2)
    
rateHand :: Hand -> HandValue
rateHand hand
   | straight && flush = HandValue StraightFlush ranks
   | flush = HandValue Flush ranks
   | straight = HandValue Straight ranks
   | otherwise = case map fst groups of
                         [4, 1] -> HandValue FourOfAKind values
                         [3, 2] -> HandValue FullHouse values
                         [3, 1, 1] -> HandValue ThreeOfAKind values
                         [2, 2, 1] -> HandValue TwoPair values
                         [2, 1, 1, 1] -> HandValue Pair values
                         otherwise -> HandValue HighCard values
                      where
       sf = (`elem` "SCDH")
       ranks = sortBy (flip compare) $ map (fromJust . (`elemIndex` "23456789TJQKA")) $ filter (not . sf) hand
       suits = filter sf hand
       flush = length (nub suits) == 1
       straight = ranks == reverse [last ranks..head ranks] || ranks == [12,3,2,1,0]
       groups = sortBy descSort . map (length &&& id) $ group ranks
       values = concatMap snd groups
       descSort (l1,v1) (l2,v2) = (l2 `compare` l1) `mappend` (v2 `compare` v1)

parseLine :: String -> Bool
parseLine line = uncurry (>) $ join (***) rateHand $ splitAt 10 $ filter (/= ' ') line

main :: IO ()
main = do
  pots <- lines <$> readFile "p054_poker.txt"
  print $ length $ filter parseLine pots

I defined a data type for the ranking, which is something like high card or flush. A HandValue is the combination of the ranking and the values of the cards related to the ranking + the kickers from high to low. For instance: HandValue TwoPair [10, 10, 3, 3, 12]. Note that even though I have an ace, the values that are relevant (i.e. the two pairs) come first. This allows to compare two HandValues with the same ranking (i.e. HandValue TwoPair [10, 10, 3, 3, 12] < HandValue TwoPair [11, 11, 9, 9, 2]). The Ord instance for HandValue looks at the ranking first, and looks only at the values if the rankings are the same.

To actually rate a hand, the suits and the ranks are separated, then:

• flush: all the same suits -> removing all the duplicates gives a list of one element
• straight: the ranks are equal to an enumeration from the head to the last item. Extra check for the ace used as a low value.

These two checks give us the option to filter out StraightFlush, Flush and Straight. If it's neither a straight nor a flush, we need to look at grouping the ranks. Then we match the length of the list of similar ranks to find everything from FourOfAKind to HighCard. The values are in this case the concatenation of the list of similar cards (e.g. [[10, 10], [9,9], [12]] -> [10, 10, 9, 9, 12] rather than the ranks from high to low (e.g. [12, 10, 10, 9, 9]), to make sure the relevant values for the ranking (e.g. TwoPair) are compared first.

A line is parsed by removing the spaces, then splitting (resulting in a tuple (hand player 1, hand player 2), which then mapped over by join (***) rateHand, and then the first value is compared to the second value, resulting in a boolean that is True if player 1 wins the hand. This is then used as a filter to count the length of the list of hands in which player 1 wins.

My implementation works perfectly and is very fast (100,000 lines in 10 sec in ghci, actual problem is instant), so I'm not necessarily looking for performance improvements; any kind of feedback is more than welcome.

Answer 1

Not bad. Here are some suggestions for improvement:

import Data.Monoid(mappend)

Use a single space before the parentheses.

data HandValue = HandValue Ranking Values
instance Eq HandValue where
  HandValue r1 v1 == HandValue r2 v2 = r1 == r2 && v1 == v2
instance Ord HandValue where

Eq and Ord instances can be derived automagically:

data HandValue = HandValue Ranking Values deriving (Eq, Ord)

ranks = sortBy (flip compare) $ map (fromJust . (`elemIndex` "23456789TJQKA")) $ filter (not . sf) hand

Rename to sortedRanks.

groups = sortBy descSort . map (length &&& id) $ group ranks

I think it'll be a bit easier to read without function composition. Change the . to $.

descSort (l1,v1) (l2,v2) = (l2 `compare` l1) `mappend` (v2 `compare` v1)

You can simply write descSort = flip compare. And since you use sortBy descSort twice, I suggest extracting it to a new function sortDecreasing :: Ord a => [a] -> [a].

parseLine :: String -> Bool

• parseLine actually both parses and checks if the first player wins. Split to parseLine :: String -> (Hand, Hand) and playerOneWins :: (Hand, Hand) -> Bool.
• Some of the parsing happens in rateHand: sf, suits, and most of sf are all parsing the hand string. Move all parsing to parseHand and change the Hand type to [(Int, Char)] instead of String.
• Use partition instead of two filters.
• join (***) is confusing. I would write a mapOverPair :: (a -> b) -> (a, a) -> (b, b) function, which can implemented in a straightforward way.
• Rename sf to isSuit. I still can't figure out what sf stands for. (Also, what does pots mean?)

The code after applying these suggestions:

import Data.Monoid (mappend)
import Data.List (sortBy, sort, group, nub, elemIndex, partition)
import Control.Arrow ((&&&), (***))
import Data.Maybe (fromJust)
import Control.Monad (join)

type Hand = [(Int, Char)]
type Values = [Int]
data Ranking = HighCard | Pair | TwoPair | ThreeOfAKind | Straight | Flush | FullHouse | FourOfAKind  | StraightFlush deriving (Eq, Ord)
data HandValue = HandValue Ranking Values deriving (Eq, Ord)

sortDecreasing :: Ord a => [a] -> [a]
sortDecreasing = sortBy (flip compare)

rateHand :: Hand -> HandValue
rateHand hand
   | straight && flush = HandValue StraightFlush sortedRanks
   | flush = HandValue Flush sortedRanks
   | straight = HandValue Straight sortedRanks
   | otherwise = case map fst groups of
                         [4, 1] -> HandValue FourOfAKind values
                         [3, 2] -> HandValue FullHouse values
                         [3, 1, 1] -> HandValue ThreeOfAKind values
                         [2, 2, 1] -> HandValue TwoPair values
                         [2, 1, 1, 1] -> HandValue Pair values
                         otherwise -> HandValue HighCard values
                      where
       sortedRanks = sortDecreasing $ map fst hand
       suits = map snd hand
       flush = length (nub suits) == 1
       straight = sortedRanks == reverse [last sortedRanks..head sortedRanks] || sortedRanks == [12,3,2,1,0]
       groups = sortDecreasing $ map (length &&& id) $ group sortedRanks
       values = concatMap snd groups

mapOverPair :: (a -> b) -> (a, a) -> (b, b)
mapOverPair f (x, y) = (f x, f y)

parseHand :: String -> Hand
parseHand str = zip ranks suits
  where (suits, ranksChars) = partition isSuit str
        isSuit = (`elem` "SCDH")
        ranks = map (fromJust . (`elemIndex` "23456789TJQKA")) ranksChars

parseLine :: String -> (Hand, Hand)
parseLine = mapOverPair parseHand . splitAt 10 . filter (/= ' ')

playerOneWins :: (Hand, Hand) -> Bool
playerOneWins (h1, h2) = rateHand h1 > rateHand h2

main :: IO ()
main = do
  hands <- (map parseLine . lines) <$> readFile "p054_poker.txt"
  print $ length $ filter playerOneWins hands