椿の日記

たぶんプログラムの話をします

プログラミングコンテスト チャレンジブック 第２版を買ってみた

プログラミングコンテストチャレンジブック [第2版]　?問題解決のアルゴリズム活用力とコーディングテクニックを鍛える?

プログラミングコンテストチャレンジブック [第2版]　?問題解決のアルゴリズム活用力とコーディングテクニックを鍛える?


気分転換にこちらの本に挑戦することにしました。この本は回答のサンプルがC++で書かれてますがHaskellで解く予定です。Haskellは言語自体は好きなのですが普段あまり使わないのでまずは慣れるために。

MySQLの日本語表示の話

Haskell プログラミング

なんか日本語が表示できないなあ、と思ってたら凄く単純な話でした。これをやっておかないとならないようです。

quickQuery conn "SET NAMES utf8" []

こうしないと、日本語文字の部分が?に化けてしまいます。これはmysqlの関数がやっているようで、Haskellは全く関係ありません…
で、SqlByteStringに入ってくる値はutf8です。これをそのままコンソールに表示するのは面倒なんで、適当に標準出力をファイルあたりにリダイレクトしてファイルから確認するのが良さそうです。

Haskellの実行速度

Haskell プログラミング

haskell vs その他の言語 - ながとの日記 という記事を見て、へぇーと思ってみてたのですが、元記事のコードの次の2つが何故これほどまでに違うのか、ちょっと気になったのでコンパイルだけして実際に確認してみます。(2つ目のはBangPatternの言語拡張のとこだけ削除)

import Control.Monad
import qualified Data.HashTable as H

main = do
    m <- H.new (==) H.hashInt
    forM_ [1..10000000] $ \n -> H.insert m n n
    v <- H.lookup m 100
    print v

import qualified Data.HashTable as H
import Data.Maybe

eqInt :: Int -> Int -> Bool
eqInt a b = a == b

type HT = H.HashTable Int Int

n = 1000000

loadHashtable :: HT -> IO ()
loadHashtable ht = work n
  where
    work :: Int -> IO ()
    work i = do
      if i < 0 then
          return ()
        else do
          H.insert ht i i
          work (i-1)

main = do
  h <- H.new eqInt H.hashInt
  loadHashtable h
  i <- (H.lookup h 100) >>= (return . show . fromJust)
  putStrLn i

確かに後者のほうが圧倒的に速いです。恐らく違いは数字の列挙の方法にあり、前者は巨大なリストの走査で、後者はループカウンタの利用、ということなのでしょうか。
ただ現実問題として毎回後者のように書くのもアレなので、アクション部分を入れ替えられる高階関数を用意したほうが良さそうですね。

forIntM_ :: Int -> (Int -> IO ()) -> IO ()
forIntM_ n act = work n
  where
    work :: Int -> IO ()
    work i = do
      if i < 0 then
        return ()
      else do
        act i
        work (i-1)

loadHashtable :: HT -> IO ()
loadHashtable ht = forIntM_ n (\i -> H.insert ht i i)

Haskellでこの問題を解いてみた②

Haskell プログラミング

同じ人が別の問題を作っておられたようなので、解いてみました。

ぷよぷよ19連鎖

import Data.Array
import Data.List

type Point = (Int,Int)
type Field = Array Point Char
type Route = [Point]

isLegalPuyo :: Char -> Bool
isLegalPuyo '\n' = False
isLegalPuyo '\r' = False
isLegalPuyo _ = True

parseField :: String -> Field
parseField cs =
    let numRow = length $ lines $ cs
        numCol = length $ head $ lines $ cs
        puyos = filter isLegalPuyo cs
    in  array ((1,1),(numRow,numCol)) $ zip [(y,x) | y <- [1..numRow], x <- [1..numCol]] puyos

unfoldLine :: Int -> String -> [String]
unfoldLine x cs = case splitAt x cs of
                      (xs,[]) -> [xs]
                      (xs,ys) -> xs : unfoldLine x ys

showField :: Field -> IO ()
showField field = do
    putStr $ unlines $ unfoldLine (snd $ snd $ bounds field) $ elems field

dfs :: (a -> [a]) -> a -> [a]
dfs next node = dfs' node
    where
        dfs' n = n : concatMap dfs' (next n)

inBound :: Field -> Point -> Bool
inBound field (y,x) =
    let ((y1,x1),(y2,x2)) = bounds field
    in  y1 <= y && y <= y2 && x1 <= x && x <= x2

findNextRoutes :: Field -> Route -> [Route]
findNextRoutes field route =
    let pos@(y,x) = head route
        neighbors = filter (inBound field) [(y+1,x),(y-1,x),(y,x+1),(y,x-1)]
        puyo = field ! pos
        same_puyo_poss = filter (\p -> (field ! p) == puyo) neighbors
        not_dupe_poss = filter (\p -> not $ p `elem` route) same_puyo_poss
    in  map (:route) not_dupe_poss

findChainedRoute :: Field -> Point -> Route
findChainedRoute field pos = 
    let routes = dfs (findNextRoutes field) [pos]
    in  nub $ concat $ routes

