第７回オフラインリアルタイムどう書くの回答です。

chairs.hs

module Main where

import Control.Arrow (first)
import Data.Char (isUpper, isLower, toUpper)
import Data.List (tails, maximumBy, findIndex)
import Data.Ord (comparing)
import Data.Maybe (fromMaybe)
import Test.HUnit (Test(..), runTestTT, (~=?))

type Chair = Maybe Char
type Input = String

solve :: String -> String
solve = writeAnswer . process . readProblem

readProblem :: String -> ([Chair], Input)
readProblem s = (cs, ps)
  where
    (cs, (_:ps)) = first (flip replicate Nothing . read) $ break (== ':') s

process :: ([Chair], Input) -> [Chair]
process (cs, is) = foldl move cs is

move :: [Chair] -> Char -> [Chair]
move cs i
  | isUpper i = set cs (Just i) $ findSeat cs
  | isLower i = case findPerson cs (toUpper i) of
      Just i' -> set cs Nothing i'
      Nothing -> error $ "move: No such person " ++ [i]
  | otherwise = error $ "move: Invalid input " ++ [i]

findSeat :: [Chair] -> Int
findSeat cs = fst $ maximumBy (comparing snd) $ reverse $ zip [0..] $ map score $ subsequence
  where
    subsequence = take (length cs) $ map (take 3) $ tails (Nothing : cs ++ [Nothing])
    score [Nothing, Nothing, Nothing] = 3
    score [Nothing, Nothing, Just _ ] = 2
    score [Just _ , Nothing, Nothing] = 2
    score [Just _ , Nothing, Just _ ] = 1
    score _                           = 0

findPerson :: [Chair] -> Char -> Maybe Int
findPerson cs c = findIndex (== Just c) cs

set :: [Chair] -> Chair -> Int -> [Chair]
set cs c i = hd ++ c : tl
  where
    (hd, _:tl) = splitAt i cs

writeAnswer :: [Chair] -> String
writeAnswer = map toChar
  where
    toChar = fromMaybe '-'

main :: IO ()
main = print =<< runTestTT (TestList $ map toTest testdata)

toTest :: (String, String) -> Test
toTest (input, expected) = expected ~=? solve input

testdata :: [(String, String)]
testdata =
  [ ( "6:NABEbBZn", "-ZAB-E" )
  , ( "1:A", "A" )
  , ( "1:Aa", "-" )
  , ( "2:AB", "AB" )
  , ( "2:AaB", "B-" )
  , ( "2:AZa", "-Z" )
  , ( "2:AZz", "A-" )
  , ( "3:ABC", "ACB" )
  , ( "3:ABCa", "-CB" )
  , ( "4:ABCD", "ADBC" )
  , ( "4:ABCbBD", "ABDC" )
  , ( "4:ABCDabcA", "-D-A" )
  , ( "5:NEXUS", "NUESX" )
  , ( "5:ZYQMyqY", "ZM-Y-" )
  , ( "5:ABCDbdXYc", "AYX--" )
  , ( "6:FUTSAL", "FAULTS" )
  , ( "6:ABCDEbcBC", "AECB-D" )
  , ( "7:FMTOWNS", "FWMNTSO" )
  , ( "7:ABCDEFGabcdfXYZ", "YE-X-GZ" )
  , ( "10:ABCDEFGHIJ", "AGBHCIDJEF" )
  ]