Added dijkstra for Acyclic.Labelled

algebraic-graphs.cabal

@@ -69,6 +69,7 @@ library
                         Algebra.Graph.Acyclic.AdjacencyMap,
                         Algebra.Graph.Acyclic.Ord,
                         Algebra.Graph.Acyclic.Labelled.AdjacencyMap,
+                        Algebra.Graph.Acyclic.Labelled.Algorithm,
                         Algebra.Graph.AdjacencyIntMap,
                         Algebra.Graph.AdjacencyIntMap.Algorithm,
                         Algebra.Graph.AdjacencyMap,

src/Algebra/Graph/Acyclic/Labelled/Algorithm.hs

@@ -0,0 +1,42 @@
+module Algebra.Graph.Acyclic.Labelled.Algorithm where
+
+import Algebra.Graph.Acyclic.Labelled.AdjacencyMap
+import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM
+import Algebra.Graph.Label
+import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM
+import Data.Map.Strict (Map, (!))
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+
+-- TODO: Replace this function with 'skeleton' from Acyclic.Labelled to remove the use of fromMaybe
+-- TODO: Make 'topSort' more efficient
+topSort :: (Ord a) => AdjacencyMap e a -> [a]
+topSort = fromMaybe [] . AM.topSort . LAM.skeleton . fromAcyclic
+
+dijkstra :: (Semiring e, Ord a) => AdjacencyMap e a -> a -> Map a e
+dijkstra am s = foldl (relaxVertex em) (initialize em) vl
+  where
+    vl = dropWhile (/=s) $ topSort am
+    em = (LAM.adjacencyMap . fromAcyclic) am
+    initialize = Map.insert s one . Map.map (const zero)
+    relaxVertex em m v = Map.foldrWithKey (relaxEdge v) m (em ! v)
+    relaxEdge v1 v2 e m = Map.insert v2 (((m ! v1) <.> e) <+> (m ! v2)) m
+
+{-
+-- REPL Testing
+x = toAcyclicOrd $ LAM.edges
+  [ (4::Distance Int, 0, 1)
+  , (8, 0, 7)
+  , (11, 1, 7)
+  , (8, 1, 2)
+  , (7, 7, 8)
+  , (1, 7, 16)
+  , (6, 8, 16)
+  , (2, 2, 8)
+  , (4, 2, 25)
+  , (2, 16, 25)
+  , (14, 3, 25)
+  , (9, 3, 40)
+  , (10, 25, 40)
+  , (7, 2, 3)]
+-}

test/Algebra/Graph/Test/Acyclic/Labelled/AdjacencyMap.hs

@@ -90,11 +90,11 @@ testAcyclicLabelledAdjacencyMap = do
 
   putStrLn $ "\n======= Acyclic.Labelled.AdjacencyMap.isSubgraphOf ======="
   test "isSubgraphOf empty      x                     == True" $ \x ->
-        isSubgraphOf (empty :: LAS)      x            == True
+        isSubgraphOf (empty :: LAD)      x            == True
   test "isSubgraphOf (vertex x) empty                 == False" $ \x ->
-        isSubgraphOf (vertex x) (empty :: LAS)        == False
-  test "isSubgraphOf x y                              == > x <= y" $ \x y ->
-        (not $ isSubgraphOf (x :: LAS) y) || (x <= y)
+        isSubgraphOf (vertex x) (empty :: LAD)        == False
+  test "isSubgraphOf x y                              == > x <= y" $ \(x :: LAD) (y :: LAD) ->
+        (not $ isSubgraphOf x y) || (x <= y)
 
   putStrLn $ "\n======= Acyclic.Labelled.AdjacencyMap.isEmpty ======="
   test "isEmpty empty                              == True" $
@@ -222,7 +222,7 @@ testAcyclicLabelledAdjacencyMap = do
   test "induce p . induce q                  == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) y ->
         (induce p . induce q) (y :: LAS)     == induce (\x -> p x && q x) y
   test "isSubgraphOf (induce p x) x          == True" $ \(apply -> p) x ->
-        isSubgraphOf (induce p x) (x :: LAS) == True
+        isSubgraphOf (induce p x) (x :: LAD) == True
 
   putStrLn $ "\n======= Acyclic.Labelled.AdjacencyMap.induceJust ======="
   test "induceJust (vertex Nothing)                == empty" $