Merge pull request #64 from ntc2/master

Make shortest-path functions safer.

Author: ivan-m

Data/Graph/Inductive/Internal/RootPath.hs

@@ -19,7 +19,9 @@ first p xss  = case filter p xss of
                  []   -> []
                  x:_  -> x
 
--- | Find the first path in a tree that starts with the given node
+-- | Find the first path in a tree that starts with the given node.
+--
+--   Returns an empty list if there is no such path.
 findP :: Node -> LRTree a -> [LNode a]
 findP _ []                                = []
 findP v (LP []:ps)                        = findP v ps
@@ -32,8 +34,13 @@ getPath v = reverse . first (\(w:_)->w==v)
 getLPath :: Node -> LRTree a -> LPath a
 getLPath v = LP . reverse . findP v
 
-getDistance :: Node -> LRTree a -> a
-getDistance v = snd . head . findP v
+-- | Return the distance to the given node in the given tree.
+--
+--   Returns 'Nothing' if the given node is not reachable.
+getDistance :: Node -> LRTree a -> Maybe a
+getDistance v t = case findP v t of
+  []      -> Nothing
+  (_,d):_ -> Just d
 
 getLPathNodes :: Node -> LRTree a -> Path
 getLPathNodes v = (\(LP p)->map fst p) . getLPath v

Data/Graph/Inductive/Query/SP.hs

@@ -19,6 +19,9 @@ expand :: (Real b) => b -> LPath b -> Context a b -> [H.Heap b (LPath b)]
 expand d (LP p) (_,_,_,s) = map (\(l,v)->H.unit (l+d) (LP ((v,l+d):p))) s
 
 -- | Dijkstra's shortest path algorithm.
+--
+--   The edge labels of type @b@ are the edge weights; negative edge
+--   weights are not supported.
 dijkstra :: (Graph gr, Real b)
     => H.Heap b (LPath b) -- ^ Initial heap of known paths and their lengths.
     -> gr a b
@@ -35,24 +38,41 @@ dijkstra h g =
 --
 --   Corresponds to 'dijkstra' applied to a heap in which the only known node is
 --   the starting node, with a path of length 0 leading to it.
+--
+--   The edge labels of type @b@ are the edge weights; negative edge
+--   weights are not supported.
 spTree :: (Graph gr, Real b)
     => Node
     -> gr a b
     -> LRTree b
 spTree v = dijkstra (H.unit 0 (LP [(v,0)]))
 
--- | Length of the shortest path between two nodes.
+-- | Length of the shortest path between two nodes, if any.
+--
+--   Returns 'Nothing' if there is no path, and @'Just' <path length>@
+--   otherwise.
+--
+--   The edge labels of type @b@ are the edge weights; negative edge
+--   weights are not supported.
 spLength :: (Graph gr, Real b)
     => Node -- ^ Start
     -> Node -- ^ Destination
     -> gr a b
-    -> b
+    -> Maybe b
 spLength s t = getDistance t . spTree s
 
--- | Shortest path between two nodes.
+-- | Shortest path between two nodes, if any.
+--
+--   Returns 'Nothing' if the destination is not reachable from teh
+--   start node, and @'Just' <path>@ otherwise.
+--
+--   The edge labels of type @b@ are the edge weights; negative edge
+--   weights are not supported.
 sp :: (Graph gr, Real b)
     => Node -- ^ Start
     -> Node -- ^ Destination
     -> gr a b
-    -> Path
-sp s t = getLPathNodes t . spTree s
+    -> Maybe Path
+sp s t g = case getLPathNodes t (spTree s g) of
+  [] -> Nothing
+  p  -> Just p

test/Data/Graph/Inductive/Query/Properties.hs

@@ -27,6 +27,7 @@ import Test.QuickCheck
 
 import           Control.Arrow (second)
 import           Data.List     (delete, sort, unfoldr, group, (\\))
+import           Data.Maybe    (fromJust, isJust, isNothing)
 import qualified Data.Set      as S
 
 #if __GLASGOW_HASKELL__ < 710
@@ -310,19 +311,48 @@ test_sp :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr () (Positive Int) ->
 test_sp _ cg = all test_p (map unLPath (msTree g))
   where
     -- Use Positive to avoid problems with distances containing
-    -- negative lengths.
+    -- negative lengths. The shortest path algorithm is Dijkstra's,
+    -- which doesn't support negative weights.
     g = emap getPositive (connGraph cg)
 
     gCon = emap (const 1) g `asTypeOf` g
 
-    test_p p = length p >= len_gCon                 -- Length-based test
+               -- Length-based test
+    test_p p = length p >= len_gCon
                && length (esp v w gCon) == len_gCon
-               && sum (map snd p) >= spLength v w g -- Weighting-based test
+               -- Weighting-based test
+               && sum (map snd p) >= fromJust (spLength v w g)
       where
         v = fst (head p)
         w = fst (last p)
 
-        len_gCon = length (sp v w gCon)
+        len_gCon = length (fromJust $ sp v w gCon)
+
+-- | Test that 'spLength' and 'sp' return a length and an connecting
+--   path when destination is reachable from source.
+test_sp_Just :: (ArbGraph gr, Graph gr, Real b) =>
+  Proxy (gr a b) -> gr a b -> Property
+test_sp_Just _ g =
+  (noNodes g >= 2 && v `elem` bfs u g) ==>
+  isJust (spLength u v g) &&
+  isJust maybePath &&
+  not (null path) &&
+  head path == u &&
+  last path == v
+  where
+    [u,v] = take 2 (nodes g)
+    maybePath@(Just path) = sp u v g
+
+-- | Test that 'spLength' and 'sp' return 'Nothing' when destination
+--   is not reachable from source.
+test_sp_Nothing :: (ArbGraph gr, Graph gr, Real b) =>
+  Proxy (gr a b) -> gr a b -> Property
+test_sp_Nothing _ g =
+  (noNodes g >= 2 && not (v `elem` bfs u g)) ==>
+  isNothing (spLength u v g) &&
+  isNothing (sp u v g)
+  where
+    [u,v] = take 2 (nodes g)
 
 -- -----------------------------------------------------------------------------
 -- TransClos

test/TestSuite.hs

@@ -116,7 +116,10 @@ queryTests = describe "Queries" $ do
   test_maxFlow2
   test_maxFlow
   propP "msTree"       test_msTree
-  propP "sp"           test_sp
+  describe "SP" $ do
+    propP "sp"         test_sp
+    propP "sp_Just"    test_sp_Just
+    propP "sp_Nothing" test_sp_Nothing
   keepSmall $ do
     -- Just producing the sample graph to compare against is O(|V|^2)
     propP "trc"        test_trc