diff --git a/bower.json b/bower.json index b0be8df..ad2a0d7 100644 --- a/bower.json +++ b/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" } } diff --git a/src/Data/Graph.purs b/src/Data/Graph.purs index 0e79795..0d030ea 100644 --- a/src/Data/Graph.purs +++ b/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,11 +148,80 @@ 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 } @@ -72,6 +229,8 @@ type SortState k v = -- 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 diff --git a/test/Main.purs b/test/Main.purs index 16c9c16..9416037 100644 --- a/test/Main.purs +++ b/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 ])