Round 1B (Google Code Jam 2009) - 落書き、時々落学

まぁ，前回同様，予想通り，ダメダメだったわけだが．

共通のテンプレート（下）を使用した．

import Data.List
import Data.Maybe
import Data.Ord
import Data.Char
import Data.Function
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as Set
import Data.MemoTrie
import Data.Array
import Data.Array.ST
import Control.Monad
import Control.Monad.ST

getList :: Read a => IO [a]
getList = liftM (map read.words) getLine

getInts :: IO [Int]
getInts = getList

getInt :: IO Int
getInt = liftM head getInts

これで，qualifiedの綴りに迷うことがなくなれば，幸いだ．

（ちなみに，ソースコードは見やすいように手を加えてある）

A

ぱっと見．問題文長い．
英語が苦手な僕は，こんなん読んでたら，理解するのに30分くらいかかる．とか思って，Bに進んだ．

そのあと戻ってきましたが．

二分木のパーサが出来れば，おしまい，な問題だと思う．
しかし．
しかし，である．

パーサつくるの面倒．しかし，ライブラリの使いかた（多分，Haskellにはパーサのライブラリがあった）
も知らないし．

だけど，Cは厄介そうだったので，仕方なく，力技で書いた．

data Tree = T {w::Double, f::String, y::Tree, n::Tree} | L {w::Double} deriving Show