erasePuyo :: Field -> Maybe Field
erasePuyo field =
    let puyo_poss = filter (\x -> (field ! x) /= ' ') (indices field)
        erase_routes = filter (\x -> length x >= 4) $ map (findChainedRoute field) puyo_poss
        erase_pos = nub $ concat $ erase_routes
    in  case erase_pos of
            [] -> Nothing
            xs -> Just (field // zip xs (repeat ' '))

dropPuyoLine :: Int -> Field -> Field
dropPuyoLine col field =
    let numRow = fst $ snd $ bounds field
        puyos = map (field !) [(p,col) | p <- [numRow,numRow-1 .. 1]]
        packedPuyos = filter (/= ' ') puyos
    in  field // zip [(p,col) | p <- [numRow,numRow-1 .. 1]] (packedPuyos ++ repeat ' ')

dropPuyo :: Field -> Field
dropPuyo field =
    let numCol = snd $ snd $ bounds field
    in  foldr dropPuyoLine field [1..numCol]

enumerateFields :: Field -> [Field]
enumerateFields field =
    case erasePuyo field of
        Just x -> let next_field = dropPuyo x
                  in  next_field : enumerateFields next_field
        Nothing -> []

showNumberedField :: (Int,Field) -> IO ()
showNumberedField (index,field) = do
    putStrLn $ show index
    putStrLn ""
    showField field
    putStrLn "------------------------------------"

main :: IO ()
main = do
    cs <- readFile "source.txt"
    let field = parseField cs
        enumerated_fields = enumerateFields field
    mapM_ showNumberedField (zip [1..] enumerated_fields)

だいたい1時間くらいでした。前の問題もそうだったんですが、慣れたＣ言語ならば半分くらいの時間で作れた気がするのが関数型言語好きとしては非常に悔しいです。関数脳を鍛えるには…。処理効率もあんまり良くないですし。

Haskellでこの問題を解いてみた

Haskell プログラミング

web巡回してたらこんなページを見つけたので、解いてみました。

人材獲得作戦・４　試験問題ほか

import Data.Array
import Data.Maybe
import Data.List

data Cell = Space | Wall | Start | Goal | Road deriving (Show, Eq)

type Field = Array (Int,Int) Cell
type Route = [(Int,Int)]

charToCell :: Char -> Maybe Cell
charToCell ' ' = Just Space
charToCell '*' = Just Wall
charToCell 'S' = Just Start
charToCell 'G' = Just Goal
charToCell _ = Nothing

cellToChar :: Cell -> Char
cellToChar Space = ' '
cellToChar Wall = '*'
cellToChar Start = 'S'
cellToChar Goal = 'G'
cellToChar Road = '$'

parseField :: String -> Field
parseField cs =
    let numRow = length $ lines cs
        numCol = length $ head $ lines cs
        cells = mapMaybe charToCell cs
    in  array ((1,1),(numRow,numCol)) $ zip [(y,x) | y <- [1..numRow], x <- [1..numCol]] cells

unfoldLine :: Int -> String -> [String]
unfoldLine _ [] = []
unfoldLine x cs = case drop x cs of
                      [] -> [cs]
                      ds -> take x cs : unfoldLine x ds

showField :: Field -> IO ()
showField field = putStr $ unlines $ unfoldLine (snd $ snd $ bounds field) $ map cellToChar $ elems field

findStart :: Field -> (Int,Int)
findStart field = case find (\(i,e) -> e == Start) (assocs field) of
                      Just (i,e) -> i
                      otherwise  -> error "not found start position"

findNextRoute :: Field -> Route -> [Route]
findNextRoute field route =
   let head_pos = head route
       y = fst head_pos
       x = snd head_pos
       next_poss = [(y+1,x),(y-1,x),(y,x+1),(y,x-1)]
       not_wall_poss = filter (\x -> (field ! x) /= Wall) next_poss
       not_dupe_poss = filter (\x -> not (x `elem` route)) not_wall_poss
   in  map (:route) not_dupe_poss

dfs :: (a -> [a]) -> a -> [a]
dfs next node = dfs' node
    where
        dfs' n = n : concatMap dfs' (next n)

bfs :: (a -> [a]) -> a -> [a]
bfs next node = bfs' [node]
    where
        bfs' xs = xs ++ bfs' (concatMap next xs)

findAllRoute :: Field -> Route -> [Route]
findAllRoute field route = bfs (findNextRoute field) route

main :: IO ()
main = do
    cs <- readFile "sample.txt"
    let field = parseField cs
        routes = findAllRoute field [findStart field]
        cond x = (field ! (head x)) == Goal
        route = find cond routes
        answer = case route of
                     Just x -> field // (zip x (repeat Road))
                     otherwise -> field
    showField answer

間違ってDFSで書いてしまった名残がソースに残ってしまいました。

Haskellの強いところは、やはりdfsとbfs関数ですね。(ほぼ)無限リストを構築し、その先頭をfindで探せるので、このあたりのコードがスッキリしています。探索部分自体のコードは凄く短い。

この問題によるレベル判定に「Lv3:不完全な最短性のチェックまでできた」「Lv4:最短性のチェックができた」とありますが、幅優先探索で見つけたらLv4で良いのでしょうか（笑）