Professor at MIT can read minds!

Assistant.hs

{-# LANGUAGE ViewPatterns #-}

import Data.Ord (Down (..))
import Data.List (sort, sortOn, elemIndex, groupBy)
import Data.Function (on)

-- == -- ==                       == -- == --
-- == -- ==   UTILITY FUNCTIONS   == -- == --
-- == -- ==                       == -- == --

composeN :: (a -> a) -> Int -> (a -> a)
composeN f 0 = id
composeN f n
    | even n    = g
    | otherwise = f . g
    where g = g' . g'
          g' = composeN f (n `div` 2)

shapeHash :: Ord a => [a] -> [Int]
shapeHash as = [i | s <- as, let Just i = elemIndex s sorted] where sorted = sort as

reshape :: [Int] -> [a] -> [a]
reshape is xs = map (xs !!) is

categorize :: (Eq c, Ord c) => (a -> c) -> [a] -> [[a]]
categorize f = groupBy ((==) `on` f) . sortOn f

perm3 :: Int -> [Int]
perm3 1 = [0, 1, 2]
perm3 2 = [0, 2, 1]
perm3 3 = [1, 0, 2]
perm3 4 = [1, 2, 0]
perm3 5 = [2, 0, 1]
perm3 6 = [2, 1, 0]

perm3' :: [Int] -> Int
perm3' [0, 1, 2] = 1
perm3' [0, 2, 1] = 2
perm3' [1, 0, 2] = 3
perm3' [1, 2, 0] = 4
perm3' [2, 0, 1] = 5
perm3' [2, 1, 0] = 6

-- == -- ==                  == -- == --
-- == -- ==   MAIN PROGRAM   == -- == --
-- == -- ==                  == -- == --

data Rank = RA | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | RJ | RQ | RK deriving (Show, Read, Eq, Enum, Ord)
data Suit = SC | SD | SH | SS deriving (Show, Read, Eq, Ord)
data Card = Card {
    rank :: Rank,
    suit :: Suit
  } deriving (Show, Eq, Ord)

inc :: Rank -> Rank
inc RK = RA
inc s  = succ s

add :: Int -> Rank -> Rank
add = composeN inc

addCard :: Int -> Card -> Card
addCard n (Card r s) = Card (add n r) s

showCard :: Card -> String
showCard (Card rank suit) = ts rank ++ ts suit where
    ts :: Show a => a -> String
    ts = tail.show

readCard :: String -> Card
readCard s = Card (read $ 'R' : init s) (read $ ['S', last s])

distance :: Rank -> Rank -> Int
distance stt end
    | stt == end = 0
    | otherwise  = 1 + distance (inc stt) end

selectCard :: [Card] -> (Card, Int, [Card])
selectCard cards
    | dist1 < dist2 = (a, dist1, rest)
    | otherwise     = (b, dist2, rest)
    where
      ((a:b:maxSuit) : nonMaxSuits) = sortOn (Down . length) $ categorize suit cards
      rest = sort . concat $ maxSuit : nonMaxSuits
      dist1 = distance (rank a) (rank b)
      dist2 = distance (rank b) (rank a)

encode :: [Card] -> [Card]
encode cards = signal : reshape (perm3 diff) rest where
    (signal, diff, rest) = selectCard cards

decode :: [Card] -> Card
decode (signal : shaped) = addCard (perm3' . shapeHash $ shaped) signal

printCards :: [Card] -> IO ()
printCards = mapM_ (putStrLn . showCard)

main = do
    printCards . pure . decode . map readCard . words =<< getLine

Magician.hs

{-# LANGUAGE ViewPatterns #-}

import Data.Ord (Down (..))
import Data.List (sort, sortOn, elemIndex, groupBy)
import Data.Function (on)

-- == -- ==                       == -- == --
-- == -- ==   UTILITY FUNCTIONS   == -- == --
-- == -- ==                       == -- == --

composeN :: (a -> a) -> Int -> (a -> a)
composeN f 0 = id
composeN f n
    | even n    = g
    | otherwise = f . g
    where g = g' . g'
          g' = composeN f (n `div` 2)

shapeHash :: Ord a => [a] -> [Int]
shapeHash as = [i | s <- as, let Just i = elemIndex s sorted] where sorted = sort as

reshape :: [Int] -> [a] -> [a]
reshape is xs = map (xs !!) is

categorize :: (Eq c, Ord c) => (a -> c) -> [a] -> [[a]]
categorize f = groupBy ((==) `on` f) . sortOn f

perm3 :: Int -> [Int]
perm3 1 = [0, 1, 2]
perm3 2 = [0, 2, 1]
perm3 3 = [1, 0, 2]
perm3 4 = [1, 2, 0]
perm3 5 = [2, 0, 1]
perm3 6 = [2, 1, 0]

perm3' :: [Int] -> Int
perm3' [0, 1, 2] = 1
perm3' [0, 2, 1] = 2
perm3' [1, 0, 2] = 3
perm3' [1, 2, 0] = 4
perm3' [2, 0, 1] = 5
perm3' [2, 1, 0] = 6

-- == -- ==                  == -- == --
-- == -- ==   MAIN PROGRAM   == -- == --
-- == -- ==                  == -- == --

data Rank = RA | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | RJ | RQ | RK deriving (Show, Read, Eq, Enum, Ord)
data Suit = SC | SD | SH | SS deriving (Show, Read, Eq, Ord)
data Card = Card {
    rank :: Rank,
    suit :: Suit
  } deriving (Show, Eq, Ord)

inc :: Rank -> Rank
inc RK = RA
inc s  = succ s

add :: Int -> Rank -> Rank
add = composeN inc

addCard :: Int -> Card -> Card
addCard n (Card r s) = Card (add n r) s

showCard :: Card -> String
showCard (Card rank suit) = ts rank ++ ts suit where
    ts :: Show a => a -> String
    ts = tail.show

readCard :: String -> Card
readCard s = Card (read $ 'R' : init s) (read $ ['S', last s])

distance :: Rank -> Rank -> Int
distance stt end
    | stt == end = 0
    | otherwise  = 1 + distance (inc stt) end

selectCard :: [Card] -> (Card, Int, [Card])
selectCard cards
    | dist1 < dist2 = (a, dist1, rest)
    | otherwise     = (b, dist2, rest)
    where
      ((a:b:maxSuit) : nonMaxSuits) = sortOn (Down . length) $ categorize suit cards
      rest = sort . concat $ maxSuit : nonMaxSuits
      dist1 = distance (rank a) (rank b)
      dist2 = distance (rank b) (rank a)

encode :: [Card] -> [Card]
encode cards = signal : reshape (perm3 diff) rest where
    (signal, diff, rest) = selectCard cards

decode :: [Card] -> Card
decode (signal : shaped) = addCard (perm3' . shapeHash $ shaped) signal

printCards :: [Card] -> IO ()
printCards = mapM_ (putStrLn . showCard)

main = do
    printCards . encode . map readCard . words =<< getLine