【Haskell】ダイクストラ法を実装する

2013-02-22
#algorithm #haskell

Project Eulerの81は左上から右か下だけに動いて右下までの、一番値が小さいルートを見つける問題。総当りでやろうとしたが、迷路が80x80で組み合わせが

通りなので全然無理だった。

最短経路を見つけるうまいアルゴリズムにダイクストラ法がある。ということでダイクストラ法を使って最短経路を求めよう。

Haskellでライブラリがあるのかわからないが、パッとググったところ見つからなかったので自作してみた。Data.Graphはこういう用途で使えるんだろうか…わからん。

グラフを表す情報にノードとエッジがあるけど、最短経路を求めるための入力としてはノード自体は特に情報は必要なくて、エッジ（有向グラフで、元ノードとターゲットノードとコスト）だけで十分。

dijkstra :: pos -> pos -> [(pos, cost, pos)] -> (cost, [pos])
dijkstra start goal edges = shortestPaths ! goal
  where shortestPaths = dijkstraAll start edges

dijkstraAll :: pos -> [(pos, cost, pos)] -> Map pos (cost, [pos])
dijkstraAll start edges = fst $ until (null . snd) (step edgeMap) initial
  where initial = (empty, singleton start (0, [start]))
        edgeMap = genEdgeMap edges

dijkstraはスタート位置とゴール位置、あとエッジリストを受け取って、最短経路（コスト、道順（の逆））を返す。dijkstraAllはゴール位置１つだけじゃなくて、スタート位置から辿れるすべての位置の最短経路を返す。until (null . snd)で、まだ決定されてないノードがなくなるまでstepを繰り返す。

step :: Map pos [Edge pos cost] ->
        (Map pos (cost, [pos]), Map pos (cost, [pos])) ->
        (Map pos (cost, [pos]), Map pos (cost, [pos]))
step edgeMap (pathMap, nodeMap) =
  let (pos, path) = getMinimumCostNode nodeMap
      edges = findWithDefault [] pos edgeMap
  in if pos `member` pathMap
       then (pathMap, delete pos nodeMap)
       else let nodeMap' = delete pos $ updateNeigbors path edges nodeMap
                pathMap' = insert pos path pathMap
            in (pathMap', nodeMap')

pathMapはスタートからの最短経路が確定したノードのパス、nodeMapは仮状態の最短経路が計算されたノードで、どちらもコストと道順を保持している。処理としては、未決定のノードの中で最短のコストとなるノードを見つけて、そのパスを確定する。その確定したノードに接続しているノードに対して、新たにそのノードからのエッジを通った場合のトータルコストが低い場合にはそちらを採用する。

計算量は、一番近いノード順に最短経路を探す外側のループがN、まだ決定されてないノードから一番近いノードを探すのが、ノード全体じゃなくて未決定のノード分、なのでノード全体よりは少なくてそんなに爆発的に増えない、と仮定するとO(N)くらいになるのかな？

モジュール全体のソースは

module Dijkstra (
  dijkstra,
  dijkstraAll
) where

import Prelude hiding (null)
import Data.List (minimumBy)
import Data.Map (Map, alter, delete, empty, findWithDefault, insert, member,
                 null, singleton, toList, (!))
import Data.Ord (comparing)

data Edge pos cost = Edge pos cost
  deriving Show

-- Finds shortest path from starting position using edge list.
-- Edge is a triplet which consists of (from, cost, to).
dijkstra :: (Ord pos, Num cost, Ord cost) =>
            pos -> pos -> [(pos, cost, pos)] -> (cost, [pos])
dijkstra start goal edges = shortestPaths ! goal
  where shortestPaths = dijkstraAll start edges

dijkstraAll :: (Ord pos, Num cost, Ord cost) =>
               pos -> [(pos, cost, pos)] -> Map pos (cost, [pos])
dijkstraAll start edges = fst $ until (null . snd) (step edgeMap) initial
  where initial = (empty, singleton start (0, [start]))
        edgeMap = genEdgeMap edges

-- One step for Dijkstra algorithm.
--   * Pick next shortest path from undetermined nodes and determine it as the
--     shortest path for the position.
--   * If new path for its neighbors is shorter than current one, overwrite it.
-- PathMap stores determined shortest paths for each position.
-- Each node in the nodeMap has temporal shortest path.
-- Path consists of cost and way (a list of position, reverse order).
step :: (Ord pos, Num cost, Ord cost) =>
        Map pos [Edge pos cost] ->
        (Map pos (cost, [pos]), Map pos (cost, [pos])) ->
        (Map pos (cost, [pos]), Map pos (cost, [pos]))
step edgeMap (pathMap, nodeMap) =
  let (pos, path) = getMinimumCostNode nodeMap
      edges = findWithDefault [] pos edgeMap
  in if pos `member` pathMap  -- Shortest Path is already determined.
       then (pathMap, delete pos nodeMap)
       else let nodeMap' = delete pos $ updateNeigbors path edges nodeMap
                pathMap' = insert pos path pathMap
            in (pathMap', nodeMap')

getMinimumCostNode :: (Ord pos, Num cost, Ord cost) =>
                      Map pos (cost, [pos]) -> (pos, (cost, [pos]))
getMinimumCostNode = minimumBy (comparing getCost) . toList
  where getCost (_, (cost, _)) = cost

updateNeigbors :: (Ord pos, Num cost, Ord cost) =>
                  (cost, [pos]) -> [Edge pos cost] -> Map pos (cost, [pos]) ->
                  Map pos (cost, [pos])
updateNeigbors (cost, way) edges nodeMap = foldl updateNeighbor nodeMap edges
  where updateNeighbor nodeMap (Edge nextPos moveCost) =
          alter (updateNode (moveCost + cost, nextPos:way)) nextPos nodeMap

updateNode :: (Ord pos, Num cost, Ord cost) =>
              (cost, [pos]) -> Maybe (cost, [pos]) -> Maybe (cost, [pos])
updateNode newPath Nothing     = return newPath
updateNode newPath (Just path) = return $ min newPath path

genEdgeMap :: (Ord pos, Num cost, Ord cost) =>
              [(pos, cost, pos)] -> Map pos [Edge pos cost]
genEdgeMap edges = foldl f empty edges
  where f edgeMap (from, cost, to) = append (Edge to cost) from edgeMap
        append val pos map = insert pos (val: findWithDefault [] pos map) map

関連記事

新着記事