Posted at

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

More than 5 years have passed since last update.

くねくね増加列の問題を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)