5_cards_puzzle.hs

import Data.List (sort, permutations, elemIndex)

data Card = Card Suit Int
  deriving (Show, Eq, Ord)

data Suit = Spades | Clubs | Hearts | Diamonds
  deriving (Show, Eq, Ord)

suits = [Spades, Clubs, Hearts, Diamonds]

deck = [Card suit number | suit <- suits, number <- [1..13]]

--------------
-- Encoding --
--------------

encodeChoice :: [Card] -> [Card]
encodeChoice cards =
  let (c1, c2, rest) = splitCards cards
      (keep, num) = pickCardToKeep c1 c2
      ordered = encodeNum num rest
  in keep : ordered

-- pull out two of the five cards that have the same suit
splitCards :: [Card] -> (Card, Card, [Card])
splitCards (c:cs) =
  case findSameSuit c cs of
    Just (matching, rest) -> (c, matching, rest)
    Nothing               ->
      let (c1, c2, rest) = splitCards cs
      in (c1, c2, c : rest)
splitCards _      = error "couldn't find a duplicate?"

-- Find a card in the second list that has the same suit as the given card
findSameSuit :: Card -> [Card] -> Maybe (Card, [Card])
findSameSuit _              [] = Nothing
findSameSuit card@(Card suit _) (c@(Card s2 _):cs)
  | suit == s2 = return (c, cs)
  | otherwise  = do
      (matching, rest) <- findSameSuit card cs
      return (matching, c : rest)

-- Keeps the card C such that (C + N) % 13 = C2 and N is <= 6
pickCardToKeep :: Card -> Card -> (Card, Int)
pickCardToKeep c1@(Card _ n1) c2@(Card _ n2) =
  let diff = modDiff n1 n2
  in if diff <= 6 then
       (c2, diff)
     else (c1, 13 - diff)

modDiff :: Int -> Int -> Int
modDiff n1 n2 = (13 + n1 - n2) `mod` 13

encodeNum num cards = nthPermutation num (sort cards)

-- TODO: this is inefficient
nthPermutation num cards = (permutations cards) !! (num - 1)

--------------
-- Decoding --
--------------

decodeChoice :: [Card] -> [Card]
decodeChoice cards@(Card suit n:rest) =
  let diff = decodeNum rest
      n' = ((n + diff) `mod` 13) + 1
  in Card suit n' : cards 

-- TODO: this is inefficient
decodeNum :: [Card] -> Int
decodeNum cards =
  let (Just idx) = elemIndex cards (permutations $ sort cards)
  in idx

-------------
-- Testing --
-------------

testAll =
  putStrLn $ show $ findFailures

findFailures = take 1 $ filter (not . testOne) allChoices

allChoices = choices 5 deck

choices num cards = choices' num cards [] []

choices' 0 _      rest results = rest : results
choices' _ []     _    results = results
choices' n (c:cs) rest results =
  let results' = choices' n cs rest results
  in choices' (n - 1) cs (c : rest) results'

testOne :: [Card] -> Bool
testOne cards =
  let result = decodeChoice $ encodeChoice cards
  in sort result == sort cards