Additional query functions; additional graph construction functions; switch to set of edges

bower.json

@@ -23,6 +23,7 @@
     "purescript-catenable-lists": "^5.0.0"
   },
   "devDependencies": {
-    "purescript-console": "^4.1.0"
+    "purescript-console": "^4.1.0",
+    "purescript-spec": "^3.1.0"
   }
 }

src/Data/Graph.purs

@@ -4,32 +4,79 @@ module Data.Graph
   ( Graph
   , unfoldGraph
   , fromMap
+  , toMap
+  , empty
+  , insertEdge
+  , insertVertex
+  , insertEdgeWithVertices
   , vertices
   , lookup
   , outEdges
+  , children
+  , descendants
+  , parents
+  , ancestors
   , topologicalSort
+  , isInCycle
+  , isCyclic
+  , isAcyclic
+  , alterVertex
+  , alterEdges
+  , adjacent
+  , isAdjacent
+  , areConnected
+  , shortestPath
+  , allPaths
   ) where
 
 import Prelude
-import Data.Bifunctor (lmap)
+
+import Data.Array as Array
+import Data.Bifunctor (lmap, rmap)
 import Data.CatList (CatList)
 import Data.CatList as CL
 import Data.Foldable (class Foldable)
+import Data.Foldable as Foldable
 import Data.List (List(..))
 import Data.List as L
+import Data.List as List
 import Data.Map (Map)
 import Data.Map as M
-import Data.Maybe (Maybe(..), maybe)
-import Data.Tuple (Tuple(..), fst, snd)
+import Data.Maybe (Maybe(..), isJust, maybe)
+import Data.Set (Set)
+import Data.Set as S
+import Data.Set as Set
+import Data.Tuple (Tuple(..), fst, snd, uncurry)
 
 -- | A graph with vertices of type `v`.
 -- |
 -- | Edges refer to vertices using keys of type `k`.
-newtype Graph k v = Graph (Map k (Tuple v (List k)))
+newtype Graph k v = Graph (Map k (Tuple v (Set k)))
 
 instance functorGraph :: Functor (Graph k) where
   map f (Graph m) = Graph (map (lmap f) m)
 
+-- | An empty graph.
+empty :: forall k v. Graph k v
+empty = Graph M.empty
+
+-- | Insert an edge from the start key to the end key.
+insertEdge :: forall k v. Ord k => k -> k -> Graph k v -> Graph k v
+insertEdge from to (Graph g) =
+  Graph $ M.alter (map (rmap (S.insert to))) from g
+
+-- | Insert a vertex into the graph.
+-- |
+-- | If the key already exists, replaces the existing value and
+-- |preserves existing edges.
+insertVertex :: forall k v. Ord k => k -> v -> Graph k v -> Graph k v
+insertVertex k v (Graph g) = Graph $ M.insertWith (\(Tuple _ ks) _ -> Tuple v ks) k (Tuple v mempty) g
+
+-- | Insert two vertices and connect them.
+insertEdgeWithVertices :: forall k v. Ord k => Tuple k v -> Tuple k v -> Graph k v -> Graph k v
+insertEdgeWithVertices from@(Tuple fromKey _) to@(Tuple toKey _) =
+  insertEdge fromKey toKey <<< uncurry insertVertex from <<< uncurry insertVertex to
+
 -- | Unfold a `Graph` from a collection of keys and functions which label keys
 -- | and specify out-edges.
 unfoldGraph
@@ -44,13 +91,54 @@ unfoldGraph
   -> Graph k v
 unfoldGraph ks label edges =
   Graph (M.fromFoldable (map (\k ->
-            Tuple k (Tuple (label k) (L.fromFoldable (edges k)))) ks))
+            Tuple k (Tuple (label k) (S.fromFoldable (edges k)))) ks))
 
 -- | Create a `Graph` from a `Map` which maps vertices to their labels and
 -- | outgoing edges.
