「HaskellでProject Euler(Problem 52～54)」ブログ用

euler52-1.hs

import Data.List (find, sort)

main = let Just result = permuted [2..6] in print result

permuted :: (Enum a, Num a, Show a) => [a] -> Maybe a
permuted ns = find (\n -> all (sameSign n) $ map (* n) ns) [1..]

sameSign :: (Show a, Show b) => a -> b -> Bool
sameSign x y = sort (show x) == sort (show y)

euler52-2.hs

import Data.List (find, sort)

main = let Just result = permuted [2..6] in print result

permuted :: (Enum a, Num a, Show a) => [a] -> Maybe a
permuted ns = find (\n -> all (sameSign n . (* n)) ns) [1..]

sameSign :: (Show a, Show b) => a -> b -> Bool
sameSign x y = sort (show x) == sort (show y)

euler53-1.hs

threshold = 1000000

main = print $ sum $ map (\n -> length $ filter (\r -> combi n r > threshold) [1..n]) [23..100]

combi :: Integral a => a -> a -> a
combi n r = (fact n) `div` ((fact r) * (fact $ n - r))

fact :: (Num a, Enum a) => a -> a
fact n = foldl (*) 1 [1..n]

euler53-2.hs

threshold = 1000000

main = print $ sum $ map (\n -> length $ filter (\r -> combi n r > threshold) [1..n]) [23..100]

combi :: Integral a => a -> a -> a
combi n r = product [n-r+1..n] `div` product [1..r]

euler54-1.hs

import Data.Char (digitToInt)
import Data.List (findIndex, group, sort, unfoldr)

newtype Rank = Rank Int deriving (Eq, Show)

instance Ord Rank where
  compare (Rank 1) (Rank 1) = EQ
  compare (Rank 1) _        = GT
  compare _ (Rank 1)        = LT
  compare (Rank x) (Rank y) = x `compare` y

data Suit = Diamond | Heart | Club | Spade deriving (Eq, Show)

type Highest = Rank

data PokerHand = HighCard [Rank] |
                 OnePair Highest [Rank] |
                 TwoPairs Highest [Rank] |
                 ThreeOfAKind Highest [Rank] |
                 Straight [Rank] |
                 Flush [Rank] |
                 FullHouse Highest [Rank] |
                 FourOfAKind Highest [Rank] |
                 StraightFlush [Rank] |
                 RoyalFlush deriving (Eq, Ord, Show)

main = do names <- readFile "poker.txt"
          print $ length $ filter (win . splitAt 5 . splitOn ' ') $ lines names

splitOn :: Eq a => a -> [a] -> [[a]]
splitOn d xs = unfoldr splitOn' xs
  where
    splitOn' []                                    = Nothing
    splitOn' xs | Just index <- findIndex (==d) xs = let (x, rest) = splitAt index xs in
                                                     Just (x, tail rest)
                | otherwise                        = Just (xs, [])

-- cards1 が勝利する場合のみTrue
win :: ([String], [String]) -> Bool
win (cards1, cards2) = (hands cards1) > (hands cards2)
  where
    hands = makeHands . map toCard

makeHands :: [(Rank, Suit)] -> PokerHand
makeHands cards
  | sameSuit                                     = makeSameSuitHands sortedRanks
  | Just n <- sameRank 4                         = FourOfAKind n sortedRanks
  | (Just n, Just m) <- (sameRank 3, sameRank 2) = FullHouse (max n m) sortedRanks
  | isConsecutive                                = Straight sortedRanks
  | Just n <- sameRank 3                         = ThreeOfAKind n sortedRanks
  | Just n <- sameRanks 2 2                      = TwoPairs n sortedRanks
  | Just n <- sameRank 2                         = OnePair n sortedRanks
  | otherwise                                    = HighCard sortedRanks
  where
    sameSuit = let (s:ss) = map snd cards in all (==s) $ ss
    makeSameSuitHands [Rank 1, Rank 13, Rank 12, Rank 11, Rank 10] = RoyalFlush
    makeSameSuitHands ranks | isConsecutive                        = StraightFlush ranks
                            | otherwise                            = Flush ranks
    isConsecutive = all isConsecutive' $ zip sortedRanks $ tail sortedRanks
      where isConsecutive' (Rank 1, Rank 13) = True
            isConsecutive' (_, Rank 1)       = False
            isConsecutive' (Rank x, Rank y)  = x == succ y
    sameRank n = sameRanks n 1
    sameRanks n count | length ranks == count = Just $ maximum ranks
                      | otherwise             = Nothing
      where ranks = (map head . filter (\g -> length g == n) . group) sortedRanks
    sortedRanks = (reverse . sort . map fst) cards

