1日1個 @nabetani さんの作った問題を解く、どう書くAdventCalendarの1日目です。

今日の問題は http://nabetani.sakura.ne.jp/hena/ord7selectchair/ にあります。

module Doukaku.Nonbiri (solve) where
import Data.Char (toUpper)

solve :: String -> String
solve input = foldl next (take n . repeat $ '-') ope
  where
    ope :: String
    (n', ':':ope) = break (== ':') input
    n = read n' :: Int

next :: String -> Char -> String
next current c
  | 'a' <= c && c <= 'z' = let c' = toUpper c
                           in map (\x -> if x == c' then '-' else x) current
  | otherwise = sitDown c current

sideMembers :: String -> [Int]
sideMembers xs = sideMembers' ('-':xs)
  where
    sideMembers' (x:'-':[])   = [count x]
    sideMembers' (_:_:[]) = [-1]
    sideMembers' (x:'-':z:zs)   = let members = sum . map count $ [x, z]
                                  in members : sideMembers' ('-':z:zs)
    sideMembers' (_:y:z:zs) = -1 : sideMembers' (y:z:zs)
    count '-' = 0
    count  _  = 1

sitDown :: Char -> String -> String
sitDown new current = either id undefined $ do
  toEither (sitDown' 0 current sides)
  toEither (sitDown' 1 current sides)
  toEither (sitDown' 2 current sides)
  return ()
  where
    sides = sideMembers current
    sitDown' :: Int -> String -> [Int] -> Maybe String
    sitDown' _ [] [] = Nothing
    sitDown' n (c:cs) (m:ms)
      | n == m = Just $ new:cs
      | otherwise = (c :) `fmap` (sitDown' n cs ms)

toEither :: Maybe a -> Either a ()
toEither = maybe (Right ()) Left

各席の隣の人数を求めてから、それを元に座る位置を決めるという戦術をとりました。sideMembers'では左端の要素の場合分けをしたくなくて番兵を使っていますが、右端はパターンマッチで分けてます。sideMembers関数の戻り値は席が空いてない時は-1を返しましたが、ここはちょっと頂けないところ。

後、Eitherモナドを通常とは逆に使って大域脱出させてます。答えが出た場合はLeftで、答えがない場合はRight ()です。

http://qiita.com/Nabetani/items/4364285801d1c9f370a1 に他の方の回答もありますので、見ると参考になるでしょう。