-fromMap :: forall k v. Map k (Tuple v (List k)) -> Graph k v
+fromMap :: forall k v. Map k (Tuple v (Set k)) -> Graph k v
 fromMap = Graph
 
+-- | Turn a `Graph` into a `Map` which maps vertices to their labels and
+-- | outgoing edges.
+toMap :: forall k v. Graph k v -> Map k (Tuple v (Set k))
+toMap (Graph g) = g
+
+-- | Check if the first key is adjacent to the second.
+isAdjacent :: forall k v. Ord k => k -> k -> Graph k v -> Boolean
+isAdjacent k1 k2 g = k1 `Set.member` adjacent k2 g
+
+-- | Find all keys adjacent to given key.
+adjacent :: forall k v. Ord k => k -> Graph k v -> Set k
+adjacent k g = children k g `Set.union` parents k g
+
+-- | Returns shortest path between start and end key if it exists.
+-- |
+-- | Cyclic graphs may return bottom.
+shortestPath :: forall k v. Ord k => k -> k -> Graph k v -> Maybe (List k)
+shortestPath start end g =
+  Array.head <<< Array.sortWith List.length <<< S.toUnfoldable $ allPaths start end g
+
+-- | Returns shortest path between start and end key if it exists.
+-- |
+-- | Cyclic graphs may return bottom.
+allPaths :: forall k v. Ord k => k -> k -> Graph k v -> Set (List k)
+allPaths start end g = Set.map L.reverse $ go mempty start
+  where
+    go hist k =
+      if end == k
+      then Set.singleton hist'
+      else
+        if children' == Set.empty
+        then Set.empty
+        else Foldable.foldMap (go hist') children'
+      where
+        children' = children k g
+        hist' = k `Cons` hist
+
+-- | Checks if there's a directed path between the start and end key.
+areConnected :: forall k v. Ord k => k -> k -> Graph k v -> Boolean
+areConnected start end g = isJust $ shortestPath start end g
+
 -- | List all vertices in a graph.
 vertices :: forall k v. Graph k v -> List v
 vertices (Graph g) = map fst (M.values g)
@@ -60,18 +148,89 @@ lookup :: forall k v. Ord k => k -> Graph k v -> Maybe v
 lookup k (Graph g) = map fst (M.lookup k g)
 
 -- | Get the keys which are directly accessible from the given key.
-outEdges :: forall k v. Ord k => k -> Graph k v -> Maybe (List k)
+outEdges :: forall k v. Ord k => k -> Graph k v -> Maybe (Set k)
 outEdges k (Graph g) = map snd (M.lookup k g)
 
+-- | Returns immediate ancestors of given key.
+parents :: forall k v. Ord k => k -> Graph k v -> Set k
+parents k (Graph g) = M.keys <<< M.filter (Foldable.elem k <<< snd) $ g
+
+-- | Returns all ancestors of given key.
+-- |
+-- | Will return bottom if `k` is in cycle.
+ancestors :: forall k v. Ord k => k -> Graph k v -> Set k
+ancestors k' g = go k'
+  where
+   go k = Set.unions $ Set.insert da $ Set.map go da
+     where
+       da = parents k g
+
+-- | Returns immediate descendants of given key.
+children :: forall k v. Ord k => k -> Graph k v -> Set k
+children k (Graph g) = maybe mempty (Set.fromFoldable <<< snd) <<< M.lookup k $ g
+
+-- | Returns all descendants of given key.
+-- |
+-- | Will return bottom if `k` is in cycle.
+descendants :: forall k v. Ord k => k -> Graph k v -> Set k
+descendants k' g = go k'
+  where
+   go k = Set.unions $ Set.insert dd $ Set.map go dd
+     where
+       dd = children k g
+
+-- | Checks if given key is part of a cycle.
+isInCycle :: forall k v. Ord k => k -> Graph k v -> Boolean
+isInCycle k' g = go mempty k'
+  where
+    go seen k =
+      case Tuple (dd == mempty) (k `Set.member` seen) of
+        Tuple true _ -> false
+        Tuple _ true -> k == k'
+        Tuple false false -> Foldable.any (go (Set.insert k seen)) dd
+      where
+        dd = children k g
+
+-- | Checks if there any cycles in graph.
+-- There's presumably a faster implementation but this is very easy to implement
+isCyclic :: forall k v. Ord k => Graph k v -> Boolean
+isCyclic g = Foldable.any (flip isInCycle g) <<< keys $ g
+  where
+    keys (Graph g') = M.keys g'
+
+-- | Checks if there are not any cycles in the graph.
+isAcyclic :: forall k v. Ord k => Graph k v -> Boolean
+isAcyclic = not <<< isCyclic
+
+alterVertex ::
+  forall v k.
+  Ord k =>
+  (Maybe v -> Maybe v) ->
+  k -> Graph k v -> Graph k v
+alterVertex f k (Graph g) = Graph $ M.alter (applyF =<< _) k g
+  where
+    applyF (Tuple v es) = flip Tuple es <$> f (Just v)
+
+alterEdges ::
+  forall v k.
+  Ord k =>
+  (Maybe (Set k) -> Maybe (Set k)) ->
+  k -> Graph k v -> Graph k v
+alterEdges f k (Graph g) = Graph $ M.alter (applyF =<< _) k g
+  where
+    applyF (Tuple v es) = Tuple v <$> f (Just es)
+
 type SortState k v =
-  { unvisited :: Map k (Tuple v (List k))
+  { unvisited :: Map k (Tuple v (Set k))
   , result :: List k
   }
 
 -- To defunctionalize the `topologicalSort` function and make it tail-recursive,
 -- we introduce this data type which captures what we intend to do at each stage
 -- of the recursion.
 data SortStep a = Emit a | Visit a
+derive instance eqSortStep :: Eq a => Eq (SortStep a)
+derive instance ordSortStep :: Ord a => Ord (SortStep a)
 
 -- | Topologically sort the vertices of a graph.
 -- |
@@ -103,9 +262,9 @@ topologicalSort (Graph g) =
                   , unvisited: M.delete k state.unvisited
                   }
 
-                next :: List k
+                next :: Set k
                 next = maybe mempty snd (M.lookup k g)
-            in visit start (CL.fromFoldable (map Visit next) <> CL.cons (Emit k) ks)
+            in visit start (CL.fromFoldable (Set.map Visit next) <> CL.cons (Emit k) ks)
           | otherwise -> visit state ks
 
     initialState :: SortState k v

test/Main.purs

@@ -2,14 +2,131 @@ module Test.Main where
 
 import Prelude
 
-import Effect (Effect, foreachE)
-import Effect.Console (logShow)
-import Data.Graph (unfoldGraph, topologicalSort)
-import Data.List (toUnfoldable, range)
+import Data.Graph as Graph
+import Data.List as List
+import Data.Map as Map
+import Data.Set as Set
+import Data.Tuple (Tuple(..))
+import Effect (Effect)
+import Test.Spec (describe, it)
+import Test.Spec.Assertions (shouldEqual)
+import Test.Spec.Reporter.Console (consoleReporter)
+import Test.Spec.Runner (run)
 
 main :: Effect Unit
 main = do
-  let double x | x * 2 < 100000 = [x * 2]
-               | otherwise      = []
-      graph = unfoldGraph (range 1 100000) identity double
-  foreachE (toUnfoldable (topologicalSort graph)) logShow
+  run [consoleReporter] do
+    let n k v = Tuple k (Tuple k (Set.fromFoldable v ))
+        --       4 - 8
+        --      /     \
+        -- 1 - 2 - 3 - 5 - 7
+        --          \
+        --           6
+        acyclicGraph =
+          Graph.fromMap (
+            Map.fromFoldable
+              [ n 1 [ 2 ]
+              , n 2 [ 3, 4 ]
+              , n 3 [ 5, 6 ]
+              , n 4 [ 8 ]
+              , n 5 [ 7 ]
+              , n 6 [ ]
+              , n 7 [ ]
+              , n 8 [ 5 ]
+              ])
+        --       2 - 4
+        --      / \
+        -- 5 - 1 - 3
+        cyclicGraph =
+          Graph.fromMap (
+            Map.fromFoldable
+              [ n 1 [ 2 ]
+              , n 2 [ 3, 4 ]
+              , n 3 [ 1 ]
+              , n 4 [ ]
+              , n 5 [ 1 ]
+              ])
+    describe "topologicalSort" do
+      it "works for an example" do
+        Graph.topologicalSort acyclicGraph `shouldEqual` List.fromFoldable [ 1, 2, 4, 8, 3, 6, 5, 7 ]
+    describe "insertEdgeWithVertices" do
+      it "works for examples" do
+        let t x = Tuple x x
+            graph =
+              Graph.insertEdgeWithVertices (t 1) (t 2) $
+              Graph.insertEdgeWithVertices (t 2) (t 4) $
+              Graph.insertEdgeWithVertices (t 4) (t 8) $
+              Graph.insertEdgeWithVertices (t 8) (t 5) $
+              Graph.insertEdgeWithVertices (t 5) (t 7) $
+              Graph.insertEdgeWithVertices (t 2) (t 3) $
+              Graph.insertEdgeWithVertices (t 3) (t 5) $
+              Graph.insertEdgeWithVertices (t 3) (t 6) $
+              Graph.empty
+        Graph.toMap graph `shouldEqual` Graph.toMap acyclicGraph
+        let graph' =
+               Graph.insertEdgeWithVertices (t 5) (t 1) $
+               Graph.insertEdgeWithVertices (t 1) (t 2) $
+               Graph.insertEdgeWithVertices (t 2) (t 4) $
+               Graph.insertEdgeWithVertices (t 2) (t 3) $
+               Graph.insertEdgeWithVertices (t 3) (t 1) $
+               Graph.empty
+        Graph.toMap graph' `shouldEqual` Graph.toMap cyclicGraph
+    describe "descendants" do
+      it "works for examples" do
+        Graph.descendants 1 acyclicGraph `shouldEqual` Set.fromFoldable [ 2, 3, 4, 5, 6, 7, 8 ]
+        Graph.descendants 2 acyclicGraph `shouldEqual` Set.fromFoldable [ 3, 4, 5, 6, 7, 8 ]
+        Graph.descendants 3 acyclicGraph `shouldEqual` Set.fromFoldable [ 5, 6, 7 ]
+        Graph.descendants 4 acyclicGraph `shouldEqual` Set.fromFoldable [ 5, 7, 8 ]
+        Graph.descendants 5 acyclicGraph `shouldEqual` Set.fromFoldable [ 7 ]
+        Graph.descendants 6 acyclicGraph `shouldEqual` Set.fromFoldable [ ]
+        Graph.descendants 7 acyclicGraph `shouldEqual` Set.fromFoldable [ ]
+        Graph.descendants 8 acyclicGraph `shouldEqual` Set.fromFoldable [ 5, 7 ]
+    describe "ancestors" do
+      it "works for examples" do
+        Graph.ancestors 1 acyclicGraph `shouldEqual` Set.fromFoldable [ ]
+        Graph.ancestors 2 acyclicGraph `shouldEqual` Set.fromFoldable [ 1 ]
+        Graph.ancestors 3 acyclicGraph `shouldEqual` Set.fromFoldable [ 1, 2 ]
+        Graph.ancestors 4 acyclicGraph `shouldEqual` Set.fromFoldable [ 1, 2 ]
+        Graph.ancestors 5 acyclicGraph `shouldEqual` Set.fromFoldable [ 1, 2, 3, 4, 8 ]
+        Graph.ancestors 6 acyclicGraph `shouldEqual` Set.fromFoldable [ 1, 2, 3 ]
+        Graph.ancestors 7 acyclicGraph `shouldEqual` Set.fromFoldable [ 1, 2, 3, 4, 5, 8 ]
+        Graph.ancestors 8 acyclicGraph `shouldEqual` Set.fromFoldable [ 1, 2, 4 ]
+    describe "inCycle" do
+      it "works for examples" do
+        Graph.isInCycle 1 cyclicGraph `shouldEqual` true
+        Graph.isInCycle 2 cyclicGraph `shouldEqual` true
+        Graph.isInCycle 3 cyclicGraph `shouldEqual` true
+        Graph.isInCycle 4 cyclicGraph `shouldEqual` false
+        Graph.isInCycle 5 cyclicGraph `shouldEqual` false
+    describe "cyclic" do
+      it "works for examples" do
+        Graph.isCyclic cyclicGraph `shouldEqual` true
+        Graph.isCyclic acyclicGraph `shouldEqual` false
+        Graph.isAcyclic cyclicGraph `shouldEqual` false
+        Graph.isAcyclic acyclicGraph `shouldEqual` true
+    describe "adjacent" do
+      it "works for examples" do
+        Graph.adjacent 1 acyclicGraph `shouldEqual` Set.fromFoldable [ 2 ]
+        Graph.adjacent 2 acyclicGraph `shouldEqual` Set.fromFoldable [ 1, 3, 4 ]
+        Graph.adjacent 3 acyclicGraph `shouldEqual` Set.fromFoldable [ 2, 5, 6 ]
+        Graph.adjacent 4 acyclicGraph `shouldEqual` Set.fromFoldable [ 2, 8 ]
+        Graph.adjacent 5 acyclicGraph `shouldEqual` Set.fromFoldable [ 3, 7, 8 ]
+        Graph.adjacent 6 acyclicGraph `shouldEqual` Set.fromFoldable [ 3 ]
+        Graph.adjacent 7 acyclicGraph `shouldEqual` Set.fromFoldable [ 5 ]
+        Graph.adjacent 8 acyclicGraph `shouldEqual` Set.fromFoldable [ 4, 5 ]
+        Graph.adjacent 1 cyclicGraph `shouldEqual` Set.fromFoldable [ 2, 3, 5 ]
+        Graph.adjacent 2 cyclicGraph `shouldEqual` Set.fromFoldable [ 1, 3, 4 ]
+        Graph.adjacent 3 cyclicGraph `shouldEqual` Set.fromFoldable [ 1, 2 ]
+        Graph.adjacent 4 cyclicGraph `shouldEqual` Set.fromFoldable [ 2 ]
+        Graph.adjacent 5 cyclicGraph `shouldEqual` Set.fromFoldable [ 1 ]
+    describe "allPaths" do
+      it "works for examples" do
+        Graph.allPaths 2 1 acyclicGraph `shouldEqual` Set.empty
+        Graph.allPaths 1 9 acyclicGraph `shouldEqual` Set.empty
+        Graph.allPaths 1 1 acyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 1 ])
+        Graph.allPaths 1 2 acyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 1, 2 ])
+        Graph.allPaths 1 7 acyclicGraph `shouldEqual`
+          Set.fromFoldable [ List.fromFoldable [ 1, 2, 4, 8, 5, 7 ], List.fromFoldable [ 1, 2, 3, 5, 7 ] ]
+        Graph.allPaths 1 8 acyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 1, 2, 4, 8 ])
+        Graph.allPaths 2 6 acyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 2, 3, 6 ])
+        Graph.allPaths 5 3 cyclicGraph `shouldEqual` Set.singleton (List.fromFoldable [ 5, 1, 2, 3 ])