-module BellmanFord {-(spTree)-} where
+module BellmanFord (bellmanFord, BFPath(BFPath)) where
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Internal.Queue
-import Data.Graph.Inductive.Internal.RootPath
-import Data.Array.Diff
+import Data.Array.IArray
+import Data.Array.ST
+import Data.STRef
+import Control.Monad.ST
+import ArrayQueue
+import MonadStuff
+import Data.List
-data NodeInfo b = NodeInfo {
- path :: Maybe [LNode b],
- changed :: Bool
-}
-data Graph gr => BFState gr a b = BFState {
- theGraph :: gr a b,
- nis :: DiffArray Node (NodeInfo b),
- changedQ :: Queue Node
+-- Path to a node
+data Real w => BFPath b w = BFPath {
+ pLen :: w, -- Total distance at the end of the path
+ pDest :: Node, -- Destination of the path
+ pFrom :: Maybe (b, BFPath b w) -- Last edge and remaining path (Nothing for source)
+} deriving Show
+
+data (Graph gr, Real w) => BFState s gr a b w = BFState {
+ bfsGraph :: gr a b,
+ bfsEdgeWt :: b -> w,
+ bfsMPaths :: STArray s Node (Maybe (BFPath b w)),
+ bfsChanged :: ArrayQueue s,
+ -- Sentinel in the queue that ends a pass.
+ bfsPassEnder :: Node,
+ -- The length of the paths we are currently considering.
+ -- If this reaches the number of nodes in the graph, we must have a negative cycle.
+ bfsPass :: STRef s Int
}
-nisToLRTree nis = do
- ni <- elems nis
- case path ni of
- Just lnl -> return (LP lnl)
- Nothing -> fail "Node is unreachable"
+{--
+negativeCycleCheck :: (Graph gr, Real w) => BFState s gr a b w ->
+ BFPath b w -> ST s ()
+negativeCycleCheck state path =
+ let getNodes (BFPath _ dst from) = dst : case from of
+ Nothing -> []
+ Just (_, p1) -> getNodes p1 in
+ let nodes = getNodes path in
+ if length (nub nodes) < length nodes
+ then error ("Negative cycle detected: " ++ show path)
+ else nop
+--}
+
+offerPath :: (Graph gr, Real w) => BFState s gr a b w ->
+ BFPath b w -> ST s ()
+offerPath state newPath@(BFPath newLen dest _) = do
+ oldMPath <- readArray (bfsMPaths state) dest
+ -- Is newPath the first path to dest or shorter than the existing one?
+ let adoptPath = case oldMPath of
+ Nothing -> True
+ Just (BFPath oldLen _ _) -> newLen < oldLen
+ if adoptPath
+ then do
+ -- Save the new path.
+ writeArray (bfsMPaths state) dest (Just newPath)
+ -- Mark dest as changed.
+ aqEnqueue (bfsChanged state) dest
+ nop
+ else nop -- Don't update anything.
-offerPath :: (Graph gr, Real b) => BFState gr a b -> [LNode b] -> BFState gr a b
-offerPath bfs newPath@((dest, newDist): _) =
- -- Is newPath the first path to dest, or better than the previous one?
- let adoptPath =
- case path (nis bfs ! dest) of
- Nothing -> True
- Just ((_, oldDist) : _) -> newDist < oldDist
- in
- if adoptPath then
- bfs{
- -- Update NodeInfo with the new path.
- nis = nis bfs // [(dest, NodeInfo (Just newPath) True)],
- changedQ = if changed (nis bfs ! dest)
- then changedQ bfs -- Already on the queue; leave as is.
- else queuePut dest (changedQ bfs) -- Add to queue.
- }
- else bfs -- Don't update anything.
+processEdge :: (Graph gr, Real w) => BFState s gr a b w ->
+ BFPath b w -> LEdge b -> ST s ()
+processEdge state path1@(BFPath len1 _ _) (_, dest, label) = do
+ let edgeLen = (bfsEdgeWt state) label
+ let newPath = BFPath (len1 + edgeLen) dest (Just (label, path1))
+ offerPath state newPath
-processEdge :: (Graph gr, Real b) => [LNode b] -> LEdge b -> BFState gr a b -> BFState gr a b
-processEdge srcPath@((_, srcDist) : _) (_, dest, edgeLen) bfs =
- let newPath = (dest, srcDist + edgeLen) : srcPath in
- offerPath bfs newPath
+endPass :: (Graph gr, Real w) => BFState s gr a b w -> ST s ()
+endPass state = do
+ qEmpty <- aqIsEmpty (bfsChanged state)
+ if qEmpty
+ then nop -- No nodes to visit on the next pass. We're done.
+ else do
+ -- Increment the pass number.
+ modifySTRef (bfsPass state) (+ 1)
+ p <- readSTRef (bfsPass state)
+ if p == noNodes (bfsGraph state)
+ then error "BellmanFord: Negative cycle detected!"
+ else do
+ -- Re-enqueue the pass ender.
+ aqEnqueue (bfsChanged state) (bfsPassEnder state)
+ search state -- Continue with the next pass.
-search :: (Graph gr, Real b) => BFState gr a b -> LRTree b
-search bfs =
- if queueEmpty (changedQ bfs) then
- -- Finished.
- nisToLRTree (nis bfs)
- else
- -- Process a changed node from the queue.
- let (src, moreQ) = queueGet (changedQ bfs) in
- let srcNI = nis bfs ! src in
- -- Clear src's changed flag.
- let bfs1 = bfs{nis = nis bfs // [(src, srcNI{changed = False})], changedQ = moreQ} in
- let Just srcPath = path srcNI in
- let outEdges = out (theGraph bfs) src in
- let newBFS = foldr (processEdge srcPath) bfs1 outEdges in
- search newBFS
+search :: forall s gr a b w. (Graph gr, Real w) => BFState s gr a b w -> ST s ()
+search state = do
+ Just node <- aqDequeue (bfsChanged state)
+ if node == bfsPassEnder state
+ then endPass state
+ else do
+ mPath1 <- readArray (bfsMPaths state) node
+ let Just path1 = mPath1
+ sequence $ map (processEdge state path1) $
+ out (bfsGraph state) node
+ search state -- Keep going.
-spTree :: (Graph gr, Real b) => Node -> gr a b -> LRTree b
-spTree source theGraph = let theNodes = range (nodeRange theGraph) in
- let emptyBFS = BFState theGraph
- (array (nodeRange theGraph) (map (\n -> (n, NodeInfo Nothing False)) theNodes))
- mkQueue in
- -- Start with a zero-length path to the source.
- let initBFS = offerPath emptyBFS [(source, 0)] in
- search initBFS
+bellmanFord :: (Graph gr, Real w) =>
+ (b -> w) -> -- Edge label -> weight
+ Node -> -- Source node
+ gr a b -> -- Graph
+ Array Node (Maybe (BFPath b w)) -- ! node -> maybe a path
+bellmanFord edgeWt source theGraph = runSTArray (do
+ mPaths <- newArray (nodeRange theGraph) Nothing
+ let (nlo, nhi) = nodeRange theGraph
+ let passEnder = nlo - 1
+ changed <- newArrayQueue (passEnder, nhi) -- Queue can contain the pass ender.
+ pass <- newSTRef 0
+ let state = BFState theGraph edgeWt mPaths changed passEnder pass
+ -- Pass is 0, and the queue contains a node that was offered a path with 0 edges.
+ offerPath state (BFPath 0 source Nothing)
+ aqEnqueue (bfsChanged state) (bfsPassEnder state)
+ search state
+ return (bfsMPaths state)
+ )
Matt McCutchen's Web Site / match / match.git / blobdiff