迷路解析・改良

改良してみた。

Pointという正格データ型を作り、Array、Set、Sequenceというデータ型を駆使してみた。けど、時間を測ってみると、それほど替わりはない(どちらにせよ0.005秒とかだけど)。

また、Data.Unambライブラリを使ってみたかったので、簡単な並列化、'S'から'G'へと'G'から'S'への二経路を探索するようにしてみた。

2Coreでうまくスレッドが機能すれば、より早いほうで結論をだせるけど、いわば逆向きのほとんど同じ計算を2スレッドでやっているだけなので、1Coreだとか、スレッドがうまく機能しないだとかだと、本来的には効率が落ちているかも。

でも、僕の手元では、うまく機能しているっぽい。

-- Labyrinth.hs
module Main where

import Data.Array (Array, Ix, array, (!))
import Data.Function (on)
import Data.Unamb
import Data.Set (Set, empty, member, insert, fromList)
import Data.Sequence (Seq, ViewL(..), viewl, singleton, (|>))
import System (getArgs, exitFailure)

import Debug.Trace

data Point = Point !Int !Int
  deriving (Eq, Show, Ix)

instance Ord Point where
  compare (Point x1 y1) (Point x2 y2) =
    let yc = compare y1 y2
    in if yc == EQ then compare x1 x2 else yc

main = do
  args <- getArgs
  if length args /= 1 && length args /= 2
    then putStrLn "Usage: Labyrinth imput [output]" >> exitFailure
    else return ()

  input <- readFile (args!!0)
  let (list, start, goal, range) = parse input
      labyrinth = array (Point 0 0 , range) list

  path <- search labyrinth start goal
          `amb` search labyrinth goal start

  let output = layout list path

  if length args == 2
    then writeFile (args!!1) output
    else putStrLn output

parse :: String -> ([(Point, Char)], Point, Point, Point)
parse l = build l [] (Point 0 0) (Point 0 0) 0 0 0 0
    where
      build :: String -> [(Point, Char)]
               -> Point -> Point
               -> Int -> Int -> Int -> Int
               -> ([(Point, Char)], Point, Point, Point)
      build [] pmap start goal x y mx my = (pmap, start, goal, Point mx my)
      build (h:t) pmap start goal x y mx my
        | h == 'S'  = build t newmap pos   goal (x+1) y    nmx nmy
        | h == 'G'  = build t newmap start pos  (x+1) y    nmx nmy
        | h == '\n' = build t newmap start goal  0   (y+1) nmx nmy
        | otherwise = build t newmap start goal (x+1) y    nmx nmy
        where
          pos = Point x y
          newmap = (pos, h) : pmap
          nmx = max x mx
          nmy = max y my

search :: Array Point Char -> Point -> Point -> [Point]
search labyrinth start goal = search' empty (singleton [start])
  where
    search' :: Set Point -> Seq [Point] -> [Point]
    search' checked queue 
      | pos == goal              = path
      | (member pos checked)     = search' checked rest
      | labyrinth!pos == '*'     = search' (insert pos checked) rest
      | otherwise                = search' (insert pos checked) next
      where
        ((:<) path@(pos@(Point x y):_) rest) = viewl queue
        next = rest
               |> (Point  x   (y+1) : path)
               |> (Point  x   (y-1) : path)
               |> (Point (x+1) y    : path)
               |> (Point (x-1) y    : path)

layout :: [(Point,Char)] -> [Point] -> String
layout list path = foldl (flip $ (:).snd.conv) [] list
  where
    path' = fromList path
    conv t@(pos, c)
      | c == ' ' && member pos path' = (pos, '$')
      | otherwise                    = t

search'が経路探索の本体部分:

    search' :: Set Point -> Seq [Point] -> [Point]
    search' checked queue 
      | pos == goal              = path
      | (member pos checked)     = search' checked rest
      | labyrinth!pos == '*'     = search' (insert pos checked) rest
      | otherwise                = search' (insert pos checked) next
      where
        ((:<) path@(pos@(Point x y):_) rest) = viewl queue
        next = rest
               |> ...

何て綺麗な末尾再帰！

path、pos、x、yの値をとっている部分が読みにくい。読みやくすくは出きるけど、これが１番よく呼び出される部分だから、一気にパターンマッチでとったほうが早くなるかなと思って、こうした。

入力データを解析している関数parseは複雑:

parse :: String -> ([(Point, Char)], Point, Point, Point)
parse l = build l [] (Point 0 0) (Point 0 0) 0 0 0 0
    where
      build :: String -> [(Point, Char)]
               -> Point -> Point
               -> Int -> Int -> Int -> Int
               -> ([(Point, Char)], Point, Point, Point)
      build [] pmap start goal x y mx my = (pmap, start, goal, Point mx my)
      build (h:t) pmap start goal x y mx my
        | h == 'S'  = build t newmap pos   goal (x+1) y    nmx nmy
        | h == 'G'  = build t newmap start pos  (x+1) y    nmx nmy
        | h == '\n' = build t newmap start goal  0   (y+1) nmx nmy
        | otherwise = build t newmap start goal (x+1) y    nmx nmy
        where ...

文字列([Char])を末尾再帰で解析し、最終的に返す(1)それぞれの文字の位置のリスト、(2)Sの位置、(3)Gの位置、(4)配列にするときのサイズの四つの情報と、計算のために必要な情報の全部明示的に持ち運んでいるため、関数引数が長くなっている。

これは、手続き型言語ならグローバル変数でも使うところ。Stateモナドを使えば綺麗になるかな？

あと連結するためのリストも持ち運んでいるから、文字列が逆向きになる。再帰部分から文字を返させて連結していけば、逆向きにはならないんだけど、連結させる文字だけを他の返り値から分離させるのが面倒なのと、そうしたら末尾再帰にならないので、これはこれで良いか。

それを、最後の出力関数layoutでもう一度ひっくり返している:

layout :: [(Point,Char)] -> [Point] -> String
layout list path = foldl (flip $ (:).snd.conv) [] list
  where
    path' = fromList path
    conv t@(pos, c)
      | c == ' ' && member pos path' = (pos, '$')
      | otherwise                    = t

「foldl (flip $ (:).snd.conv)」の部分がそう。実質的に、評判の悪いreverse関数を二回使って、最初と同じ順番で(ほぼ)同内容のリストを得ているのと同じ。ただし、今の実装では、入力部parseでも、出力部layoutでも全要素の走査が必要なので、二回reverseでも問題はない。

ただ、これも手続き型言語なら、走査なんかせずに確保しているデータ構造を破壊的に変更して終わり、となるところ。haskellでも少なくともlayoutでの全走査は必須ではないので、その辺はもっと改良できる余地がある*1。

全体的に、計算の主要部分は綺麗な末尾再帰でいかにも関数型言語的に書け、しかもコンパクトになっている。トークンの数とかからいえば、同じ内容をこれ以上短く書ける言語はそうないのではないか、と思う。

でも、入出力部で、手続き型言語に比べてコードが間延びしているし、手続き型言語以上に考えなくてはいけない感じ。

最後に平行化をしている部分:

  path <- search labyrinth start goal
          `amb` search labyrinth goal start

これだけ。このamb関数一つが、中置演算子のように書かれている関数たった一つが、平行化、スレッドの生成と先に結論の出たほうを採用するというロジックを実現している。

すごくない？　使ってみたいですよね、これ。Data.Unambライブラリ。

*1:それで速度が向上しても、プログラム全体の処理コストと比較すれば微々たるものだと思うけど。