mkTree :: String -> Tree
mkTree s | leaf s    = L ( read.init.tail $ s)
         | otherwise = let w' = read.tail $ w
                           f' = f
                           (ys,ns) = cut $ unwords ws
                           ns' = fst $ cut ns
                       in T w' f' (mkTree ys) (mkTree ns')
         where (w:f:ws) = words s

leaf :: [Char] -> Bool
leaf s = all (`elem` "()0123456789. ") s

cut :: String -> (String, String)
cut (' ':s) = cut s
cut ('(':s) = cpart 1 "(" s
    where cpart 0 cs s = (cs, s)
          cpart p cs ('(':s) = cpart (p+1) (cs++"(") s
          cpart p cs (')':s) = cpart (p-1) (cs++")") s
          cpart p cs (c  :s) = cpart p (cs ++ [c])   s

cute :: Tree -> [String] -> Double -> Double
cute (L w) fs p = p * w
cute (T w f y n) fs p | elem f fs = cute y fs (w * p)
                      | otherwise = cute n fs (w * p)

main = do n <- getInt
          forM_ [1..n] $ \i ->
              do l <- getInt
                 t <- replicateM l getLine
                 let t' = mkTree.fst.cut.unlines $ t
                 a <- getInt
                 putStrLn $ "Case #" ++ show i ++ ":"
                 forM_ [1..a] $ \a ->
                       do fs <- getLine
                          print $ cute t' (drop 2.words $ fs) 1

ものすごい，その場しのぎのコードなので，気に食わない．
Stringの処理に手間取った．

B

問題文，短い．
これだよ，こういう問題が良いんだよ．意気揚々と問題文を読み始める．

5分後…

＞日本語でおk?

10分後…

＞日本語で(ry

15分後…

＞にほ（ry

と，まぁ，問題文が短いだけに，意味が分からないと，困ると．

桁が増える場合，などを考えていなかったりして，結構時間を食った．

あとで分かったが，この問題は next permutation を求めるもんだい．
なので，これが理解できると一瞬（で，出来る人もいる）．

ということで，コードはシンプル．

main = do t <- getInt
          forM_ [1..t] $ \i ->
              do n <- liftM read getLine
                 putStrLn $ "Case #" ++ show i ++ "] " ++ show (next n)

next :: Integer -> Integer
next n = read.map intToDigit.npart1 [] .reverse.(0:).map digitToInt.show $ n
npart1 xs (y:z:zs) | y > z     = npart2 z (y:xs) zs
                   | otherwise = npart1 (y:xs) (z:zs)
npart1 xs [z] = npart2 z xs []
npart2 z xs ys = reverse ys ++ m : sort (delete m (z:xs))
    where m = minimum.filter (>z) $ xs

しかし，もう少し速く解けるだろう，この問題程度なら．

そういえば，このとき，screen か zsh かどっちか分からないけど，変な挙動を突然したから，
焦った．結局，ほかのterminal立ちあげて，どうにかなった．

C

これは問題文は，他2問と比べると，すんなり，理解できた．
ようは，最短路問題ですよ，たぶん．

とりあえず，コンテスト中に (座標, 数式の計算結果）を頂点にして，枝を座標移動にともなう，数式の追加
な感じで表現して，ダミーの頂点を一つ追加して，最短パスのアルゴリズムを走らせれば，答えはでるなー,

= O(Q * W * W),

= O( Q * W * W) ぐらいかー，

まぁ，計算は終わるな．
でも，実装はHaskellだと時間的に無理かな.
と，思ってました．

実際，時間切れでした．

終了後，つくったコード．ベルマン・フォード的なコード（配列の代わりにMapを使用）．
しかし，汚いコードだ．しかも，遅い．

type Point = (Int, Int)
type MS    = Array Point Char
type Memo  = Map (Point, Int) String
type Ans   = Map Int String
type State = ((Point,Int), String)

_QueryMax = 250

nodes :: MS -> [Point]
nodes ms = filter (isDigit.(ms !)).range.bounds $ ms

neighboor s (i,j) = filter (inRange.bounds $ s) [(i,j+1),(i+1,j),(i,j-1),(i-1,j)]

edge ms (0,0) = [(x, digitToInt $ ms ! x, [ms ! x]) | x <- nodes ms]
edge ms x = nub.sort $ [(z, delta y z, [ms ! y, ms ! z]) | y <- neighboor ms x, z <- neighboor ms y]
    where delta a b | ms ! a == '+' = digitToInt $ ms ! b
                    | ms ! a == '-' = negate.digitToInt $ ms ! b

updateMemo :: MS -> Memo -> [State] -> (Memo, [State])
updateMemo ms m xs = foldl' upart (m, []) xs
    where  upart (m, zs) x | M.member (fst x) m = (m, zs)
                           | otherwise          = (uncurry M.insert x m, x:zs)

updateAns :: MS -> Ans -> [State] -> Ans
updateAns ms a xs = foldl' upart a ys
    where ys = nub' [(c,s)| ((x,c),s) <- xs, 0 < c && c <=_QueryMax]
          upart a x | M.member (fst x) a = a
                    | otherwise          = uncurry M.insert x a

step ms m a xs
    | M.size a == _QueryMax = a
    | null xs               = a
    | otherwise             = step ms m' a' zs
    where (m',ys) = updateMemo ms m xs
          a'      = updateAns ms a ys
          zs      = nexts ms m' ys

next :: MS -> Memo -> State -> [State]
next ms m ((x,c),s) = [((z, c + d), s ++ s') |(z,d,s') <- edge ms x, c + d > -_QueryMax, c + d < 2 *_QueryMax]
nexts :: MS -> Memo -> [State] -> [State]
nexts ms m xs = nub' $ concatMap (next ms m) xs
nub' :: (Ord a, Ord b) => [(a,b)] -> [(a,b)]
nub' = map (minimumBy $ comparing snd).groupBy (on (==) fst).sort

main = do n <- getInt
          forM_ [1..n] $ \i ->
              do (w:q:_) <- getInts
                 ms <- getSquare w
                 qs <- getInts
                 let a = step ms (M.empty) (M.empty) [(((0,0),0),"")]
                 putStrLn $ "Case #" ++ show i ++ ":"
                 forM_ qs $ \j ->
                     putStrLn.fromJust.M.lookup j $ a

-- output and input function

getSquare w = liftM (listArray ((1,1),(w,w)).concat).replicateM w $ getLine

初めは，fglのライブラリ使って，お手軽最短経路を実行しようと画策していたが，

グラフの頂点はIntでないとダメ
枝の重みは Real でないとダメ

らしいので，どうやらお手軽作戦は，全然お手軽では無い模様だった．

どうにかして，関数型らしく書けないものか．

# あ，neighboursだった．