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

くねくね増加列の問題をHaskellで解きました。

単純に深さ優先探索で解いています。非効率な実装ですが、問題サイズが小さいのでよしとします、

import qualified Data.Map as Map
import Data.Char

type Position = Int
type Value = Int
type Board = Map.Map Position Value

makeMap :: String -> Board
makeMap = foldl insert Map.empty
	where
		insert :: Board -> Char -> Board
		insert m c | c == '/' = m
		           | otherwise = Map.insert (Map.size m) (digitToInt c) m


nextPosition :: Board -> Position -> [Position]
nextPosition b p = [p' | p' <- around p, b Map.! p' > b Map.! p]
	where
		around :: Position -> [Position]
		around p | p `mod` 5 == 0 = [p' | p' <- [p - 5, p + 1, p + 5], p' >= 0, p' <= 24]
		around p | p `mod` 5 == 4 = [p' | p' <- [p - 5, p + 5, p - 1], p' >= 0, p' <= 24]
		around p | otherwise = [p' | p' <- [p - 5, p + 1, p + 5, p - 1], p' >= 0, p' <= 24]


search :: Board -> Int
search b = maximum $ map (search' b) [0..24]
	where 
		search' :: Board -> Position -> Int
		search' b p | nextPosition b p == [] = 1
		            | otherwise = 1 + (maximum $ map (search' b) (nextPosition b p))

main = do
	input <- getContents
	mapM test (lines input)
	where
		test :: String -> IO ()
		test s = do
			--putStr s
			let (x:y:[]) = words s
			putStr $ x ++ " "
			let out = (search . makeMap) x
			putStr $ show out ++ " "
			putStr $ y ++ " "
			putStrLn $ show (out == read y)