Haskellでダイクストラ法

2013-02-22

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はゴール位置1つだけじゃなくて、スタート位置から辿れるすべての位置の最短経路を返す。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