第14回オフラインリアルタイムどう書くの参考問題をHaskellで解く

第14回 オフラインリアルタイムどう書くの参考問題「眠れるモンスターを狩る」を、Haskellで解きました。Stateモナドを使ってみたけど苦労のわりには…。

monster.hs

-- http://nabetani.sakura.ne.jp/hena/ord14linedung/
import Control.Monad
import Control.Monad.State

data Monster = B|D|F|H|J|L deriving (Eq, Show)
data Arm = A|C|E|G|I|K deriving (Eq, Show)

removeOne e xs
    | after == [] = before
    | otherwise = before ++ tail(after)
    where
      before = takeWhile (\t-> t /= e) xs
      after = dropWhile (\t-> t /= e) xs

step (ms, as, n)
    | A `elem` as && B `elem` ms = (True, (removeOne B ms, C:as, n+1))
    | C `elem` as && D `elem` ms = (True, (removeOne D ms, E:as, n+1))
    | E `elem` as && F `elem` ms = (True, (removeOne F ms, G:as, n+1))
    | G `elem` as && H `elem` ms = (True, (removeOne H ms, I:as, n+1))
    | I `elem` as && J `elem` ms = (True, (removeOne J ms, K:as, n+1))
    | K `elem` as && L `elem` ms = (True, (removeOne L ms, A:as, n+1))
    | otherwise = (False, (ms, as, n))

next :: State ([Monster],[Arm],Int) Bool
next = state $ \(ms, as, n) -> step (ms, as, n)

toMonster :: [Monster] -> Char -> [Monster]
toMonster xs ch = case ch of
                    'B' -> B:xs
                    'D' -> D:xs
                    'F' -> F:xs
                    'H' -> H:xs
                    'J' -> J:xs
                    'L' -> L:xs
                    _ -> xs

toArm :: [Arm] -> Char -> [Arm]
toArm xs ch = case ch of
                'a' -> A:xs
                'c' -> C:xs
                'e' -> E:xs
                'g' -> G:xs
                'i' -> I:xs
                'k' -> K:xs
                _ -> xs

toState :: [Char] -> ([Monster], [Arm], Int)
toState str = (foldl (toMonster) [] str, foldl (toArm) [] str, 0)

solve :: State ([Monster], [Arm], Int) ()
solve = do
  result <- next
  if (result == False) then return () else solve

solve' :: [Char] -> ([Monster], [Arm], Int)
solve' str = do
  execState solve (toState str)

test :: [Char] -> String -> Bool
test str expected = do
  let (_, _, n) = solve' str
  n == read expected

main :: IO ()
main = do
  print $ test "gLDLBgBgHDaD" "6" {-0-}
  print $ test "DBcDLaLgDBH" "6" {-1-}
  print $ test "JJca" "0" {-2-}
  print $ test "FJDLBH" "0" {-3-}
  print $ test "HJBLFDg" "6" {-4-}
  print $ test "HBaDLFJ" "6" {-5-}
  print $ test "DJaHLB" "2" {-6-}
  print $ test "gDLHJF" "3" {-7-}
  print $ test "cJFgLHD" "5" {-8-}
  print $ test "FFBJaJJ" "1" {-9-}
  print $ test "FJeJFBJ" "2" {-10-}
  print $ test "iJFFJJB" "3" {-11-}
  print $ test "JBJiLFJF" "5" {-12-}
  print $ test "JDiFLFBJJ" "8" {-13-}
  print $ test "BDFDFFDFFLLFFJFDBFDFFFFDDFaDBFFB" "28" {-14-}
  print $ test "DDFBFcBDFFFFFFLBFDFFBFLFDFDJDFDF" "24" {-15-}
  print $ test "FDLBFDDBFFFeFFFFFDFBLDDFDDFBFFJF" "16" {-16-}
  print $ test "FDBFFLFDFFDBBDFFBJDLFgDFFFDFFDFF" "0" {-17-}
  print $ test "FDiFLDFFFFBDDJDDBFBFDFFFBFFDFLFF" "31" {-18-}
  print $ test "FDFDJBLBLBFFDDFFFDFFFFFDDFBkFDFF" "30" {-19-}
  print $ test "HBkFFFFHBLH" "3" {-20-}
  print $ test "FBHHFFFHLaB" "2" {-21-}
  print $ test "LFHFBBcHFHF" "0" {-22-}
  print $ test "LFBHFFeFHBH" "7" {-23-}
  print $ test "LgFHHHBFBFF" "3" {-24-}
  print $ test "FFiFHBHLBFH" "0" {-25-}
  print $ test "BFHHFFHBeFLk" "10" {-26-}
  print $ test "FHFaBBHFHLFg" "5" {-27-}
  print $ test "FFgacaFg" "0" {-28-}
  print $ test "JHDaDcBJiiHccBHDBDH" "9" {-29-}
  print $ test "FHJJLckFckFJHDFF" "12" {-30-}
  print $ test "DeDHJHDFHJBLHDLLDHJLBDD" "22" {-31-}
  print $ test "gJLLLJgJgJLJL" "0" {-32-}
  print $ test "DaaaDDD" "0" {-33-}
  print $ test "HFeJFHiBiiBJeJBBFFB" "9" {-34-}
  print $ test "FJFFJDBHBHaLJBHJHDLHkLLLFFFgJgHJLHkJkB" "32" {-35-}
  print $ test "giFLBiBJLLJgHBFJigJJJBLHFLDLL" "23" {-36-}
  print $ test "cgkLJcLJJJJgJc" "2" {-37-}
  print $ test "LDFHJHcFBDBLJBLFLcFJcDFBL" "22" {-38-}
  print $ test "JJHHHkHJkHLJk" "1" {-39-}
  print $ test "kHHBBaBgHagHgaHBBB" "11" {-40-}
  print $ test "HDBFFDHHHDFLDcHHLFDcJD" "20" {-41-}
  print $ test "HFFFHeFFee" "7" {-42-}
  print $ test "gLLDHgDLgFL" "1" {-43-}
  print $ test "JJJBBaBBHBBHaLBHJ" "7" {-44-}
  print $ test "FBFBgJBDBDgF" "0" {-45-}
  print $ test "LLLLakakLakLL" "7" {-46-}
  print $ test "HeJHeJe" "0" {-47-}
  print $ test "LDFLBLLeBLDBBFFBLFBB" "4" {-48-}