Haskell卒業!

■ [アルゴリズム]演習(時事問題5) 06:29

一応、"http://okajima.air-nifty.com/b/2010/01/post-abc6.html"の方もやってみた。

最短経路問題と言ったら、やっぱり、とりあえずダイクストラ。最短性の証明とかする必要ないし。

簡単な実装を選んだのに意外と手間だった。リストでやってる方もいるから参考にしよう...

でも、絶対このコード半分くらいに短くなる気がする...

{-# OPTIONS_GHC -cpp -XPatternGuards #-}

-- #define _DEBUG

import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Data.List (unfoldr, splitAt)
import Data.Array
import Data.Array.IO
import Text.Printf

(?)  b t f = if b then t else f ; infixr 1 ?

data Node = Node { done :: Bool, kind :: Char, cost :: Int, from :: (Int, Int) }

instance Show Node where
  show (Node d k c (i, j)) =
    printf "done: %s, kind: '%c', cost: %d, from: (%d, %d)" (show d) k c i j

loadData fileName = do
  xss@(xs:_) <- filter (not . null) . lines <$> readFile fileName
  let (b@(_, (lb, ub)), rs)   = (((1, 1), (length xss, length xs)), range b)
  let xs'       = concat xss
  let Just goal = lookup 'G' (zip xs' rs)
  a <- thaw $ array b (map conv (zip rs  xs')) :: IO (IOArray (Int, Int) Node)
  return (ub, goal, a)
  where conv x@(idx, k) | 'S' <- k  = (idx, Node False k 0        idx     )
                        | otherwise = (idx, Node False k minBound (-1, -1))

getRange a = getBounds a >>= return . range

nextNode a = getRange a >>= foldM f Nothing
  where f candidate idx = do
          Node d k c _ <- readArray a idx
          (d || c < 0 ?) (return candidate) $
            case candidate of
              Just idx' -> do
                Node _ _ c' _ <- readArray a idx'
                return $ Just ((c < c' ?) idx idx')
              otherwise -> return $ Just idx

goDijkstra a = nextNode a >>= f a
    where f a Nothing           = return ()
          f a (Just idx@(i, j)) = do
            Node _ k c p <- readArray a idx
            writeArray a idx (Node True k c p)
            mapM_ (g c) [(pred i, j), (succ i, j), (i, pred j), (i, succ j)]
            goDijkstra a
            where g c idx' = do
                    b <- getBounds a
                    when (inRange b idx') $ do
                      Node d' k' c' p' <- readArray a idx'
                      when (k' /= '*' && (c' < 0 || (c + 1) < c')) $ do
                        writeArray a idx' (Node d' k' (c + 1) idx)

fillRoute a idx = do
  Node d k c idx' <- readArray a idx
  case k of
    'S' -> return ()
    'G' -> fillRoute a idx'
    _   -> writeArray a idx (Node d '$' c idx') >> fillRoute  a idx'

arrayToList a n = mapArray kind a >>= getElems >>= return . unfoldr f
  where f []  = Nothing
        f xs' = Just (splitAt n xs')

solve fileName = do
  (l, goal, a) <- loadData fileName
  goDijkstra a
  fillRoute a goal
#ifdef _DEBUG
  getRange a >>= mapM_ (\idx@(i, j) -> readArray a idx >>= printf "(%2d, %2d): %s\n" i j . show)
#endif
  arrayToList a l

main = solve "./test.txt" >>= mapM_ putStrLn

-- $> main
-- **************************
-- *S* *$$$$$               *
-- *$* *$ * $*************  *
-- *$*$$$*  $$************  *
-- *$$$ *    $$$$$          *
-- **************$***********
-- * $$$$$$$$$$$$$          *
-- **$***********************
-- * $$$$$*$$$$$$$$$$$$$$G  *
-- *  *  $$$ *********** *  *
-- *    *        ******* *  *
-- *       *                *
-- **************************
-- (0.34 secs, 42661608 bytes)

■ [アルゴリズム]演習(時事問題6) 13:32

"http://d.hatena.ne.jp/rst76/20100115"を参考に、時事問題5を幅優先で解いてみた。参考にしたコードがあまりに的確なので、ほとんど写経だった。

何となくTreeとSetを使ってみた。

わわわ...、写し間違いに気が付いたので封印...

GHCiで連続して実行すると、たまにコード更新後にreloadしても昔のコードをキャッシュしてるような気がするのだけど気のせい？

で、直ったかなぁ...

import Control.Applicative ((<$>))
import Control.Monad (msum, mzero)
import Data.Tree (levels, unfoldTree)
import qualified Data.Foldable as Foldable
import qualified Data.Set as Set

-- 幅優先(bfs)、一応切り替え可能にしたつもり...
-- リストで全て出力させる時はマップを小さくしないとなかなか終わらない...
-- search :: [String] -> [Set.Set (Int, Int)]
search :: [String] -> Maybe (Set.Set (Int, Int))
search xss = msum . concat . levels . unfoldTree checkPos $ (start, Set.singleton start)
  where Just start = msum [Just (i, j) | (i, xs) <- zip [0 ..] xss, (j, x) <- zip [0 ..] xs, x == 'S']
        charOf (i, j) = xss !! i !! j
        nextOf ((i, j), s) = [(pos, Set.insert pos s) | pos <- xs, Set.notMember pos s]
          where xs = [(pred i, j), (succ i, j), (i, pred j), (i, succ j)]
        checkPos x@(pos, s) = case charOf pos of
          'G' -> (return (foldr Set.delete s [start, pos]), [])
          '*' -> (mzero, [])
          _   -> (mzero, nextOf x)

convert (i, j) xss = insertAt i (insertAt j '$' $ xss !! i) xss
  where insertAt n c xs = take n xs ++ c : drop (succ n) xs

solve xss = foldr convert xss . Set.toList <$> search xss

main = readFile "./test.txt" >>= Foldable.mapM_ (putStrLn . unlines) . solve . lines

■ [アルゴリズム]演習(時事問題7) 21:45

深さ優先で書き換えた。

よく見ると、

concat . levels

が

flatten

に置き換わってる。逆に言えば、他は全く同じ。つか、levelsで幅優先になるのはわかるけど、flattenで深さ優先になるかは知らない。でも、多分そう。Haskellすごいかも...

import Control.Applicative ((<$>))
import Control.Monad (msum, mzero)
import Data.Tree (flatten, unfoldTree)
import qualified Data.Foldable as Foldable
import qualified Data.Set as Set

-- 深さ優先(dfs)だと、小さなマップでも結構時間が掛かる。例題のマップだと
-- とても終わりそうにない(自分のコードが悪いせいもあるけど...)
-- ↓くらいなら大丈夫...
-- **************************
-- *S* *                    *
-- * * *  ***************   *
-- * *   * G  ************  *
-- *    *                   *
-- **************************

-- 一応、切り替え可能にした...
-- search :: [String] -> [Set.Set (Int, Int)]
search :: [String] -> Maybe (Set.Set (Int, Int))

-- Treeを使うと幅優先と深さ優先をconcat . levelsかflattenで比較的簡単に切り替えられる。
-- リストとMaybeの組み合わせで、幅優先か深さ優先、１つ出力か全て出力、の４種類の関数を
-- １つの高階関数で実現できるはず。普通、目的があるからやんないけど...
-- ただ、Treeは前の要素とか必要なくなってもなかなかGCしなそうな気がするのが欝...
search xss = msum . flatten . unfoldTree checkPos $ (start, Set.singleton start)
  where Just start = msum [Just (i, j) | (i, xs) <- zip [0 ..] xss, (j, x) <- zip [0 ..] xs, x == 'S']
        charOf (i, j) = xss !! i !! j
        nextOf ((i, j), s) = [(pos, Set.insert pos s) | pos <- xs, Set.notMember pos s]
          where xs = [(pred i, j), (succ i, j), (i, pred j), (i, succ j)]
        checkPos x@(pos, s) = case charOf pos of
          'G' -> (return (foldr Set.delete s [start, pos]), [])
          '*' -> (mzero, [])
          _   -> (mzero, nextOf x)

convert (i, j) xss = insertAt i (insertAt j '$' $ xss !! i) xss
  where insertAt n c xs = take n xs ++ c : drop (succ n) xs

solve xss = foldr convert xss . Set.toList <$> search xss

main = readFile "./test.txt" >>= Foldable.mapM_ (putStrLn . unlines) . solve . lines