第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-}