toCard :: String -> (Rank, Suit)
toCard [r, s] = (toRank r, toSuit s)
  where
    toRank 'A' = Rank 1
    toRank 'T' = Rank 10
    toRank 'J' = Rank 11
    toRank 'Q' = Rank 12
    toRank 'K' = Rank 13
    toRank n   = Rank $ digitToInt n
    toSuit 'D' = Diamond
    toSuit 'H' = Heart
    toSuit 'C' = Club
    toSuit 'S' = Spade

euler54-2.hs

import Data.Char (digitToInt)
import Data.List (group, sort, sortBy)
import Data.Ord (comparing)

newtype Rank = Rank Int deriving (Eq, Show)

instance Ord Rank where
  compare = comparing fromEnum

instance Enum Rank where
  toEnum n | n == fromEnum (Rank 1) = Rank 1
           | otherwise              = Rank n
  fromEnum (Rank 1) = fromEnum (Rank 13) + 1
  fromEnum (Rank n) = n

data Suit = Diamond | Heart | Club | Spade deriving (Eq, Show)

type Highest = Rank

data PokerHand = HighCard [Rank] |
                 OnePair Highest [Rank] |
                 TwoPairs Highest [Rank] |
                 ThreeOfAKind Highest [Rank] |
                 Straight [Rank] |
                 Flush [Rank] |
                 FullHouse Highest [Rank] |
                 FourOfAKind Highest [Rank] |
                 StraightFlush [Rank] |
                 RoyalFlush deriving (Eq, Ord, Show)

main = do names <- readFile "poker.txt"
          print $ length $ filter (win . splitAt 5 . words) $ lines names

-- cards1 が勝利する場合のみTrue
win :: ([String], [String]) -> Bool
win (cards1, cards2) = (hands cards1) > (hands cards2)
  where
    hands = makeHands . map toCard

makeHands :: Eq a => [(Rank, a)] -> PokerHand
makeHands cards = makeHands' groupedCards
  where
    makeHands' [[Rank 1], [_], [_], [_], [Rank 10]]
      | sameSuit                                 = RoyalFlush
    makeHands' ns | isConsecutive ns && sameSuit = StraightFlush sortedRanks
    makeHands' [[n, _, _, _], [_]]               = FourOfAKind n sortedRanks
    makeHands' [[n, _, _], [m, _]]               = FullHouse (max n m) sortedRanks
    makeHands' _ | sameSuit                      = Flush sortedRanks
    makeHands' ns | isConsecutive ns             = Straight sortedRanks
    makeHands' [[n, _, _], [_], [_]]             = ThreeOfAKind n sortedRanks
    makeHands' [[n, _], [_, _], [_]]             = TwoPairs n sortedRanks
    makeHands' [[n, _], [_], [_], [_]]           = OnePair n sortedRanks
    makeHands' _                                 = HighCard sortedRanks
    sameSuit = let (s:ss) = map snd cards in all (==s) $ ss
    isConsecutive [[n], [_], [_], [_], [m]] | fromEnum n == fromEnum m + 4 = True
    isConsecutive _                                                        = False
    groupedCards = sortBy (flip $ comparing length) $ group $ sortedRanks
    sortedRanks = (reverse . sort . map fst) cards

toCard :: String -> (Rank, Suit)
toCard [r, s] = (toRank r, toSuit s)
  where
    toRank 'A' = Rank 1
    toRank 'T' = Rank 10
    toRank 'J' = Rank 11
    toRank 'Q' = Rank 12
    toRank 'K' = Rank 13
    toRank n   = Rank $ digitToInt n
    toSuit 'D' = Diamond
    toSuit 'H' = Heart
    toSuit 'C' = Club
    toSuit 'S' = Spade