X-Git-Url: https://mattmccutchen.net/match/match.git/blobdiff_plain/08532bcc65c3e99738cddecdd86e1a7904100119..5a07db44406bad03321a90b0814cc4496c6b7d63:/program/BellmanFord.hs diff --git a/program/BellmanFord.hs b/program/BellmanFord.hs index 506acd9..da0fdf8 100644 --- a/program/BellmanFord.hs +++ b/program/BellmanFord.hs @@ -1,69 +1,113 @@ -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) + )