HaskellでAIZU ONLINE JUDGE Part2
引き続きHaskellに慣れるためにAIZU ONLINE JUDGEやってみます。「Introduction to Algorithms and Data Structures」を対象にします。詰まったところや知らなかった関数などをメモします。
ALDS1_4_C
DNAの塩基配列がぽいぽい渡されたりそれを探したり、という問題。
とりあえず動くものは実装できましたが、TLEで失敗。またメモリも使いすぎている。以下の2点を改善したいのですが、Haskellでのうまいやり方がわからないので一旦保留に。
insert,find関数の実装を二分探索木に。find関数の結果を随時出力し、メモリ上に保存しないように。
type Result = ([String], [Bool])
dictionary :: Result -> String -> Result
dictionary (items, found) input
| cmd == "insert" = (insert target items, found)
| cmd == "find" = (items, (find target items) : found)
where inputs = words input
cmd = inputs !! 0
target = inputs !! 1
insert :: String -> [String] -> [String]
insert x [] = [x]
insert x (y:ys)
| x `compare` y == GT = y : (insert x ys)
| otherwise = x:y:ys
find :: String -> [String] -> Bool
find x [] = False
find x (y:ys)
| x == y = True
| otherwise = find x ys
main = do
_ <- getLine
inputs <- fmap lines getContents
let result = foldl dictionary ([], []) inputs
mapM_ putStrLn (map yesno $ reverse $ snd result)
yesno :: Bool -> String
yesno True = "yes"
yesno False = "no"
ALDS2_4_B
binary searchしてくださいという問題。
はじめは何も考えずListを使い実装 -> TLEでした。なのでデータ構造として配列を使用するように変更して解決。Haskellでとりあえず配列を扱いたいという場合、Array or UArrayを使えば良さそうです (他にもIOArrayやら色々あるようですが、今回の用途にはUArrayで問題なし)。
import Data.Array.Unboxed
{-
Array
-> Imported from Data.Array
-> 参照の配列
-> 実際に添字を使ってアクセスされるまで値が評価されない
UArray
-> Imported from Data.Array.Unboxed
-> 値の配列
-> 正格評価
-}
binarySearch :: Int -> (Int, Int) -> UArray Int Int -> Bool
binarySearch target (start, end) arr
| start == end = target == arr!i
| target == arr!i = True
| target < arr!i = binarySearch target (start, i) arr
| otherwise = binarySearch target (i+1, end) arr
where i = floor $ (fromIntegral (end + start)) / 2
main = do
n <- fmap read getLine
seqNum <- fmap (map read . words) getLine
let arr = listArray (1, n) seqNum
_ <- getLine
targets <- fmap (map read . words) getLine
putStrLn $ show . length . filter (\x -> binarySearch x (1, n) arr) $ targets
ALDS1_7_C
Binary tree walkしましょう、各nodeの番号を指定されたorderで読み上げましょう、という問題。
Writerモナドの練習と便利さを感じるのにちょうど良い問題な気がします。preorder, inorder, postorderの挙動がコードにシンプルに現れているのではないでしょうか。
import Data.List
import Control.Monad.Writer
data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show)
-- ルートノードを見つける。
findRoot :: Int -> [(Int, (Int, Int))] -> Int
findRoot x xs = let
findLR (idx, (l, r)) = l == x || r == x
node = find findLR xs
in
case node of
Just (idx, _) -> findRoot idx xs
Nothing -> x
-- 二分木を構築する。
makeTree :: Int -> [(Int, (Int, Int))] -> Tree Int
makeTree x xs = let
node = lookup x xs
in
case node of
Just (l, r) -> Node x (makeTree l xs) (makeTree r xs)
Nothing -> EmptyTree
-- PreOrderでノード番号を取得する。
preorder :: Tree Int -> Writer [Int] (Tree Int)
preorder EmptyTree = return (EmptyTree)
preorder (Node idx l r) = do
tell [idx]
preorder l
preorder r
-- InOrderでノード番号を取得する。
inorder :: Tree Int -> Writer [Int] (Tree Int)
inorder EmptyTree = return (EmptyTree)
inorder (Node idx l r) = do
inorder l
tell [idx]
inorder r
-- PostOrderでノード番号を取得する。
postorder :: Tree Int -> Writer [Int] (Tree Int)
postorder EmptyTree = return (EmptyTree)
postorder (Node idx l r) = do
postorder l
postorder r
tell [idx]
return (EmptyTree)
-- 出力用文字列のフォーマット
format :: [Int] -> String
format xs = foldl (\acc x -> acc ++ " " ++ show x) "" xs
main = do
n <- fmap (read) getLine
lns <- sequence $ replicate n getLine
let nodes = map ((\[x,y,z] -> (x, (y,z))) . map read . words) lns
r = findRoot (fst (nodes !! 0)) nodes
tree = makeTree r nodes
putStrLn "Preorder"
putStrLn $ format . snd . runWriter $ preorder tree
putStrLn "Inorder"
putStrLn $ format . snd . runWriter $ inorder tree
putStrLn "Postorder"
putStrLn $ format . snd . runWriter $ postorder tree
ALDS1_10_C
いわゆる最長共通部分列(LCS)問題と呼ばれるものです。
よく動的計画法の例として用いられる問題です。Haskellさんで部分問題に分解するのはお手の物なのですが、どうメモ化部分を実装したらいいかがわからず、ひとまずその部分を無視して実装しました。
{- First trial -}
lcs :: (String,String) -> Int -> Int
lcs ([],_) n = n
lcs (_,[]) n = n
lcs (ax@(x:xs),ay@(y:ys)) n
| x == y = lcs (xs,ys) (n+1)
| otherwise = max (lcs (ax,ys) n) (lcs (xs,ay) n)
{- Parse input -}
main = do
getLine
inputs <- fmap lines getContents
let targets = zip (takeOnlyOdd inputs) (takeOnlyEven inputs)
mapM_ putStrLn $ map (\(x,y) -> show . length $ lcs' x y) targets
takeOnlyEven :: [a] -> [a]
takeOnlyEven xs = map snd . filter (\(i, n) -> i `mod` 2 == 0) $ zip [1..] xs
takeOnlyOdd :: [a] -> [a]
takeOnlyOdd xs = map snd . filter (\(i, n) -> i `mod` 2 == 1) $ zip [1..] xs
これで正解にはたどり着けますが、パフォーマンスは悪く、submitしても1問目から時間切れになります。
ということで実際のHaskellのLCS実装を調べたところ、Haskellのメモ化パッケージとしてdata-memocombinatorsというのがあるようです。
import qualified Data.MemoCombinators as M
-- M.integral :: Integral a => (a -> r) -> a -> r
-- Integralを受け取る1引数関数をメモ化された関数にする。
fib = M.integral fib'
where
fib' 0 = 0
fib' 1 = 1
fib' x = fib (x-1) + fib (x-2)
-- M.memo2 :: Memo a -> Memo b -> (a -> b -> r) -> a -> b -> r
-- 2引数関数をメモ化された関数にする。
memoPlus = M.memo2 mString mString (++)
-- Memo型のStringは直接は用意されていないのでCharのListとして表現する。
mString = M.list M.char
これを使用してLCSを解くと以下の通りです。
import qualified Data.MemoCombinators as M
{- Second trial -}
{- Most of codes come from RosettaCode... -}
lcs' = memoize lcsm
where
lcsm [] _ = []
lcsm _ [] = []
lcsm ax@(x:xs) ay@(y:ys)
| x == y = x:(lcs' xs ys)
| otherwise = maxl (lcs' ax ys) (lcs' xs ay)
maxl x y = if length x > length y then x else y
memoize = M.memo2 mString mString
mString = M.list M.char
{- Parse input -}
main = do
getLine
inputs <- fmap lines getContents
let targets = zip (takeOnlyOdd inputs) (takeOnlyEven inputs)
mapM_ putStrLn $ map (\(x,y) -> show . length $ lcs' x y) targets
takeOnlyEven :: [a] -> [a]
takeOnlyEven xs = map snd . filter (\(i, n) -> i `mod` 2 == 0) $ zip [1..] xs
takeOnlyOdd :: [a] -> [a]
takeOnlyOdd xs = map snd . filter (\(i, n) -> i `mod` 2 == 1) $ zip [1..] xs
ただ残念ながらAIZU ONLINEではパッケージが対応していない？ためruntime errorとなります。またコード自体も依然パフォーマンス不十分なようでローカルで実行したin4.txtでかなり時間がかかります。ListをArrayにする等できることはまだありますが、最初のものよりは改善されたということでとりあえずはよしとします。