diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,8 +1,31 @@ # Change log +## 0.2 + +* #117: Add `sparsify`. +* #115: Add `isDfsForestOf`. +* #114: Add a basic implementation of edge-labelled graphs. +* #107: Drop `starTranspose`. +* #106: Extend `ToGraph` with algorithms based on adjacency maps. +* #106: Add `isAcyclic` and `reachable`. +* #106: Rename `isTopSort` to `isTopSortOf`. +* #102: Switch the master branch to GHC 8.4.3. Add a CI instance for GHC 8.6.1. +* #101: Drop `-O2` from the `ghc-options` section of the Cabal file. +* #100: Rename `fromAdjacencyList` to `stars`. +* #79: Improve the API consistency: rename `IntAdjacencyMap` to `AdjacencyIntMap`, + and then rename the function that extracts its adjacency map to + `adjacencyIntMap` to avoid the clash with `AdjacencyMap.adjacencyMap`, + which has incompatible type. +* #82, #92: Add performance regression suite. +* #76: Remove benchmarks. +* #74: Drop dependency of `Algebra.Graph` on graph type classes. +* #62: Move King-Launchbury graphs into `Data.Graph.Typed`. +* #67, #68, #69, #77, #81, #93, #94, #97, #103, #110: Various performance improvements. +* #66, #72, #96, #98: Add missing `NFData` instances. + ## 0.1.1.1 -* #59: Allow base-compat-0.10. +* #59: Allow `base-compat-0.10`. ## 0.1.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,8 +3,11 @@ [![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Linux & OS X status](https://img.shields.io/travis/snowleopard/alga/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/snowleopard/alga) [![Windows status](https://img.shields.io/appveyor/ci/snowleopard/alga/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/alga) **Alga** is a library for algebraic construction and manipulation of graphs in Haskell. See -[this paper](https://github.com/snowleopard/alga-paper) for the motivation behind the library, the underlying -theory and implementation details. +[this Haskell Symposium paper](https://github.com/snowleopard/alga-paper) and the +corresponding [talk](https://www.youtube.com/watch?v=EdQGLewU-8k) for the motivation +behind the library, the underlying theory and implementation details. There is also a +[Haskell eXchange talk](https://skillsmatter.com/skillscasts/10635-algebraic-graphs), +and a [tutorial](https://nobrakal.github.io/alga-tutorial) by Alexandre Moine. ## Main idea @@ -57,7 +60,7 @@ enough for many applications. We believe there is a lot of potential for improving the performance of the library, and this is one of our top priorities. If you come across a performance issue when using the library, please let us know. -Some preliminary benchmarks can be found in [doc/benchmarks](https://github.com/snowleopard/alga/blob/master/doc/benchmarks.md). +Some preliminary benchmarks can be found [here](https://github.com/haskell-perf/graphs). ## Blog posts diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -1,10 +1,11 @@ name: algebraic-graphs -version: 0.1.1.1 +version: 0.2 synopsis: A library for algebraic graph construction and transformation license: MIT license-file: LICENSE author: Andrey Mokhov , github: @snowleopard -maintainer: Andrey Mokhov , github: @snowleopard +maintainer: Andrey Mokhov , github: @snowleopard, + Alexandre Moine , github: @nobrakal copyright: Andrey Mokhov, 2016-2018 homepage: https://github.com/snowleopard/alga category: Algebra, Algorithms, Data Structures, Graphs @@ -14,7 +15,8 @@ GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, - GHC==8.4.1 + GHC==8.4.3, + GHC==8.6.1 stability: experimental description: is a library for algebraic construction and @@ -64,9 +66,11 @@ Algebra.Graph.Export.Dot, Algebra.Graph.Fold, Algebra.Graph.HigherKinded.Class, - Algebra.Graph.IntAdjacencyMap, - Algebra.Graph.IntAdjacencyMap.Internal, + Algebra.Graph.AdjacencyIntMap, + Algebra.Graph.AdjacencyIntMap.Internal, Algebra.Graph.Internal, + Algebra.Graph.Label, + Algebra.Graph.Labelled, Algebra.Graph.NonEmpty, Algebra.Graph.Relation, Algebra.Graph.Relation.Internal, @@ -74,12 +78,15 @@ Algebra.Graph.Relation.Preorder, Algebra.Graph.Relation.Reflexive, Algebra.Graph.Relation.Symmetric, - Algebra.Graph.Relation.Transitive + Algebra.Graph.Relation.Transitive, + Algebra.Graph.ToGraph, + Data.Graph.Typed build-depends: array >= 0.4 && < 0.6, base >= 4.7 && < 5, base-compat >= 0.9.1 && < 0.11, containers >= 0.5.5.1 && < 0.8, - deepseq >= 1.3.0.1 && < 1.5 + deepseq >= 1.3.0.1 && < 1.5, + mtl >= 2.1 && < 2.3 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.3 && < 0.18.4 default-language: Haskell2010 @@ -114,22 +121,23 @@ Algebra.Graph.Test.Fold, Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, - Algebra.Graph.Test.IntAdjacencyMap, + Algebra.Graph.Test.AdjacencyIntMap, Algebra.Graph.Test.Internal, Algebra.Graph.Test.NonEmptyGraph, - Algebra.Graph.Test.Relation + Algebra.Graph.Test.Relation, + Data.Graph.Test.Typed build-depends: algebraic-graphs, + array >= 0.4 && < 0.6, base >= 4.7 && < 5, - base-compat >= 0.9.1 && < 0.10, - base-orphans >= 0.5.4 && < 0.8, + base-compat >= 0.9.1 && < 0.11, + base-orphans >= 0.5.4 && < 0.9, containers >= 0.5.5.1 && < 0.8, - extra >= 1.5, + extra >= 1.5 && < 2, QuickCheck >= 2.9 && < 2.12 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.3 && < 0.18.4 default-language: Haskell2010 - GHC-options: -O2 - -Wall + GHC-options: -Wall -fno-warn-name-shadowing if impl(ghc >= 8.0) GHC-options: -Wcompat @@ -144,25 +152,3 @@ ConstraintKinds RankNTypes ViewPatterns - -benchmark benchmark-alga - hs-source-dirs: bench - type: exitcode-stdio-1.0 - main-is: Bench.hs - build-depends: algebraic-graphs, - base >= 4.7 && < 5, - base-compat >= 0.9.1 && < 0.10, - containers >= 0.5.5.1 && < 0.8, - criterion >= 1.1 - default-language: Haskell2010 - GHC-options: -O2 - -Wall - -fno-warn-name-shadowing - if impl(ghc >= 8.0) - GHC-options: -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints - default-extensions: FlexibleContexts - TypeFamilies - ScopedTypeVariables diff --git a/bench/Bench.hs b/bench/Bench.hs deleted file mode 100644 --- a/bench/Bench.hs +++ /dev/null @@ -1,200 +0,0 @@ -import Prelude () -import Prelude.Compat - -import Criterion.Main -import Data.Char -import Data.Foldable (toList) - -import Algebra.Graph.Class -import Algebra.Graph.AdjacencyMap (AdjacencyMap, adjacencyMap) -import Algebra.Graph.Fold (Fold, box, deBruijn, gmap, vertexIntSet, vertexSet) -import Algebra.Graph.IntAdjacencyMap (IntAdjacencyMap) -import Algebra.Graph.Relation (Relation, relation) - -import qualified Algebra.Graph.IntAdjacencyMap as Int -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set - -v :: Ord a => Fold a -> Int -v = Set.size . vertexSet - -l :: Fold a -> Int -l = length . toList - -e :: AdjacencyMap a -> Int -e = foldr (\s t -> Set.size s + t) 0 . adjacencyMap - -r :: Relation a -> Int -r = Set.size . relation - -vInt :: Fold Int -> Int -vInt = IntSet.size . vertexIntSet - -eInt :: IntAdjacencyMap -> Int -eInt = foldr (\s t -> IntSet.size s + t) 0 . Int.adjacencyMap - -vDeBruijn :: Int -> Int -vDeBruijn n = v $ deBruijn n "0123456789" - -lDeBruijn :: Int -> Int -lDeBruijn n = l $ deBruijn n "0123456789" - -eDeBruijn :: Int -> Int -eDeBruijn n = e $ deBruijn n "0123456789" - -rDeBruijn :: Int -> Int -rDeBruijn n = r $ deBruijn n "0123456789" - -vIntDeBruijn :: Int -> Int -vIntDeBruijn n = v $ gmap fastRead $ deBruijn n "0123456789" - -eIntDeBruin :: Int -> Int -eIntDeBruin n = e $ gmap fastRead $ deBruijn n "0123456789" - --- fastRead is ~3000x faster than read -fastRead :: String -> Int -fastRead = foldr (\c t -> t + ord c - ord '0') 0 - -fastReadInts :: Int -> Int -fastReadInts n = foldr (+) 0 $ map fastRead $ ints ++ ints - where - ints = mapM (const "0123456789") [1..n] - -vMesh :: Int -> Int -vMesh n = v $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n] - -lMesh :: Int -> Int -lMesh n = l $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n] - -eMesh :: Int -> Int -eMesh n = e $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n] - -rMesh :: Int -> Int -rMesh n = r $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n] - -vIntMesh :: Int -> Int -vIntMesh n = vInt $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n] - -eIntMesh :: Int -> Int -eIntMesh n = eInt $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n] - -vIntClique :: Int -> Int -vIntClique n = vInt $ clique [1..n] - -eIntClique :: Int -> Int -eIntClique n = eInt $ clique [1..n] - -lClique :: Int -> Int -lClique n = l $ clique [1..n] - -rClique :: Int -> Int -rClique n = r $ clique [1..n] - -main :: IO () -main = defaultMain - [ bgroup "vDeBruijn" - [ bench "10^1" $ whnf vDeBruijn 1 - , bench "10^2" $ whnf vDeBruijn 2 - , bench "10^3" $ whnf vDeBruijn 3 - , bench "10^4" $ whnf vDeBruijn 4 - , bench "10^5" $ whnf vDeBruijn 5 - , bench "10^6" $ whnf vDeBruijn 6 ] - , bgroup "lDeBruijn" - [ bench "10^1" $ whnf lDeBruijn 1 - , bench "10^2" $ whnf lDeBruijn 2 - , bench "10^3" $ whnf lDeBruijn 3 - , bench "10^4" $ whnf lDeBruijn 4 - , bench "10^5" $ whnf lDeBruijn 5 - , bench "10^6" $ whnf lDeBruijn 6 ] - , bgroup "eDeBruijn" - [ bench "10^1" $ whnf eDeBruijn 1 - , bench "10^2" $ whnf eDeBruijn 2 - , bench "10^3" $ whnf eDeBruijn 3 - , bench "10^4" $ whnf eDeBruijn 4 - , bench "10^5" $ whnf eDeBruijn 5 - , bench "10^6" $ whnf eDeBruijn 6 ] - , bgroup "rDeBruijn" - [ bench "10^1" $ whnf rDeBruijn 1 - , bench "10^2" $ whnf rDeBruijn 2 - , bench "10^3" $ whnf rDeBruijn 3 - , bench "10^4" $ whnf rDeBruijn 4 - , bench "10^5" $ whnf rDeBruijn 5 - , bench "10^6" $ whnf rDeBruijn 6 ] - , bgroup "vIntDeBruijn" - [ bench "10^1" $ whnf vIntDeBruijn 1 - , bench "10^2" $ whnf vIntDeBruijn 2 - , bench "10^3" $ whnf vIntDeBruijn 3 - , bench "10^4" $ whnf vIntDeBruijn 4 - , bench "10^5" $ whnf vIntDeBruijn 5 - , bench "10^6" $ whnf vIntDeBruijn 6 ] - , bgroup "eIntDeBruin" - [ bench "10^1" $ whnf eIntDeBruin 1 - , bench "10^2" $ whnf eIntDeBruin 2 - , bench "10^3" $ whnf eIntDeBruin 3 - , bench "10^4" $ whnf eIntDeBruin 4 - , bench "10^5" $ whnf eIntDeBruin 5 - , bench "10^6" $ whnf eIntDeBruin 6 ] - , bgroup "fastReadInts" - [ bench "10^1" $ whnf fastReadInts 1 - , bench "10^2" $ whnf fastReadInts 2 - , bench "10^3" $ whnf fastReadInts 3 - , bench "10^4" $ whnf fastReadInts 4 - , bench "10^5" $ whnf fastReadInts 5 - , bench "10^6" $ whnf fastReadInts 6 ] - , bgroup "vMesh" - [ bench "1x1" $ whnf vMesh 1 - , bench "10x10" $ whnf vMesh 10 - , bench "100x100" $ whnf vMesh 100 - , bench "1000x1000" $ whnf vMesh 1000 ] - , bgroup "lMesh" - [ bench "1x1" $ whnf lMesh 1 - , bench "10x10" $ whnf lMesh 10 - , bench "100x100" $ whnf lMesh 100 - , bench "1000x1000" $ whnf lMesh 1000 ] - , bgroup "eMesh" - [ bench "1x1" $ whnf eMesh 1 - , bench "10x10" $ whnf eMesh 10 - , bench "100x100" $ whnf eMesh 100 - , bench "1000x1000" $ whnf eMesh 1000 ] - , bgroup "rMesh" - [ bench "1x1" $ whnf rMesh 1 - , bench "10x10" $ whnf rMesh 10 - , bench "100x100" $ whnf rMesh 100 - , bench "1000x1000" $ whnf rMesh 1000 ] - , bgroup "vIntMesh" - [ bench "1x1" $ whnf vIntMesh 1 - , bench "10x10" $ whnf vIntMesh 10 - , bench "100x100" $ whnf vIntMesh 100 - , bench "1000x1000" $ whnf vIntMesh 1000 ] - , bgroup "eIntMesh" - [ bench "1x1" $ whnf eIntMesh 1 - , bench "10x10" $ whnf eIntMesh 10 - , bench "100x100" $ whnf eIntMesh 100 - , bench "1000x1000" $ whnf eIntMesh 1000 ] - , bgroup "rClique" - [ bench "1" $ nf rClique 1 - , bench "10" $ nf rClique 10 - , bench "100" $ nf rClique 100 - , bench "1000" $ nf rClique 1000 - , bench "10000" $ nf rClique 10000 ] - , bgroup "vIntClique" - [ bench "1" $ nf vIntClique 1 - , bench "10" $ nf vIntClique 10 - , bench "100" $ nf vIntClique 100 - , bench "1000" $ nf vIntClique 1000 - , bench "10000" $ nf vIntClique 10000 - , bench "44722" $ nf vIntClique 44722 ] - , bgroup "lClique" - [ bench "1" $ nf lClique 1 - , bench "10" $ nf lClique 10 - , bench "100" $ nf lClique 100 - , bench "1000" $ nf lClique 1000 - , bench "10000" $ nf lClique 10000 - , bench "44722" $ nf lClique 44722 ] - , bgroup "eIntClique" - [ bench "1" $ nf eIntClique 1 - , bench "10" $ nf eIntClique 10 - , bench "100" $ nf eIntClique 100 - , bench "1000" $ nf eIntClique 1000 - , bench "10000" $ nf eIntClique 10000 - , bench "44722" $ nf eIntClique 44722 ] ] diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -33,37 +33,49 @@ -- * Graph properties isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, vertexIntSet, edgeSet, + edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList, adjacencyMap, + adjacencyIntMap, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest, mesh, - torus, deBruijn, + path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus, + deBruijn, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex, - transpose, induce, simplify, + transpose, induce, simplify, sparsify, -- * Graph composition - box + box, + + -- * Context + Context (..), context ) where import Prelude () import Prelude.Compat -import Control.Applicative (Alternative, (<|>)) +import Control.Applicative (Alternative) import Control.DeepSeq (NFData (..)) import Control.Monad.Compat +import Control.Monad.State (runState, get, put) +import Data.Foldable (toList) +import Data.Maybe (fromMaybe) +import Data.Tree import Algebra.Graph.Internal -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.HigherKinded.Class as H -import qualified Algebra.Graph.Relation as R -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set -import qualified Data.Tree as Tree +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Map (Map) +import Data.Set (Set) +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Control.Applicative as Ap +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import qualified Data.Tree as Tree + {-| The 'Graph' data type is a deep embedding of the core graph construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a 'Num' instance as a convenient notation for working with graphs: @@ -151,28 +163,6 @@ rnf (Overlay x y) = rnf x `seq` rnf y rnf (Connect x y) = rnf x `seq` rnf y -instance C.Graph (Graph a) where - type Vertex (Graph a) = a - empty = empty - vertex = vertex - overlay = overlay - connect = connect - -instance C.ToGraph (Graph a) where - type ToVertex (Graph a) = a - foldg e v o c = go - where - go Empty = e - go (Vertex x ) = v x - go (Overlay x y) = o (go x) (go y) - go (Connect x y) = c (go x) (go y) - -instance H.ToGraph Graph where - toGraph = foldg H.empty H.vertex H.overlay H.connect - -instance H.Graph Graph where - connect = connect - instance Num a => Num (Graph a) where fromInteger = Vertex . fromInteger (+) = Overlay @@ -182,8 +172,19 @@ negate = id instance Ord a => Eq (Graph a) where - x == y = C.toGraph x == (C.toGraph y :: AM.AdjacencyMap a) + (==) = equals +-- TODO: Find a more efficient equality check. +-- | Compare two graphs by converting them to their adjacency maps. +{-# NOINLINE [1] equals #-} +{-# RULES "equalsInt" equals = equalsInt #-} +equals :: Ord a => Graph a -> Graph a -> Bool +equals x y = adjacencyMap x == adjacencyMap y + +-- | Like @equals@ but specialised for graphs with vertices of type 'Int'. +equalsInt :: Graph Int -> Graph Int -> Bool +equalsInt x y = adjacencyIntMap x == adjacencyIntMap y + instance Applicative Graph where pure = Vertex (<*>) = ap @@ -212,6 +213,7 @@ -- @ empty :: Graph a empty = Empty +{-# INLINE empty #-} -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. @@ -226,6 +228,7 @@ -- @ vertex :: a -> Graph a vertex = Vertex +{-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory and size. @@ -238,7 +241,7 @@ -- 'vertexCount' (edge 1 2) == 2 -- @ edge :: a -> a -> Graph a -edge = H.edge +edge x y = connect (vertex x) (vertex y) -- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a -- commutative, associative and idempotent operation with the identity 'empty'. @@ -257,6 +260,7 @@ -- @ overlay :: Graph a -> Graph a -> Graph a overlay = Overlay +{-# INLINE overlay #-} -- | /Connect/ two graphs. An alias for the constructor 'Connect'. This is an -- associative operation with the identity 'empty', which distributes over @@ -280,6 +284,7 @@ -- @ connect :: Graph a -> Graph a -> Graph a connect = Connect +{-# INLINE connect #-} -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -293,7 +298,8 @@ -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: [a] -> Graph a -vertices = H.vertices +vertices = overlays . map vertex +{-# NOINLINE [1] vertices #-} -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -305,7 +311,7 @@ -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: [(a, a)] -> Graph a -edges = H.edges +edges = overlays . map (uncurry edge) -- | Overlay a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -319,7 +325,8 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [Graph a] -> Graph a -overlays = H.overlays +overlays = concatg overlay +{-# INLINE [2] overlays #-} -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -333,8 +340,13 @@ -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: [Graph a] -> Graph a -connects = H.connects +connects = concatg connect +{-# INLINE [2] connects #-} +-- | Auxiliary function, similar to 'mconcat'. +concatg :: (Graph a -> Graph a -> Graph a) -> [Graph a] -> Graph a +concatg combine = fromMaybe empty . foldr1Safe combine + -- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying -- the provided functions to the leaves and internal nodes of the expression. -- The order of arguments is: empty, vertex, overlay and connect. @@ -350,7 +362,12 @@ -- foldg True (const False) (&&) (&&) == 'isEmpty' -- @ foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b -foldg = C.foldg +foldg e v o c = go + where + go Empty = e + go (Vertex x ) = v x + go (Overlay x y) = o (go x) (go y) + go (Connect x y) = c (go x) (go y) -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. @@ -364,8 +381,9 @@ -- isSubgraphOf ('overlay' x y) ('connect' x y) == True -- isSubgraphOf ('path' xs) ('circuit' xs) == True -- @ +{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool -isSubgraphOf = H.isSubgraphOf +isSubgraphOf x y = overlay x y == y -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time. @@ -377,6 +395,7 @@ -- 1 + 2 === 2 + 1 == False -- x + y === x * y == False -- @ +{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} (===) :: Eq a => Graph a -> Graph a -> Bool Empty === Empty = True (Vertex x1 ) === (Vertex x2 ) = x1 == x2 @@ -397,7 +416,7 @@ -- isEmpty ('removeEdge' x y $ 'edge' x y) == False -- @ isEmpty :: Graph a -> Bool -isEmpty = H.isEmpty +isEmpty = foldg True (const False) (&&) (&&) -- | The /size/ of a graph, i.e. the number of leaves of the expression -- including 'empty' leaves. @@ -423,8 +442,9 @@ -- hasVertex 1 ('vertex' 2) == False -- hasVertex x . 'removeVertex' x == const False -- @ +{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} hasVertex :: Eq a => a -> Graph a -> Bool -hasVertex = H.hasVertex +hasVertex x = foldg False (==x) (||) (||) -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. @@ -436,8 +456,20 @@ -- hasEdge x y . 'removeEdge' x y == const False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -hasEdge :: Ord a => a -> a -> Graph a -> Bool -hasEdge = H.hasEdge +{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} +hasEdge :: Eq a => a -> a -> Graph a -> Bool +hasEdge s t g = hit g == Edge + where + hit Empty = Miss + hit (Vertex x ) = if x == s then Tail else Miss + hit (Overlay x y) = case hit x of + Miss -> hit y + Tail -> max Tail (hit y) + Edge -> Edge + hit (Connect x y) = case hit x of + Miss -> hit y + Tail -> if hasVertex t y then Edge else Tail + Edge -> Edge -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. @@ -447,9 +479,15 @@ -- vertexCount ('vertex' x) == 1 -- vertexCount == 'length' . 'vertexList' -- @ +{-# INLINE [1] vertexCount #-} +{-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} vertexCount :: Ord a => Graph a -> Int -vertexCount = length . vertexList +vertexCount = Set.size . vertexSet +-- | Like 'vertexCount' but specialised for graphs with vertices of type 'Int'. +vertexIntCount :: Graph Int -> Int +vertexIntCount = IntSet.size . vertexIntSet + -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a -- graph can be quadratic with respect to the expression size /s/. @@ -460,9 +498,15 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ +{-# INLINE [1] edgeCount #-} +{-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-} edgeCount :: Ord a => Graph a -> Int -edgeCount = length . edgeList +edgeCount = AM.edgeCount . toAdjacencyMap +-- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. +edgeCountInt :: Graph Int -> Int +edgeCountInt = AIM.edgeCount . toAdjacencyIntMap + -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- @@ -471,9 +515,15 @@ -- vertexList ('vertex' x) == [x] -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ +{-# INLINE [1] vertexList #-} +{-# RULES "vertexList/Int" vertexList = vertexIntList #-} vertexList :: Ord a => Graph a -> [a] vertexList = Set.toAscList . vertexSet +-- | Like 'vertexList' but specialised for graphs with vertices of type 'Int'. +vertexIntList :: Graph Int -> [Int] +vertexIntList = IntSet.toList . vertexIntSet + -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of -- edges /m/ of a graph can be quadratic with respect to the expression size /s/. @@ -486,9 +536,15 @@ -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' -- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList -- @ +{-# INLINE [1] edgeList #-} +{-# RULES "edgeList/Int" edgeList = edgeIntList #-} edgeList :: Ord a => Graph a -> [(a, a)] -edgeList = AM.edgeList . C.toGraph +edgeList = AM.edgeList . toAdjacencyMap +-- | Like 'edgeList' but specialised for graphs with vertices of type 'Int'. +edgeIntList :: Graph Int -> [(Int, Int)] +edgeIntList = AIM.edgeList . toAdjacencyIntMap + -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- @@ -499,7 +555,7 @@ -- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Ord a => Graph a -> Set.Set a -vertexSet = H.vertexSet +vertexSet = foldg Set.empty Set.singleton Set.union Set.union -- | The set of vertices of a given graph. Like 'vertexSet' but specialised for -- graphs with vertices of type 'Int'. @@ -512,7 +568,7 @@ -- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' -- @ vertexIntSet :: Graph Int -> IntSet.IntSet -vertexIntSet = H.vertexIntSet +vertexIntSet = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. @@ -524,8 +580,50 @@ -- edgeSet . 'edges' == Set.'Set.fromList' -- @ edgeSet :: Ord a => Graph a -> Set.Set (a, a) -edgeSet = R.edgeSet . C.toGraph +edgeSet = AM.edgeSet . toAdjacencyMap +{-# INLINE [1] edgeSet #-} +{-# RULES "edgeSet/Int" edgeSet = edgeIntSet #-} +-- | Like 'edgeSet' but specialised for graphs with vertices of type 'Int'. +edgeIntSet :: Graph Int -> Set.Set (Int,Int) +edgeIntSet = AIM.edgeSet . toAdjacencyIntMap + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] +-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] +-- 'stars' . adjacencyList == id +-- @ +{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} +adjacencyList :: Ord a => Graph a -> [(a, [a])] +adjacencyList = AM.adjacencyList . toAdjacencyMap + +-- | The /adjacency map/ of a graph: each vertex is associated with a set of its +-- direct successors. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +adjacencyMap :: Ord a => Graph a -> Map a (Set a) +adjacencyMap = AM.adjacencyMap . toAdjacencyMap + +-- TODO: This is a very inefficient implementation. Find a way to construct an +-- adjacency map directly, without building intermediate representations for all +-- subgraphs. +-- | Convert a graph to 'AM.AdjacencyMap'. +toAdjacencyMap :: Ord a => Graph a -> AM.AdjacencyMap a +toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect + +-- | Like 'adjacencyMap' but specialised for graphs with vertices of type 'Int'. +adjacencyIntMap :: Graph Int -> IntMap IntSet +adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap + +-- | Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'. +toAdjacencyIntMap :: Graph Int -> AIM.AdjacencyIntMap +toAdjacencyIntMap = foldg AIM.empty AIM.vertex AIM.overlay AIM.connect + -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. @@ -537,7 +635,9 @@ -- path . 'reverse' == 'transpose' . path -- @ path :: [a] -> Graph a -path = H.path +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) -- | The /circuit/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -550,7 +650,8 @@ -- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: [a] -> Graph a -circuit = H.circuit +circuit [] = empty +circuit (x:xs) = path $ [x] ++ xs ++ [x] -- | The /clique/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -565,7 +666,8 @@ -- clique . 'reverse' == 'transpose' . clique -- @ clique :: [a] -> Graph a -clique = H.clique +clique = connects . map vertex +{-# NOINLINE [1] clique #-} -- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -579,7 +681,9 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [a] -> [a] -> Graph a -biclique = H.biclique +biclique xs [] = vertices xs +biclique [] ys = vertices ys +biclique xs ys = connect (vertices xs) (vertices ys) -- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -592,21 +696,27 @@ -- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: a -> [a] -> Graph a -star = H.star +star x [] = vertex x +star x ys = connect (vertex x) (vertices ys) +{-# INLINE star #-} --- | The /star transpose/ formed by a list of leaves connected to a centre vertex. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the +-- input. -- -- @ --- starTranspose x [] == 'vertex' x --- starTranspose x [y] == 'edge' y x --- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] --- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) --- starTranspose x ys == 'transpose' ('star' x ys) +-- stars [] == 'empty' +-- stars [(x, [])] == 'vertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . map (uncurry 'star') +-- stars . 'adjacencyList' == id +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ -starTranspose :: a -> [a] -> Graph a -starTranspose = H.starTranspose +stars :: [(a, [a])] -> Graph a +stars = overlays . map (uncurry star) +{-# INLINE stars #-} -- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the @@ -619,7 +729,9 @@ -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] -- @ tree :: Tree.Tree a -> Graph a -tree = H.tree +tree (Node x []) = vertex x +tree (Node x f ) = star x (map rootLabel f) + `overlay` forest (filter (not . null . subForest) f) -- | The /forest graph/ constructed from a given 'Tree.Forest' data structure. -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the @@ -632,7 +744,7 @@ -- forest == 'overlays' . map 'tree' -- @ forest :: Tree.Forest a -> Graph a -forest = H.forest +forest = overlays . map tree -- | Construct a /mesh graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -647,7 +759,17 @@ -- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ] -- @ mesh :: [a] -> [b] -> Graph (a, b) -mesh = H.mesh +mesh [] _ = empty +mesh _ [] = empty +mesh [x] [y] = vertex (x, y) +mesh xs ys = stars $ [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ipxs, (b1, b2) <- ipys ] + ++ [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] + ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] + where + lx = last xs + ly = last ys + ipxs = init (pairs xs) + ipys = init (pairs ys) -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -656,14 +778,19 @@ -- @ -- torus xs [] == 'empty' -- torus [] ys == 'empty' --- torus [x] [y] == 'edge' (x, y) (x, y) +-- torus [x] [y] == 'edge' (x,y) (x,y) -- torus xs ys == 'box' ('circuit' xs) ('circuit' ys) -- torus [1,2] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\')) -- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ torus :: [a] -> [b] -> Graph (a, b) -torus = H.torus +torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] +-- | Auxiliary function for 'mesh' and 'torus' +pairs :: [a] -> [(a, a)] +pairs [] = [] +pairs as@(x:xs) = zip as (xs ++ [x]) + -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols -- from a given alphabet. -- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the @@ -681,7 +808,12 @@ -- n > 0 ==> 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) -- @ deBruijn :: Int -> [a] -> Graph [a] -deBruijn = H.deBruijn +deBruijn 0 _ = edge [] [] +deBruijn len alphabet = skeleton >>= expand + where + overlaps = mapM (const alphabet) [2..len] + skeleton = edges [ (Left s, Right s) | s <- overlaps ] + expand v = vertices [ either ([a] ++) (++ [a]) v | a <- alphabet ] -- | Remove a vertex from a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -693,31 +825,34 @@ -- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ +{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} removeVertex :: Eq a => a -> Graph a -> Graph a -removeVertex = H.removeVertex +removeVertex v = induce (/= v) -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size. -- -- @ --- removeEdge x y ('edge' x y) == 'vertices' [x, y] +-- removeEdge x y ('edge' x y) == 'vertices' [x,y] -- removeEdge x y . removeEdge x y == removeEdge x y -- removeEdge x y . 'removeVertex' x == 'removeVertex' x -- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} removeEdge :: Eq a => a -> a -> Graph a -> Graph a removeEdge s t = filterContext s (/=s) (/=t) + -- TODO: Export -- | Filter vertices in a subgraph context. +{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Graph a -> Graph a filterContext s i o g = maybe g go $ context (==s) g where - go (Context is os) = overlays [ induce (/=s) g - , starTranspose s (filter i is) - , star s (filter o os) ] + go (Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is)) + `overlay` star s (filter o os) -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. @@ -728,9 +863,11 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y == 'mergeVertices' (== x) y -- @ +{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} replaceVertex :: Eq a => a -> a -> Graph a -> Graph a -replaceVertex = H.replaceVertex +replaceVertex u v = fmap $ \w -> if w == u then v else w + -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes -- /O(1)/ to be evaluated. @@ -742,7 +879,7 @@ -- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a -mergeVertices = H.mergeVertices +mergeVertices p v = fmap $ \w -> if p w then v else w -- | Split a vertex into a list of vertices with the same connectivity. -- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of @@ -755,8 +892,9 @@ -- splitVertex x [y] == 'replaceVertex' x y -- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @ +{-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-} splitVertex :: Eq a => a -> [a] -> Graph a -> Graph a -splitVertex = H.splitVertex +splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -771,7 +909,21 @@ -- @ transpose :: Graph a -> Graph a transpose = foldg Empty Vertex Overlay (flip Connect) +{-# NOINLINE [1] transpose #-} +{-# RULES +"transpose/Empty" transpose Empty = Empty +"transpose/Vertex" forall x. transpose (Vertex x) = Vertex x +"transpose/Overlay" forall g1 g2. transpose (Overlay g1 g2) = Overlay (transpose g1) (transpose g2) +"transpose/Connect" forall g1 g2. transpose (Connect g1 g2) = Connect (transpose g2) (transpose g1) + +"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs) +"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs)) + +"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs +"transpose/clique" forall xs. transpose (clique xs) = clique (reverse xs) + #-} + -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes @@ -807,9 +959,11 @@ -- simplify (1 + 2 + 1) '===' 1 + 2 -- simplify (1 * 1 * 1) '===' 1 * 1 -- @ +{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} simplify :: Ord a => Graph a -> Graph a simplify = foldg Empty Vertex (simple Overlay) (simple Connect) +{-# SPECIALISE simple :: (Int -> Int -> Int) -> Int -> Int -> Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y | x == z = x @@ -844,4 +998,50 @@ -- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ box :: Graph a -> Graph b -> Graph (a, b) -box = H.box +box x y = overlays $ xs ++ ys + where + xs = map (\b -> fmap (,b) x) $ toList y + ys = map (\a -> fmap (a,) y) $ toList x + +-- | 'Focus' on a specified subgraph. +focus :: (a -> Bool) -> Graph a -> Focus a +focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci + +-- | The context of a subgraph comprises the input and output vertices outside +-- the subgraph that are connected to the vertices inside the subgraph. +data Context a = Context { inputs :: [a], outputs :: [a] } + +-- | Extract the context from a graph 'Focus'. Returns @Nothing@ if the focus +-- could not be obtained. +context :: (a -> Bool) -> Graph a -> Maybe (Context a) +context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) + | otherwise = Nothing + where + f = focus p g + +-- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the +-- original vertices (wrapping the latter in 'Right') such that the resulting +-- graph is /sparse/, i.e. contains only O(s) edges, but preserves the +-- reachability relation between the original vertices. Sparsification is useful +-- when working with dense graphs, as it can reduce the number of edges from +-- O(n^2) down to O(n) by replacing cliques, bicliques and similar densely +-- connected structures by sparse subgraphs built out of intermediate vertices. +-- Complexity: O(s) time, memory and size. +-- +-- @ +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' ('Data.Either.Right' x) . sparsify +-- 'vertexCount' (sparsify x) <= 'vertexCount' x + 'size' x + 1 +-- 'edgeCount' (sparsify x) <= 3 * 'size' x +-- 'size' (sparsify x) <= 3 * 'size' x +-- @ +sparsify :: Graph a -> Graph (Either Int a) +sparsify graph = res + where + (res, end) = runState (foldg e v o c graph 0 end) 1 + e s t = return $ path [Left s, Left t] + v x s t = return $ clique [Left s, Right x, Left t] + o x y s t = overlay <$> s `x` t <*> s `y` t + c x y s t = do + m <- get + put (m + 1) + overlay <$> s `x` m <*> m `y` t diff --git a/src/Algebra/Graph/AdjacencyIntMap.hs b/src/Algebra/Graph/AdjacencyIntMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyIntMap.hs @@ -0,0 +1,692 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.AdjacencyIntMap +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines the 'AdjacencyIntMap' data type, as well as associated +-- operations and algorithms. 'AdjacencyIntMap' is an instance of the 'C.Graph' +-- type class, which can be used for polymorphic graph construction +-- and manipulation. See "Algebra.Graph.AdjacencyMap" for graphs with +-- non-@Int@ vertices. +----------------------------------------------------------------------------- +module Algebra.Graph.AdjacencyIntMap ( + -- * Data structure + AdjacencyIntMap, adjacencyIntMap, + + -- * Basic graph construction primitives + empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, + + -- * Relations on graphs + isSubgraphOf, + + -- * Graph properties + isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, + adjacencyList, vertexIntSet, edgeSet, preIntSet, postIntSet, + + -- * Standard families of graphs + path, circuit, clique, biclique, star, stars, tree, forest, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, + induce, + + -- * Algorithms + dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, + + -- * Correctness properties + isDfsForestOf, isTopSortOf + ) where + +import Control.Monad +import Data.Foldable (foldMap) +import Data.IntSet (IntSet) +import Data.Maybe +import Data.Monoid +import Data.Set (Set) +import Data.Tree + +import Algebra.Graph.AdjacencyIntMap.Internal + +import qualified Data.Graph.Typed as Typed +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set + +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time, memory. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- 'hasEdge' x y (edge x y) == True +-- 'edgeCount' (edge x y) == 1 +-- 'vertexCount' (edge 1 1) == 1 +-- 'vertexCount' (edge 1 2) == 2 +-- @ +edge :: Int -> Int -> AdjacencyIntMap +edge x y | x == y = AM $ IntMap.singleton x (IntSet.singleton y) + | otherwise = AM $ IntMap.fromList [(x, IntSet.singleton y), (y, IntSet.empty)] + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexIntSet' . vertices == IntSet.'IntSet.fromList' +-- @ +vertices :: [Int] -> AdjacencyIntMap +vertices = AM . IntMap.fromList . map (\x -> (x, IntSet.empty)) +{-# NOINLINE [1] vertices #-} + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(x,y)] == 'edge' x y +-- 'edgeCount' . edges == 'length' . 'Data.List.nub' +-- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' +-- @ +edges :: [(Int, Int)] -> AdjacencyIntMap +edges = fromAdjacencyIntSets . map (fmap IntSet.singleton) + +-- | Overlay a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: [AdjacencyIntMap] -> AdjacencyIntMap +overlays = AM . IntMap.unionsWith IntSet.union . map adjacencyIntMap +{-# NOINLINE [1] overlays #-} + +-- | Connect a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- connects [] == 'empty' +-- connects [x] == x +-- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' +-- 'isEmpty' . connects == 'all' 'isEmpty' +-- @ +connects :: [AdjacencyIntMap] -> AdjacencyIntMap +connects = foldr connect empty +{-# NOINLINE [1] connects #-} + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- @ +isSubgraphOf :: AdjacencyIntMap -> AdjacencyIntMap -> Bool +isSubgraphOf x y = IntMap.isSubmapOfBy IntSet.isSubsetOf (adjacencyIntMap x) (adjacencyIntMap y) + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' x y) == False +-- @ +isEmpty :: AdjacencyIntMap -> Bool +isEmpty = IntMap.null . adjacencyIntMap + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False +-- hasVertex x . 'removeVertex' x == const False +-- @ +hasVertex :: Int -> AdjacencyIntMap -> Bool +hasVertex x = IntMap.member x . adjacencyIntMap + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' x y) == True +-- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' +-- @ +hasEdge :: Int -> Int -> AdjacencyIntMap -> Bool +hasEdge u v a = case IntMap.lookup u (adjacencyIntMap a) of + Nothing -> False + Just vs -> IntSet.member v vs + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- @ +vertexCount :: AdjacencyIntMap -> Int +vertexCount = IntMap.size . adjacencyIntMap + +-- | The number of edges in a graph. +-- Complexity: /O(n)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: AdjacencyIntMap -> Int +edgeCount = getSum . foldMap (Sum . IntSet.size) . adjacencyIntMap + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: AdjacencyIntMap -> [Int] +vertexList = IntMap.keys . adjacencyIntMap + +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] +-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- @ +edgeList :: AdjacencyIntMap -> [(Int, Int)] +edgeList (AM m) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] + +-- | The set of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexIntSet 'empty' == IntSet.'IntSet.empty' +-- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' +-- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' +-- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' +-- @ +vertexIntSet :: AdjacencyIntMap -> IntSet +vertexIntSet = IntMap.keysSet . adjacencyIntMap + +-- | The set of edges of a given graph. +-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) +-- edgeSet . 'edges' == Set.'Set.fromList' +-- @ +edgeSet :: AdjacencyIntMap -> Set (Int, Int) +edgeSet = Set.fromAscList . edgeList + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] +-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] +-- 'stars' . adjacencyList == id +-- @ +adjacencyList :: AdjacencyIntMap -> [(Int, [Int])] +adjacencyList = map (fmap IntSet.toAscList) . IntMap.toAscList . adjacencyIntMap + +-- | The /preset/ (here @preIntSet@) of an element @x@ is the set of its +-- /direct predecessors/. +-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- preIntSet x 'empty' == Set.'Set.empty' +-- preIntSet x ('vertex' x) == Set.'Set.empty' +-- preIntSet 1 ('edge' 1 2) == Set.'Set.empty' +-- preIntSet y ('edge' x y) == Set.'Set.fromList' [x] +-- @ +preIntSet :: Int -> AdjacencyIntMap -> IntSet.IntSet +preIntSet x = IntSet.fromAscList . map fst . filter p . IntMap.toAscList . adjacencyIntMap + where + p (_, set) = x `IntSet.member` set + +-- | The /postset/ (here @postIntSet@) of a vertex is the set of its +-- /direct successors/. +-- +-- @ +-- postIntSet x 'empty' == IntSet.'IntSet.empty' +-- postIntSet x ('vertex' x) == IntSet.'IntSet.empty' +-- postIntSet x ('edge' x y) == IntSet.'IntSet.fromList' [y] +-- postIntSet 2 ('edge' 1 2) == IntSet.'IntSet.empty' +-- @ +postIntSet :: Int -> AdjacencyIntMap -> IntSet +postIntSet x = IntMap.findWithDefault IntSet.empty x . adjacencyIntMap + +-- | The /path/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- path [] == 'empty' +-- path [x] == 'vertex' x +-- path [x,y] == 'edge' x y +-- path . 'reverse' == 'transpose' . path +-- @ +path :: [Int] -> AdjacencyIntMap +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- circuit [] == 'empty' +-- circuit [x] == 'edge' x x +-- circuit [x,y] == 'edges' [(x,y), (y,x)] +-- circuit . 'reverse' == 'transpose' . circuit +-- @ +circuit :: [Int] -> AdjacencyIntMap +circuit [] = empty +circuit (x:xs) = path $ [x] ++ xs ++ [x] + +-- | The /clique/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique . 'reverse' == 'transpose' . clique +-- @ +clique :: [Int] -> AdjacencyIntMap +clique = fromAdjacencyIntSets . fst . go + where + go [] = ([], IntSet.empty) + go (x:xs) = let (res, set) = go xs in ((x, set) : res, IntSet.insert x set) +{-# NOINLINE [1] clique #-} + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. +-- +-- @ +-- biclique [] [] == 'empty' +-- biclique [x] [] == 'vertex' x +-- biclique [] [y] == 'vertex' y +-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) +-- @ +biclique :: [Int] -> [Int] -> AdjacencyIntMap +biclique xs ys = AM $ IntMap.fromSet adjacent (x `IntSet.union` y) + where + x = IntSet.fromList xs + y = IntSet.fromList ys + adjacent v = if v `IntSet.member` x then y else IntSet.empty + +-- TODO: Optimise. +-- | The /star/ formed by a centre vertex connected to a list of leaves. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- star x [] == 'vertex' x +-- star x [y] == 'edge' x y +-- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) +-- @ +star :: Int -> [Int] -> AdjacencyIntMap +star x [] = vertex x +star x ys = connect (vertex x) (vertices ys) +{-# INLINE star #-} + +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L * log(n))/ time, memory and size, where /L/ is the total +-- size of the input. +-- +-- @ +-- stars [] == 'empty' +-- stars [(x, [])] == 'vertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . map (uncurry 'star') +-- stars . 'adjacencyList' == id +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) +-- @ +stars :: [(Int, [Int])] -> AdjacencyIntMap +stars = fromAdjacencyIntSets . map (fmap IntSet.fromList) + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ +tree :: Tree Int -> AdjacencyIntMap +tree (Node x []) = vertex x +tree (Node x f ) = star x (map rootLabel f) + `overlay` forest (filter (not . null . subForest) f) + +-- | The /forest graph/ constructed from a given 'Forest' data structure. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . map 'tree' +-- @ +forest :: Forest Int -> AdjacencyIntMap +forest = overlays . map tree + +-- | Remove a vertex from a given graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Int -> AdjacencyIntMap -> AdjacencyIntMap +removeVertex x = AM . IntMap.map (IntSet.delete x) . IntMap.delete x . adjacencyIntMap + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Int -> Int -> AdjacencyIntMap -> AdjacencyIntMap +removeEdge x y = AM . IntMap.adjust (IntSet.delete y) x . adjacencyIntMap + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'AdjacencyIntMap'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'mergeVertices' (== x) y +-- @ +replaceVertex :: Int -> Int -> AdjacencyIntMap -> AdjacencyIntMap +replaceVertex u v = gmap $ \w -> if w == u then v else w + +-- | Merge vertices satisfying a given predicate into a given vertex. +-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- mergeVertices (const False) x == id +-- mergeVertices (== x) y == 'replaceVertex' x y +-- mergeVertices even 1 (0 * 2) == 1 * 1 +-- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 +-- @ +mergeVertices :: (Int -> Bool) -> Int -> AdjacencyIntMap -> AdjacencyIntMap +mergeVertices p v = gmap $ \u -> if p u then v else u + +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' x y) == 'edge' y x +-- transpose . transpose == id +-- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- @ +transpose :: AdjacencyIntMap -> AdjacencyIntMap +transpose (AM m) = AM $ IntMap.foldrWithKey combine vs m + where + combine v es = IntMap.unionWith IntSet.union (IntMap.fromSet (const $ IntSet.singleton v) es) + vs = IntMap.fromSet (const IntSet.empty) (IntMap.keysSet m) +{-# NOINLINE [1] transpose #-} + +{-# RULES +"transpose/empty" transpose empty = empty +"transpose/vertex" forall x. transpose (vertex x) = vertex x +"transpose/overlay" forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2) +"transpose/connect" forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1) + +"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs) +"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs)) + +"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs +"transpose/clique" forall xs. transpose (clique xs) = clique (reverse xs) + #-} + +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'AdjacencyIntMap'. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- gmap f 'empty' == 'empty' +-- gmap f ('vertex' x) == 'vertex' (f x) +-- gmap f ('edge' x y) == 'edge' (f x) (f y) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Int -> Int) -> AdjacencyIntMap -> AdjacencyIntMap +gmap f = AM . IntMap.map (IntSet.map f) . IntMap.mapKeysWith IntSet.union f . adjacencyIntMap + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to +-- be evaluated. +-- +-- @ +-- induce (const True ) x == x +-- induce (const False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (Int -> Bool) -> AdjacencyIntMap -> AdjacencyIntMap +induce p = AM . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyIntMap + +-- | Compute the /depth-first search/ forest of a graph that corresponds to +-- searching from each of the graph vertices in the 'Ord' @a@ order. +-- +-- @ +-- dfsForest 'empty' == [] +-- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True +-- 'isDfsForestOf' (dfsForest x) x == True +-- dfsForest . 'forest' . dfsForest == dfsForest +-- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- 'dfsForestFrom' ('vertexList' x) x == dfsForest x +-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 3 +-- , subForest = [ Node { rootLabel = 4 +-- , subForest = [] }]}] +-- @ +dfsForest :: AdjacencyIntMap -> Forest Int +dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap + +-- | Compute the /depth-first search/ forest of a graph, searching from each of +-- the given vertices in order. Note that the resulting forest does not +-- necessarily span the whole graph, as some vertices may be unreachable. +-- +-- @ +-- dfsForestFrom vs 'empty' == [] +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 +-- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' +-- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True +-- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True +-- dfsForestFrom ('vertexList' x) x == 'dfsForest' x +-- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom [] x == [] +-- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- @ +dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int +dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap + +-- | Compute the list of vertices visited by the /depth-first search/ in a graph, +-- when searching from each of the given vertices in order. +-- +-- @ +-- dfs vs $ 'empty' == [] +-- dfs [1] $ 'edge' 1 1 == [1] +-- dfs [1] $ 'edge' 1 2 == [1,2] +-- dfs [2] $ 'edge' 1 2 == [2] +-- dfs [3] $ 'edge' 1 2 == [] +-- dfs [1,2] $ 'edge' 1 2 == [1,2] +-- dfs [2,1] $ 'edge' 1 2 == [2,1] +-- dfs [] $ x == [] +-- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] +-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True +-- @ +dfs :: [Int] -> AdjacencyIntMap -> [Int] +dfs vs = concatMap flatten . dfsForestFrom vs + +-- | Compute the list of vertices that are /reachable/ from a given source +-- vertex in a graph. The vertices in the resulting list appear in the +-- /depth-first order/. +-- +-- @ +-- reachable x $ 'empty' == [] +-- reachable 1 $ 'vertex' 1 == [1] +-- reachable 1 $ 'vertex' 2 == [] +-- reachable 1 $ 'edge' 1 1 == [1] +-- reachable 1 $ 'edge' 1 2 == [1,2] +-- reachable 4 $ 'path' [1..8] == [4..8] +-- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] +-- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] +-- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- @ +reachable :: Int -> AdjacencyIntMap -> [Int] +reachable x = dfs [x] + +-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph +-- is cyclic. +-- +-- @ +-- topSort (1 * 2 + 3 * 1) == Just [3,1,2] +-- topSort (1 * 2 + 2 * 1) == Nothing +-- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False +-- 'isJust' . topSort == 'isAcyclic' +-- @ +topSort :: AdjacencyIntMap -> Maybe [Int] +topSort m = if isTopSortOf result m then Just result else Nothing + where + result = Typed.topSort (Typed.fromAdjacencyIntMap m) + +-- | Check if a given graph is /acyclic/. +-- +-- @ +-- isAcyclic (1 * 2 + 3 * 1) == True +-- isAcyclic (1 * 2 + 2 * 1) == False +-- isAcyclic . 'circuit' == 'null' +-- isAcyclic == 'isJust' . 'topSort' +-- @ +isAcyclic :: AdjacencyIntMap -> Bool +isAcyclic = isJust . topSort + +-- | Check if a given forest is a correct /depth-first search/ forest of a graph. +-- The implementation is based on the paper "Depth-First Search and Strong +-- Connectivity in Coq" by François Pottier. +-- +-- @ +-- isDfsForestOf [] 'empty' == True +-- isDfsForestOf [] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('vertex' 1) == True +-- isDfsForestOf [Node 1 []] ('vertex' 2) == False +-- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('edge' 1 1) == True +-- isDfsForestOf [Node 1 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False +-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False +-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- @ +isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool +isDfsForestOf f am = case go IntSet.empty f of + Just seen -> seen == vertexIntSet am + Nothing -> False + where + go seen [] = Just seen + go seen (t:ts) = do + let root = rootLabel t + guard $ root `IntSet.notMember` seen + guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] + newSeen <- go (IntSet.insert root seen) (subForest t) + guard $ postIntSet root am `IntSet.isSubsetOf` newSeen + go newSeen ts + +-- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- +-- @ +-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True +-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] 'empty' == True +-- isTopSortOf [x] ('vertex' x) == True +-- isTopSortOf [x] ('edge' x x) == False +-- @ +isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool +isTopSortOf xs m = go IntSet.empty xs + where + go seen [] = seen == IntMap.keysSet (adjacencyIntMap m) + go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty + && go newSeen vs + where + newSeen = IntSet.insert v seen diff --git a/src/Algebra/Graph/AdjacencyIntMap/Internal.hs b/src/Algebra/Graph/AdjacencyIntMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyIntMap/Internal.hs @@ -0,0 +1,232 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.AdjacencyIntMap.Internal +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- This module exposes the implementation of adjacency maps. The API is unstable +-- and unsafe, and is exposed only for documentation. You should use the +-- non-internal module "Algebra.Graph.AdjacencyIntMap" instead. +----------------------------------------------------------------------------- +module Algebra.Graph.AdjacencyIntMap.Internal ( + -- * Adjacency map implementation + AdjacencyIntMap (..), empty, vertex, overlay, connect, fromAdjacencyIntSets, + consistent + ) where + +import Data.IntMap.Strict (IntMap, keysSet, fromSet) +import Data.IntSet (IntSet) +import Data.List + +import Control.DeepSeq (NFData (..)) + +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet + +{-| The 'AdjacencyIntMap' data type represents a graph by a map of vertices to +their adjacency sets. We define a 'Num' instance as a convenient notation for +working with graphs: + + > 0 == vertex 0 + > 1 + 2 == overlay (vertex 1) (vertex 2) + > 1 * 2 == connect (vertex 1) (vertex 2) + > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) + > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) + +The 'Show' instance is defined using basic graph construction primitives: + +@show (empty :: AdjacencyIntMap Int) == "empty" +show (1 :: AdjacencyIntMap Int) == "vertex 1" +show (1 + 2 :: AdjacencyIntMap Int) == "vertices [1,2]" +show (1 * 2 :: AdjacencyIntMap Int) == "edge 1 2" +show (1 * 2 * 3 :: AdjacencyIntMap Int) == "edges [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: AdjacencyIntMap Int) == "overlay (vertex 3) (edge 1 2)"@ + +The 'Eq' instance satisfies all axioms of algebraic graphs: + + * 'Algebra.Graph.AdjacencyIntMap.overlay' is commutative and associative: + + > x + y == y + x + > x + (y + z) == (x + y) + z + + * 'Algebra.Graph.AdjacencyIntMap.connect' is associative and has + 'Algebra.Graph.AdjacencyIntMap.empty' as the identity: + + > x * empty == x + > empty * x == x + > x * (y * z) == (x * y) * z + + * 'Algebra.Graph.AdjacencyIntMap.connect' distributes over + 'Algebra.Graph.AdjacencyIntMap.overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'Algebra.Graph.AdjacencyIntMap.connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + +The following useful theorems can be proved from the above set of axioms. + + * 'Algebra.Graph.AdjacencyIntMap.overlay' has + 'Algebra.Graph.AdjacencyIntMap.empty' as the identity and is idempotent: + + > x + empty == x + > empty + x == x + > x + x == x + + * Absorption and saturation of 'Algebra.Graph.AdjacencyIntMap.connect': + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ and /m/ +will denote the number of vertices and edges in the graph, respectively. +-} +newtype AdjacencyIntMap = AM { + -- | The /adjacency map/ of the graph: each vertex is associated with a set + -- of its direct successors. Complexity: /O(1)/ time and memory. + -- + -- @ + -- adjacencyIntMap 'empty' == IntMap.'IntMap.empty' + -- adjacencyIntMap ('vertex' x) == IntMap.'IntMap.singleton' x IntSet.'IntSet.empty' + -- adjacencyIntMap ('Algebra.Graph.AdjacencyIntMap.edge' 1 1) == IntMap.'IntMap.singleton' 1 (IntSet.'IntSet.singleton' 1) + -- adjacencyIntMap ('Algebra.Graph.AdjacencyIntMap.edge' 1 2) == IntMap.'IntMap.fromList' [(1,IntSet.'IntSet.singleton' 2), (2,IntSet.'IntSet.empty')] + -- @ + adjacencyIntMap :: IntMap IntSet } deriving Eq + +instance Show AdjacencyIntMap where + show (AM m) + | null vs = "empty" + | null es = vshow vs + | vs == used = eshow es + | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" + where + vs = IntSet.toAscList (keysSet m) + es = internalEdgeList m + vshow [x] = "vertex " ++ show x + vshow xs = "vertices " ++ show xs + eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y + eshow xs = "edges " ++ show xs + used = IntSet.toAscList (referredToVertexSet m) + +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.AdjacencyIntMap.isEmpty' empty == True +-- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x empty == False +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' empty == 0 +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' empty == 0 +-- @ +empty :: AdjacencyIntMap +empty = AM IntMap.empty +{-# NOINLINE [1] empty #-} + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (vertex x) == False +-- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x (vertex x) == True +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (vertex x) == 1 +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (vertex x) == 0 +-- @ +vertex :: Int -> AdjacencyIntMap +vertex x = AM $ IntMap.singleton x IntSet.empty +{-# NOINLINE [1] vertex #-} + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty' x && 'Algebra.Graph.AdjacencyIntMap.isEmpty' y +-- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay 1 2) == 2 +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +overlay x y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y) +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (connect x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty' x && 'Algebra.Graph.AdjacencyIntMap.isEmpty' y +-- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (connect x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' y +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y + 'Algebra.Graph.AdjacencyIntMap.edgeCount' x + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y +-- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect 1 2) == 2 +-- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect 1 2) == 1 +-- @ +connect :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +connect x y = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y, + fromSet (const . keysSet $ adjacencyIntMap y) (keysSet $ adjacencyIntMap x) ] +{-# NOINLINE [1] connect #-} + +instance Num AdjacencyIntMap where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance NFData AdjacencyIntMap where + rnf (AM a) = rnf a + +-- | Construct a graph from a list of adjacency sets. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyIntSets [] == 'Algebra.Graph.AdjacencyIntMap.empty' +-- fromAdjacencyIntSets [(x, IntSet.'IntSet.empty')] == 'Algebra.Graph.AdjacencyIntMap.vertex' x +-- fromAdjacencyIntSets [(x, IntSet.'IntSet.singleton' y)] == 'Algebra.Graph.AdjacencyIntMap.edge' x y +-- fromAdjacencyIntSets . map (fmap IntSet.'IntSet.fromList') . 'Algebra.Graph.AdjacencyIntMap.adjacencyList' == id +-- 'Algebra.Graph.AdjacencyIntMap.overlay' (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys) +-- @ +fromAdjacencyIntSets :: [(Int, IntSet)] -> AdjacencyIntMap +fromAdjacencyIntSets ss = AM $ IntMap.unionWith IntSet.union vs es + where + vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss + es = IntMap.fromListWith IntSet.union ss + +-- | Check if the internal graph representation is consistent, i.e. that all +-- edges refer to existing vertices. It should be impossible to create an +-- inconsistent adjacency map, and we use this function in testing. +-- /Note: this function is for internal use only/. +-- +-- @ +-- consistent 'Algebra.Graph.AdjacencyIntMap.empty' == True +-- consistent ('Algebra.Graph.AdjacencyIntMap.vertex' x) == True +-- consistent ('Algebra.Graph.AdjacencyIntMap.overlay' x y) == True +-- consistent ('Algebra.Graph.AdjacencyIntMap.connect' x y) == True +-- consistent ('Algebra.Graph.AdjacencyIntMap.edge' x y) == True +-- consistent ('Algebra.Graph.AdjacencyIntMap.edges' xs) == True +-- consistent ('Algebra.Graph.AdjacencyIntMap.stars' xs) == True +-- @ +consistent :: AdjacencyIntMap -> Bool +consistent (AM m) = referredToVertexSet m `IntSet.isSubsetOf` keysSet m + +-- The set of vertices that are referred to by the edges +referredToVertexSet :: IntMap IntSet -> IntSet +referredToVertexSet = IntSet.fromList . uncurry (++) . unzip . internalEdgeList + +-- The list of edges in adjacency map +internalEdgeList :: IntMap IntSet -> [(Int, Int)] +internalEdgeList m = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -13,7 +13,7 @@ -- This module defines the 'AdjacencyMap' data type, as well as associated -- operations and algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type -- class, which can be used for polymorphic graph construction and manipulation. --- "Algebra.Graph.IntAdjacencyMap" defines adjacency maps specialised to graphs +-- "Algebra.Graph.AdjacencyIntMap" defines adjacency maps specialised to graphs -- with @Int@ vertices. ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap ( @@ -22,60 +22,42 @@ -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - fromAdjacencyList, -- * Relations on graphs isSubgraphOf, -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexSet, edgeSet, postSet, + adjacencyList, vertexSet, vertexIntSet, edgeSet, preSet, postSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest, + path, circuit, clique, biclique, star, stars, tree, forest, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, + removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, + induce, -- * Algorithms - dfsForest, dfsForestFrom, dfs, topSort, isTopSort, scc + dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc, + + -- * Correctness properties + isDfsForestOf, isTopSortOf ) where -import Data.Foldable (toList) +import Control.Monad +import Data.Foldable (foldMap, toList) import Data.Maybe +import Data.Monoid import Data.Set (Set) import Data.Tree import Algebra.Graph.AdjacencyMap.Internal -import qualified Algebra.Graph.Class as C -import qualified Data.Graph as KL -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'isEmpty' empty == True --- 'hasVertex' x empty == False --- 'vertexCount' empty == 0 --- 'edgeCount' empty == 0 --- @ -empty :: Ord a => AdjacencyMap a -empty = C.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True --- 'vertexCount' (vertex x) == 1 --- 'edgeCount' (vertex x) == 0 --- @ -vertex :: Ord a => a -> AdjacencyMap a -vertex = C.vertex +import qualified Data.Graph.Typed as Typed +import qualified Data.Graph as KL +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. @@ -88,45 +70,8 @@ -- 'vertexCount' (edge 1 2) == 2 -- @ edge :: Ord a => a -> a -> AdjacencyMap a -edge = C.edge - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (overlay x y) >= 'vertexCount' x --- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (overlay x y) >= 'edgeCount' x --- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y --- 'vertexCount' (overlay 1 2) == 2 --- 'edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -overlay = C.overlay - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (connect x y) >= 'vertexCount' x --- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (connect x y) >= 'edgeCount' x --- 'edgeCount' (connect x y) >= 'edgeCount' y --- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y --- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y --- 'vertexCount' (connect 1 2) == 2 --- 'edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -connect = C.connect +edge x y | x == y = AM $ Map.singleton x (Set.singleton y) + | otherwise = AM $ Map.fromList [(x, Set.singleton y), (y, Set.empty)] -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length @@ -140,19 +85,20 @@ -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: Ord a => [a] -> AdjacencyMap a -vertices = mkAM . Map.fromList . map (\x -> (x, Set.empty)) +vertices = AM . Map.fromList . map (\x -> (x, Set.empty)) +{-# NOINLINE [1] vertices #-} -- | Construct the graph from a list of edges. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ -- edges [] == 'empty' --- edges [(x, y)] == 'edge' x y +-- edges [(x,y)] == 'edge' x y -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' -- @ edges :: Ord a => [(a, a)] -> AdjacencyMap a -edges = fromAdjacencyList . map (fmap return) +edges = fromAdjacencySets . map (fmap Set.singleton) -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -165,7 +111,8 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a -overlays = C.overlays +overlays = AM . Map.unionsWith Set.union . map adjacencyMap +{-# NOINLINE overlays #-} -- | Connect a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -178,24 +125,8 @@ -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: Ord a => [AdjacencyMap a] -> AdjacencyMap a -connects = C.connects - --- | Construct a graph from an adjacency list. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyList [] == 'empty' --- fromAdjacencyList [(x, [])] == 'vertex' x --- fromAdjacencyList [(x, [y])] == 'edge' x y --- fromAdjacencyList . 'adjacencyList' == id --- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) --- @ -fromAdjacencyList :: Ord a => [(a, [a])] -> AdjacencyMap a -fromAdjacencyList as = mkAM $ Map.unionWith Set.union vs es - where - ss = map (fmap Set.fromList) as - vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss - es = Map.fromListWith Set.union ss +connects = foldr connect empty +{-# NOINLINE connects #-} -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. @@ -272,7 +203,7 @@ -- edgeCount == 'length' . 'edgeList' -- @ edgeCount :: AdjacencyMap a -> Int -edgeCount = Map.foldr (\es r -> (Set.size es + r)) 0 . adjacencyMap +edgeCount = getSum . foldMap (Sum . Set.size) . adjacencyMap -- | The sorted list of vertices of a given graph. -- Complexity: /O(n)/ time and memory. @@ -297,20 +228,7 @@ -- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyMap a -> [(a, a)] -edgeList (AM m _) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] - --- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- adjacencyList 'empty' == [] --- adjacencyList ('vertex' x) == [(x, [])] --- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] --- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] --- 'fromAdjacencyList' . adjacencyList == id --- @ -adjacencyList :: AdjacencyMap a -> [(a, [a])] -adjacencyList = map (fmap Set.toAscList) . Map.toAscList . adjacencyMap +edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory. @@ -324,6 +242,19 @@ vertexSet :: AdjacencyMap a -> Set a vertexSet = Map.keysSet . adjacencyMap +-- | The set of vertices of a given graph. Like 'vertexSet' but specialised for +-- graphs with vertices of type 'Int'. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexIntSet 'empty' == IntSet.'IntSet.empty' +-- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' +-- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' +-- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' +-- @ +vertexIntSet :: AdjacencyMap Int -> IntSet.IntSet +vertexIntSet = IntSet.fromAscList . Set.toAscList . vertexSet + -- | The set of edges of a given graph. -- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. -- @@ -334,11 +265,39 @@ -- edgeSet . 'edges' == Set.'Set.fromList' -- @ edgeSet :: Ord a => AdjacencyMap a -> Set (a, a) -edgeSet = Map.foldrWithKey (\v es -> Set.union (Set.mapMonotonic (v,) es)) Set.empty . adjacencyMap +edgeSet = Set.fromAscList . edgeList --- | The /postset/ (here 'postSet') of a vertex is the set of its /direct successors/. +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. -- -- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] +-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] +-- 'stars' . adjacencyList == id +-- @ +adjacencyList :: AdjacencyMap a -> [(a, [a])] +adjacencyList = map (fmap Set.toAscList) . Map.toAscList . adjacencyMap + +-- | The /preset/ of an element @x@ is the set of its /direct predecessors/. +-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- preSet x 'empty' == Set.'Set.empty' +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 ('edge' 1 2) == Set.'Set.empty' +-- preSet y ('edge' x y) == Set.'Set.fromList' [x] +-- @ +preSet :: Ord a => a -> AdjacencyMap a -> Set.Set a +preSet x = Set.fromAscList . map fst . filter p . Map.toAscList . adjacencyMap + where + p (_, set) = x `Set.member` set + +-- | The /postset/ of a vertex is the set of its /direct successors/. +-- Complexity: /O(log(n))/ time and /O(1)/ memory. +-- +-- @ -- postSet x 'empty' == Set.'Set.empty' -- postSet x ('vertex' x) == Set.'Set.empty' -- postSet x ('edge' x y) == Set.'Set.fromList' [y] @@ -357,7 +316,9 @@ -- path . 'reverse' == 'transpose' . path -- @ path :: Ord a => [a] -> AdjacencyMap a -path = C.path +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) -- | The /circuit/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -369,7 +330,8 @@ -- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: Ord a => [a] -> AdjacencyMap a -circuit = C.circuit +circuit [] = empty +circuit (x:xs) = path $ [x] ++ xs ++ [x] -- | The /clique/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -383,7 +345,11 @@ -- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> AdjacencyMap a -clique = C.clique +clique = fromAdjacencySets . fst . go + where + go [] = ([], Set.empty) + go (x:xs) = let (res, set) = go xs in ((x, set) : res, Set.insert x set) +{-# NOINLINE [1] clique #-} -- | The /biclique/ on two lists of vertices. -- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. @@ -396,14 +362,13 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Ord a => [a] -> [a] -> AdjacencyMap a -biclique xs ys = mkAM $ Map.fromSet adjacent (x `Set.union` y) +biclique xs ys = AM $ Map.fromSet adjacent (x `Set.union` y) where x = Set.fromList xs y = Set.fromList ys - adjacent v - | v `Set.member` x = y - | otherwise = Set.empty + adjacent v = if v `Set.member` x then y else Set.empty +-- TODO: Optimise. -- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -414,21 +379,26 @@ -- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Ord a => a -> [a] -> AdjacencyMap a -star = C.star +star x [] = vertex x +star x ys = connect (vertex x) (vertices ys) +{-# INLINE star #-} --- | The /star transpose/ formed by a list of leaves connected to a centre vertex. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L * log(n))/ time, memory and size, where /L/ is the total +-- size of the input. -- -- @ --- starTranspose x [] == 'vertex' x --- starTranspose x [y] == 'edge' y x --- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] --- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) --- starTranspose x ys == 'transpose' ('star' x ys) +-- stars [] == 'empty' +-- stars [(x, [])] == 'vertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . map (uncurry 'star') +-- stars . 'adjacencyList' == id +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ -starTranspose :: Ord a => a -> [a] -> AdjacencyMap a -starTranspose = C.starTranspose +stars :: Ord a => [(a, [a])] -> AdjacencyMap a +stars = fromAdjacencySets . map (fmap Set.fromList) -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -440,7 +410,9 @@ -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] -- @ tree :: Ord a => Tree a -> AdjacencyMap a -tree = C.tree +tree (Node x []) = vertex x +tree (Node x f ) = star x (map rootLabel f) + `overlay` forest (filter (not . null . subForest) f) -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -452,7 +424,7 @@ -- forest == 'overlays' . map 'tree' -- @ forest :: Ord a => Forest a -> AdjacencyMap a -forest = C.forest +forest = overlays . map tree -- | Remove a vertex from a given graph. -- Complexity: /O(n*log(n))/ time. @@ -465,20 +437,20 @@ -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a -removeVertex x = mkAM . Map.map (Set.delete x) . Map.delete x . adjacencyMap +removeVertex x = AM . Map.map (Set.delete x) . Map.delete x . adjacencyMap -- | Remove an edge from a given graph. -- Complexity: /O(log(n))/ time. -- -- @ --- removeEdge x y ('edge' x y) == 'vertices' [x, y] +-- removeEdge x y ('edge' x y) == 'vertices' [x,y] -- removeEdge x y . removeEdge x y == removeEdge x y -- removeEdge x y . 'removeVertex' x == 'removeVertex' x -- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- @ removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a -removeEdge x y = mkAM . Map.adjust (Set.delete y) x . adjacencyMap +removeEdge x y = AM . Map.adjust (Set.delete y) x . adjacencyMap -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. @@ -516,11 +488,25 @@ -- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a -transpose (AM m _) = mkAM $ Map.foldrWithKey combine vs m +transpose (AM m) = AM $ Map.foldrWithKey combine vs m where combine v es = Map.unionWith Set.union (Map.fromSet (const $ Set.singleton v) es) vs = Map.fromSet (const Set.empty) (Map.keysSet m) +{-# NOINLINE [1] transpose #-} +{-# RULES +"transpose/empty" transpose empty = empty +"transpose/vertex" forall x. transpose (vertex x) = vertex x +"transpose/overlay" forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2) +"transpose/connect" forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1) + +"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs) +"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs)) + +"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs +"transpose/clique" forall xs. transpose (clique xs) = clique (reverse xs) + #-} + -- | Transform a graph by applying a function to each of its vertices. This is -- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric -- 'AdjacencyMap'. @@ -534,7 +520,7 @@ -- gmap f . gmap g == gmap (f . g) -- @ gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b -gmap f = mkAM . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap +gmap f = AM . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. @@ -548,16 +534,19 @@ -- induce p . induce q == induce (\\x -> p x && q x) -- 'isSubgraphOf' (induce p x) x == True -- @ -induce :: Ord a => (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a -induce p = mkAM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap +induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a +induce p = AM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap --- | Compute the /depth-first search/ forest of a graph. +-- | Compute the /depth-first search/ forest of a graph that corresponds to +-- searching from each of the graph vertices in the 'Ord' @a@ order. -- -- @ +-- dfsForest 'empty' == [] -- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 -- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1, 2] +-- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] -- 'isSubgraphOf' ('forest' $ dfsForest x) x == True +-- 'isDfsForestOf' (dfsForest x) x == True -- dfsForest . 'forest' . dfsForest == dfsForest -- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) -- 'dfsForestFrom' ('vertexList' x) x == dfsForest x @@ -568,79 +557,94 @@ -- , subForest = [ Node { rootLabel = 4 -- , subForest = [] }]}] -- @ -dfsForest :: AdjacencyMap a -> Forest a -dfsForest (AM _ (GraphKL g r _)) = fmap (fmap r) (KL.dff g) +dfsForest :: Ord a => AdjacencyMap a -> Forest a +dfsForest g = dfsForestFrom (vertexList g) g -- | Compute the /depth-first search/ forest of a graph, searching from each of -- the given vertices in order. Note that the resulting forest does not -- necessarily span the whole graph, as some vertices may be unreachable. -- -- @ --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2, 1] $ 'edge' 1 2) == 'vertices' [1, 2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1, 4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] +-- dfsForestFrom vs 'empty' == [] +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 +-- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' +-- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True +-- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True +-- dfsForestFrom ('vertexList' x) x == 'dfsForest' x +-- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom [] x == [] +-- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] -- @ -dfsForestFrom :: [a] -> AdjacencyMap a -> Forest a -dfsForestFrom vs (AM _ (GraphKL g r t)) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) +dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a +dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap --- | Compute the list of vertices visited by the /depth-first search/ in a graph, --- when searching from each of the given vertices in order. +-- | Compute the list of vertices visited by the /depth-first search/ in a +-- graph, when searching from each of the given vertices in order. -- -- @ --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1, 2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1, 2] $ 'edge' 1 2 == [1, 2] --- dfs [2, 1] $ 'edge' 1 2 == [2, 1] --- dfs [] $ x == [] --- dfs [1, 4] $ 3 * (1 + 4) * (1 + 5) == [1, 5, 4] +-- dfs vs $ 'empty' == [] +-- dfs [1] $ 'edge' 1 1 == [1] +-- dfs [1] $ 'edge' 1 2 == [1,2] +-- dfs [2] $ 'edge' 1 2 == [2] +-- dfs [3] $ 'edge' 1 2 == [] +-- dfs [1,2] $ 'edge' 1 2 == [1,2] +-- dfs [2,1] $ 'edge' 1 2 == [2,1] +-- dfs [] $ x == [] +-- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] -- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True -- @ -dfs :: [a] -> AdjacencyMap a -> [a] +dfs :: Ord a => [a] -> AdjacencyMap a -> [a] dfs vs = concatMap flatten . dfsForestFrom vs +-- | Compute the list of vertices that are /reachable/ from a given source +-- vertex in a graph. The vertices in the resulting list appear in the +-- /depth-first order/. +-- +-- @ +-- reachable x $ 'empty' == [] +-- reachable 1 $ 'vertex' 1 == [1] +-- reachable 1 $ 'vertex' 2 == [] +-- reachable 1 $ 'edge' 1 1 == [1] +-- reachable 1 $ 'edge' 1 2 == [1,2] +-- reachable 4 $ 'path' [1..8] == [4..8] +-- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] +-- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] +-- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- @ +reachable :: Ord a => a -> AdjacencyMap a -> [a] +reachable x = dfs [x] + -- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph -- is cyclic. -- -- @ --- topSort (1 * 2 + 3 * 1) == Just [3,1,2] --- topSort (1 * 2 + 2 * 1) == Nothing --- fmap (flip 'isTopSort' x) (topSort x) /= Just False +-- topSort (1 * 2 + 3 * 1) == Just [3,1,2] +-- topSort (1 * 2 + 2 * 1) == Nothing +-- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False +-- 'isJust' . topSort == 'isAcyclic' -- @ topSort :: Ord a => AdjacencyMap a -> Maybe [a] -topSort m@(AM _ (GraphKL g r _)) = - if isTopSort result m then Just result else Nothing +topSort m = if isTopSortOf result m then Just result else Nothing where - result = map r (KL.topSort g) + result = Typed.topSort (Typed.fromAdjacencyMap m) --- | Check if a given list of vertices is a valid /topological sort/ of a graph. +-- | Check if a given graph is /acyclic/. -- -- @ --- isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True --- isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False --- isTopSort [] (1 * 2 + 3 * 1) == False --- isTopSort [] 'empty' == True --- isTopSort [x] ('vertex' x) == True --- isTopSort [x] ('edge' x x) == False +-- isAcyclic (1 * 2 + 3 * 1) == True +-- isAcyclic (1 * 2 + 2 * 1) == False +-- isAcyclic . 'circuit' == 'null' +-- isAcyclic == 'isJust' . 'topSort' -- @ -isTopSort :: Ord a => [a] -> AdjacencyMap a -> Bool -isTopSort xs m = go Set.empty xs - where - go seen [] = seen == Map.keysSet (adjacencyMap m) - go seen (v:vs) = let newSeen = seen `seq` Set.insert v seen - in postSet v m `Set.intersection` newSeen == Set.empty && go newSeen vs +isAcyclic :: Ord a => AdjacencyMap a -> Bool +isAcyclic = isJust . topSort -- | Compute the /condensation/ of a graph, where each vertex corresponds to a -- /strongly-connected component/ of the original graph. @@ -656,8 +660,65 @@ -- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [5] )] -- @ scc :: Ord a => AdjacencyMap a -> AdjacencyMap (Set a) -scc m@(AM _ (GraphKL g r _)) = - gmap (\v -> Map.findWithDefault Set.empty v components) m +scc m = gmap (\v -> Map.findWithDefault Set.empty v components) m where + (Typed.GraphKL g r _) = Typed.fromAdjacencyMap m components = Map.fromList $ concatMap (expand . fmap r . toList) (KL.scc g) expand xs = let s = Set.fromList xs in map (\x -> (x, s)) xs + +-- | Check if a given forest is a correct /depth-first search/ forest of a graph. +-- The implementation is based on the paper "Depth-First Search and Strong +-- Connectivity in Coq" by François Pottier. +-- +-- @ +-- isDfsForestOf [] 'empty' == True +-- isDfsForestOf [] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('vertex' 1) == True +-- isDfsForestOf [Node 1 []] ('vertex' 2) == False +-- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('edge' 1 1) == True +-- isDfsForestOf [Node 1 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False +-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False +-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- @ +isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool +isDfsForestOf f am = case go Set.empty f of + Just seen -> seen == vertexSet am + Nothing -> False + where + go seen [] = Just seen + go seen (t:ts) = do + let root = rootLabel t + guard $ root `Set.notMember` seen + guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] + newSeen <- go (Set.insert root seen) (subForest t) + guard $ postSet root am `Set.isSubsetOf` newSeen + go newSeen ts + +-- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- +-- @ +-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True +-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] 'empty' == True +-- isTopSortOf [x] ('vertex' x) == True +-- isTopSortOf [x] ('edge' x x) == False +-- @ +isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool +isTopSortOf xs m = go Set.empty xs + where + go seen [] = seen == Map.keysSet (adjacencyMap m) + go seen (v:vs) = postSet v m `Set.intersection` newSeen == Set.empty + && go newSeen vs + where + newSeen = Set.insert v seen diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs --- a/src/Algebra/Graph/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/AdjacencyMap/Internal.hs @@ -12,19 +12,16 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap.Internal ( -- * Adjacency map implementation - AdjacencyMap (..), mkAM, consistent, - - -- * Interoperability with King-Launchbury graphs - GraphKL (..), mkGraphKL + AdjacencyMap (..), empty, vertex, overlay, connect, fromAdjacencySets, + consistent ) where import Data.List import Data.Map.Strict (Map, keysSet, fromSet) import Data.Set (Set) -import Algebra.Graph.Class +import Control.DeepSeq (NFData (..)) -import qualified Data.Graph as KL import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -88,25 +85,20 @@ When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively. -} -data AdjacencyMap a = AM { +newtype AdjacencyMap a = AM { -- | The /adjacency map/ of the graph: each vertex is associated with a set - -- of its direct successors. - adjacencyMap :: !(Map a (Set a)), - -- | Cached King-Launchbury representation. - -- /Note: this field is for internal use only/. - graphKL :: GraphKL a } - --- | Construct an 'AdjacencyMap' from a map of successor sets and (lazily) --- compute the corresponding King-Launchbury representation. --- /Note: this function is for internal use only/. -mkAM :: Ord a => Map a (Set a) -> AdjacencyMap a -mkAM m = AM m (mkGraphKL m) - -instance Eq a => Eq (AdjacencyMap a) where - x == y = adjacencyMap x == adjacencyMap y + -- of its direct successors. Complexity: /O(1)/ time and memory. + -- + -- @ + -- adjacencyMap 'empty' == Map.'Map.empty' + -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1) + -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')] + -- @ + adjacencyMap :: Map a (Set a) } deriving Eq instance (Ord a, Show a) => Show (AdjacencyMap a) where - show (AM m _) + show (AM m) | null vs = "empty" | null es = vshow vs | vs == used = eshow es @@ -120,14 +112,73 @@ eshow xs = "edges " ++ show xs used = Set.toAscList (referredToVertexSet m) -instance Ord a => Graph (AdjacencyMap a) where - type Vertex (AdjacencyMap a) = a - empty = mkAM Map.empty - vertex x = mkAM $ Map.singleton x Set.empty - overlay x y = mkAM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) - connect x y = mkAM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, - fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.AdjacencyMap.isEmpty' empty == True +-- 'Algebra.Graph.AdjacencyMap.hasVertex' x empty == False +-- 'Algebra.Graph.AdjacencyMap.vertexCount' empty == 0 +-- 'Algebra.Graph.AdjacencyMap.edgeCount' empty == 0 +-- @ +empty :: AdjacencyMap a +empty = AM Map.empty +{-# NOINLINE [1] empty #-} +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.AdjacencyMap.isEmpty' (vertex x) == False +-- 'Algebra.Graph.AdjacencyMap.hasVertex' x (vertex x) == True +-- 'Algebra.Graph.AdjacencyMap.vertexCount' (vertex x) == 1 +-- 'Algebra.Graph.AdjacencyMap.edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap a +vertex x = AM $ Map.singleton x Set.empty +{-# NOINLINE [1] vertex #-} + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'Algebra.Graph.AdjacencyMap.isEmpty' (overlay x y) == 'Algebra.Graph.AdjacencyMap.isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y +-- 'Algebra.Graph.AdjacencyMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyMap.hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y +-- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.vertexCount' x +-- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y +-- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.edgeCount' x +-- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y +-- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay 1 2) == 2 +-- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y + 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +connect x y = AM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, + fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] +{-# NOINLINE [1] connect #-} + instance (Ord a, Num a) => Num (AdjacencyMap a) where fromInteger = vertex . fromInteger (+) = overlay @@ -136,27 +187,41 @@ abs = id negate = id -instance ToGraph (AdjacencyMap a) where - type ToVertex (AdjacencyMap a) = a - toGraph = overlays . map (uncurry star . fmap Set.toList) . Map.toList . adjacencyMap +instance NFData a => NFData (AdjacencyMap a) where + rnf (AM a) = rnf a +-- | Construct a graph from a list of adjacency sets. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencySets [] == 'Algebra.Graph.AdjacencyMap.empty' +-- fromAdjacencySets [(x, Set.'Set.empty')] == 'Algebra.Graph.AdjacencyMap.vertex' x +-- fromAdjacencySets [(x, Set.'Set.singleton' y)] == 'Algebra.Graph.AdjacencyMap.edge' x y +-- fromAdjacencySets . map (fmap Set.'Set.fromList') . 'Algebra.Graph.AdjacencyMap.adjacencyList' == id +-- 'Algebra.Graph.AdjacencyMap.overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys) +-- @ +fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a +fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es + where + vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss + es = Map.fromListWith Set.union ss + -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices. It should be impossible to create an -- inconsistent adjacency map, and we use this function in testing. -- /Note: this function is for internal use only/. -- -- @ --- consistent 'Algebra.Graph.AdjacencyMap.empty' == True --- consistent ('Algebra.Graph.AdjacencyMap.vertex' x) == True --- consistent ('Algebra.Graph.AdjacencyMap.overlay' x y) == True --- consistent ('Algebra.Graph.AdjacencyMap.connect' x y) == True --- consistent ('Algebra.Graph.AdjacencyMap.edge' x y) == True --- consistent ('Algebra.Graph.AdjacencyMap.edges' xs) == True --- consistent ('Algebra.Graph.AdjacencyMap.graph' xs ys) == True --- consistent ('Algebra.Graph.AdjacencyMap.fromAdjacencyList' xs) == True +-- consistent 'Algebra.Graph.AdjacencyMap.empty' == True +-- consistent ('Algebra.Graph.AdjacencyMap.vertex' x) == True +-- consistent ('Algebra.Graph.AdjacencyMap.overlay' x y) == True +-- consistent ('Algebra.Graph.AdjacencyMap.connect' x y) == True +-- consistent ('Algebra.Graph.AdjacencyMap.edge' x y) == True +-- consistent ('Algebra.Graph.AdjacencyMap.edges' xs) == True +-- consistent ('Algebra.Graph.AdjacencyMap.stars' xs) == True -- @ consistent :: Ord a => AdjacencyMap a -> Bool -consistent (AM m _) = referredToVertexSet m `Set.isSubsetOf` keysSet m +consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` keysSet m -- The set of vertices that are referred to by the edges referredToVertexSet :: Ord a => Map a (Set a) -> Set a @@ -165,32 +230,3 @@ -- The list of edges in adjacency map internalEdgeList :: Map a (Set a) -> [(a, a)] internalEdgeList m = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] - --- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in --- the "Data.Graph" module of the @containers@ library. --- /Note: this data structure is for internal use only/. --- --- If @mkGraphKL (adjacencyMap g) == h@ then the following holds: --- --- @ --- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.vertexList' g --- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.edgeList' g --- @ -data GraphKL a = GraphKL { - -- | Array-based graph representation (King and Launchbury, 1995). - toGraphKL :: KL.Graph, - -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. - fromVertexKL :: KL.Vertex -> a, - -- | A mapping from vertices of type @a@ to "Data.Graph.Vertex". - -- Returns 'Nothing' if the argument is not in the graph. - toVertexKL :: a -> Maybe KL.Vertex } - --- | Build 'GraphKL' from a map of successor sets. --- /Note: this function is for internal use only/. -mkGraphKL :: Ord a => Map a (Set a) -> GraphKL a -mkGraphKL m = GraphKL - { toGraphKL = g - , fromVertexKL = \u -> case r u of (_, v, _) -> v - , toVertexKL = t } - where - (g, r, t) = KL.graphFromEdges [ ((), v, Set.toAscList us) | (v, us) <- Map.toAscList m ] diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -44,10 +44,7 @@ isSubgraphOf, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest, - - -- * Conversion between graph data types - ToGraph (..) + path, circuit, clique, biclique, star, starTranspose, tree, forest ) where import Prelude () @@ -55,6 +52,12 @@ import Data.Tree +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Fold as F +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.Relation as R + {-| The core type class for constructing algebraic graphs, characterised by the following minimal set of axioms. In equations we use @+@ and @*@ as convenient @@ -114,6 +117,41 @@ -- | Connect two graphs. connect :: g -> g -> g +instance Graph (G.Graph a) where + type Vertex (G.Graph a) = a + empty = G.empty + vertex = G.vertex + overlay = G.overlay + connect = G.connect + +instance Ord a => Graph (AM.AdjacencyMap a) where + type Vertex (AM.AdjacencyMap a) = a + empty = AM.empty + vertex = AM.vertex + overlay = AM.overlay + connect = AM.connect + +instance Graph (F.Fold a) where + type Vertex (F.Fold a) = a + empty = F.empty + vertex = F.vertex + overlay = F.overlay + connect = F.connect + +instance Graph AIM.AdjacencyIntMap where + type Vertex AIM.AdjacencyIntMap = Int + empty = AIM.empty + vertex = AIM.vertex + overlay = AIM.overlay + connect = AIM.connect + +instance Ord a => Graph (R.Relation a) where + type Vertex (R.Relation a) = a + empty = R.empty + vertex = R.vertex + overlay = R.overlay + connect = R.connect + {-| The class of /undirected graphs/ that satisfy the following additional axiom. @@ -395,7 +433,7 @@ tree :: Graph g => Tree (Vertex g) -> g tree (Node x []) = vertex x tree (Node x f ) = star x (map rootLabel f) - `overlay` forest (filter (not . null . subForest) f) + `overlay` forest (filter (not . null . subForest) f) -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the @@ -409,45 +447,3 @@ -- @ forest :: Graph g => Forest (Vertex g) -> g forest = overlays . map tree - --- | The 'ToGraph' type class captures data types that can be converted to --- polymorphic graph expressions. The conversion method 'toGraph' semantically --- acts as the identity on graph data structures, but allows to convert graphs --- between different data representations. --- --- @ --- toGraph (g :: 'Algebra.Graph.Graph' a ) :: 'Algebra.Graph.Graph' a == g --- 'show' (toGraph (1 * 2 :: 'Algebra.Graph.Graph' Int) :: 'Algebra.Graph.Relation' Int) == "edge 1 2" --- @ --- --- The second method 'foldg' is used for generalised graph folding. It recursively --- collapses a given data type by applying the provided graph construction --- primitives. The order of arguments is: empty, vertex, overlay and connect, --- and it is assumed that the functions satisfy the axioms of the algebra. --- The following law establishes the relation between 'toGraph' and 'foldg': --- --- @ --- toGraph == foldg 'empty' 'vertex' 'overlay' 'connect' --- @ -class ToGraph t where - type ToVertex t - toGraph :: (Graph g, Vertex g ~ ToVertex t) => t -> g - toGraph = foldg empty vertex overlay connect - foldg :: r -> (ToVertex t -> r) -> (r -> r -> r) -> (r -> r -> r) -> t -> r - foldg e v o c = go . toGraph - where - go E = e - go (V x ) = v x - go (O x y) = o (go x) (go y) - go (C x y) = c (go x) (go y) - --- TODO: Get rid of code duplication. Note: we do not use the data type Graph --- here due to import cycle. -data G a = E | V a | O (G a) (G a) | C (G a) (G a) - -instance Graph (G a) where - type Vertex (G a) = a - empty = E - vertex = V - overlay = O - connect = C diff --git a/src/Algebra/Graph/Export.hs b/src/Algebra/Graph/Export.hs --- a/src/Algebra/Graph/Export.hs +++ b/src/Algebra/Graph/Export.hs @@ -32,8 +32,8 @@ import Data.Semigroup import Data.String hiding (unlines) -import Algebra.Graph.AdjacencyMap -import Algebra.Graph.Class (ToGraph (..)) +import Algebra.Graph.ToGraph (ToGraph, ToVertex, toAdjacencyMap) +import Algebra.Graph.AdjacencyMap (vertexList, edgeList) import Algebra.Graph.Internal -- | An abstract document data type with /O(1)/ time concatenation (the current @@ -159,8 +159,8 @@ -- 2 -> 4 -- @ export :: (Ord a, ToGraph g, ToVertex g ~ a) => (a -> Doc s) -> (a -> a -> Doc s) -> g -> Doc s -export vs es g = vDoc <> eDoc +export v e g = vDoc <> eDoc where - vDoc = mconcat $ map vs (vertexList adjMap) - eDoc = mconcat $ map (uncurry es) (edgeList adjMap) - adjMap = toGraph g + vDoc = mconcat $ map v (vertexList adjMap) + eDoc = mconcat $ map (uncurry e) (edgeList adjMap) + adjMap = toAdjacencyMap g diff --git a/src/Algebra/Graph/Export/Dot.hs b/src/Algebra/Graph/Export/Dot.hs --- a/src/Algebra/Graph/Export/Dot.hs +++ b/src/Algebra/Graph/Export/Dot.hs @@ -26,7 +26,7 @@ import Data.String hiding (unlines) import Prelude hiding (unlines) -import Algebra.Graph.Class (ToGraph (..)) +import Algebra.Graph.ToGraph (ToGraph (..)) import Algebra.Graph.Export hiding (export) import qualified Algebra.Graph.Export as E @@ -124,7 +124,7 @@ vDoc x = line $ label x <+> attributes (vertexAttributes x) eDoc x y = line $ label x <> " -> " <> label y <+> attributes (edgeAttributes x y) --- A list of attributes formatted as a DOT document. +-- | A list of attributes formatted as a DOT document. -- Example: @attributes ["label" := "A label", "shape" := "box"]@ -- corresponds to document: @ [label="A label" shape="box"]@. attributes :: IsString s => [Attribute s] -> Doc s diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs --- a/src/Algebra/Graph/Fold.hs +++ b/src/Algebra/Graph/Fold.hs @@ -29,40 +29,37 @@ foldg, -- * Relations on graphs - C.isSubgraphOf, + isSubgraphOf, -- * Graph properties isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, vertexIntSet, edgeSet, + edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList, -- * Standard families of graphs - C.path, C.circuit, C.clique, C.biclique, C.star, C.starTranspose, C.tree, - C.forest, mesh, torus, deBruijn, + path, circuit, clique, biclique, star, stars, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex, - transpose, gmap, bind, induce, simplify, - - -- * Graph composition - box + removeVertex, removeEdge, transpose, induce, simplify, ) where import Prelude () import Prelude.Compat -import Control.Applicative hiding (empty) +import Control.Applicative (Alternative, liftA2) import Control.Monad.Compat (MonadPlus (..), ap) -import Data.Foldable +import Data.Function -import Algebra.Graph.Internal +import Control.DeepSeq (NFData (..)) -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.HigherKinded.Class as H -import qualified Algebra.Graph.Relation as R -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set +import Algebra.Graph.ToGraph (ToGraph, ToVertex, toGraph) +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.ToGraph as T +import qualified Control.Applicative as Ap +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set + {-| The 'Fold' data type is the Boehm-Berarducci encoding of the core graph construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a 'Num' instance as a convenient notation for working with graphs: @@ -150,17 +147,13 @@ newtype Fold a = Fold { runFold :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b } instance (Ord a, Show a) => Show (Fold a) where - show f = show (C.toGraph f :: AM.AdjacencyMap a) + show = show . foldg AM.empty AM.vertex AM.overlay AM.connect instance Ord a => Eq (Fold a) where - x == y = C.toGraph x == (C.toGraph y :: AM.AdjacencyMap a) + x == y = T.adjacencyMap x == T.adjacencyMap y -instance C.Graph (Fold a) where - type Vertex (Fold a) = a - empty = Fold $ \e _ _ _ -> e - vertex x = Fold $ \_ v _ _ -> v x - overlay x y = Fold $ \e v o c -> runFold x e v o c `o` runFold y e v o c - connect x y = Fold $ \e v o c -> runFold x e v o c `c` runFold y e v o c +instance NFData a => NFData (Fold a) where + rnf = foldg () rnf seq seq instance Num a => Num (Fold a) where fromInteger = vertex . fromInteger @@ -171,7 +164,7 @@ negate = id instance Functor Fold where - fmap = gmap + fmap f = foldg empty (vertex . f) overlay connect instance Applicative Fold where pure = vertex @@ -187,10 +180,7 @@ instance Monad Fold where return = vertex - (>>=) = bind - -instance H.Graph Fold where - connect = connect + g >>=f = foldg empty f overlay connect g instance Foldable Fold where foldMap f = foldg mempty f mappend mappend @@ -198,12 +188,9 @@ instance Traversable Fold where traverse f = foldg (pure empty) (fmap vertex . f) (liftA2 overlay) (liftA2 connect) -instance C.ToGraph (Fold a) where +instance ToGraph (Fold a) where type ToVertex (Fold a) = a - foldg e v o c g = runFold g e v o c - -instance H.ToGraph Fold where - toGraph = foldg H.empty H.vertex H.overlay H.connect + foldg = foldg -- | Construct the /empty graph/. -- Complexity: /O(1)/ time, memory and size. @@ -215,8 +202,9 @@ -- 'edgeCount' empty == 0 -- 'size' empty == 1 -- @ -empty :: C.Graph g => g -empty = C.empty +empty :: Fold a +empty = Fold $ \e _ _ _ -> e +{-# NOINLINE [1] empty #-} -- | Construct the graph comprising /a single isolated vertex/. -- Complexity: /O(1)/ time, memory and size. @@ -228,8 +216,9 @@ -- 'edgeCount' (vertex x) == 0 -- 'size' (vertex x) == 1 -- @ -vertex :: C.Graph g => C.Vertex g -> g -vertex = C.vertex +vertex :: a -> Fold a +vertex x = Fold $ \_ v _ _ -> v x +{-# NOINLINE [1] vertex #-} -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory and size. @@ -241,8 +230,8 @@ -- 'vertexCount' (edge 1 1) == 1 -- 'vertexCount' (edge 1 2) == 2 -- @ -edge :: C.Graph g => C.Vertex g -> C.Vertex g -> g -edge = C.edge +edge :: a -> a -> Fold a +edge x y = Fold $ \_ v _ c -> v x `c` v y -- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. @@ -259,8 +248,9 @@ -- 'vertexCount' (overlay 1 2) == 2 -- 'edgeCount' (overlay 1 2) == 0 -- @ -overlay :: C.Graph g => g -> g -> g -overlay = C.overlay +overlay :: Fold a -> Fold a -> Fold a +overlay x y = Fold $ \e v o c -> runFold x e v o c `o` runFold y e v o c +{-# NOINLINE [1] overlay #-} -- | /Connect/ two graphs. This is an associative operation with the identity -- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. @@ -281,8 +271,9 @@ -- 'vertexCount' (connect 1 2) == 2 -- 'edgeCount' (connect 1 2) == 1 -- @ -connect :: C.Graph g => g -> g -> g -connect = C.connect +connect :: Fold a -> Fold a -> Fold a +connect x y = Fold $ \e v o c -> runFold x e v o c `c` runFold y e v o c +{-# NOINLINE [1] connect #-} -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -295,8 +286,9 @@ -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ -vertices :: C.Graph g => [C.Vertex g] -> g -vertices = C.vertices +vertices :: [a] -> Fold a +vertices = overlays . map vertex +{-# NOINLINE [1] vertices #-} -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -307,8 +299,8 @@ -- edges [(x,y)] == 'edge' x y -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ -edges :: C.Graph g => [(C.Vertex g, C.Vertex g)] -> g -edges = C.edges +edges :: [(a, a)] -> Fold a +edges es = Fold $ \e v o c -> foldr (flip o . uncurry (c `on` v)) e es -- | Overlay a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -321,8 +313,9 @@ -- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ -overlays :: C.Graph g => [g] -> g -overlays = C.overlays +overlays :: [Fold a] -> Fold a +overlays = foldr overlay empty +{-# INLINE [2] overlays #-} -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -335,10 +328,11 @@ -- connects == 'foldr' 'connect' 'empty' -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ -connects :: C.Graph g => [g] -> g -connects = C.connects +connects :: [Fold a] -> Fold a +connects = foldr connect empty +{-# INLINE [2] connects #-} --- | Generalised graph folding: recursively collapse a 'Fold' by applying +-- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying -- the provided functions to the leaves and internal nodes of the expression. -- The order of arguments is: empty, vertex, overlay and connect. -- Complexity: /O(s)/ applications of given functions. As an example, the @@ -353,8 +347,23 @@ -- foldg True (const False) (&&) (&&) == 'isEmpty' -- @ foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Fold a -> b -foldg = C.foldg +foldg e v o c g = runFold g e v o c +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- @ +isSubgraphOf :: Ord a => Fold a -> Fold a -> Bool +isSubgraphOf x y = overlay x y == y + -- | Check if a graph is empty. A convenient alias for 'null'. -- Complexity: /O(s)/ time. -- @@ -366,7 +375,7 @@ -- isEmpty ('removeEdge' x y $ 'edge' x y) == False -- @ isEmpty :: Fold a -> Bool -isEmpty = H.isEmpty +isEmpty = T.isEmpty -- | The /size/ of a graph, i.e. the number of leaves of the expression -- including 'empty' leaves. @@ -381,7 +390,7 @@ -- size x >= 'vertexCount' x -- @ size :: Fold a -> Int -size = foldg 1 (const 1) (+) (+) +size = T.size -- | Check if a graph contains a given vertex. A convenient alias for `elem`. -- Complexity: /O(s)/ time. @@ -393,7 +402,7 @@ -- hasVertex x . 'removeVertex' x == const False -- @ hasVertex :: Eq a => a -> Fold a -> Bool -hasVertex = H.hasVertex +hasVertex = T.hasVertex -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. @@ -405,8 +414,8 @@ -- hasEdge x y . 'removeEdge' x y == const False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -hasEdge :: Ord a => a -> a -> Fold a -> Bool -hasEdge = H.hasEdge +hasEdge :: Eq a => a -> a -> Fold a -> Bool +hasEdge = T.hasEdge -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. @@ -417,7 +426,7 @@ -- vertexCount == 'length' . 'vertexList' -- @ vertexCount :: Ord a => Fold a -> Int -vertexCount = length . vertexList +vertexCount = T.vertexCount -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a @@ -430,7 +439,7 @@ -- edgeCount == 'length' . 'edgeList' -- @ edgeCount :: Ord a => Fold a -> Int -edgeCount = length . edgeList +edgeCount = T.edgeCount -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -441,7 +450,7 @@ -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ vertexList :: Ord a => Fold a -> [a] -vertexList = Set.toAscList . vertexSet +vertexList = T.vertexList -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of @@ -456,7 +465,7 @@ -- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList -- @ edgeList :: Ord a => Fold a -> [(a, a)] -edgeList = AM.edgeList . C.toGraph +edgeList = T.edgeList -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -468,7 +477,7 @@ -- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Ord a => Fold a -> Set.Set a -vertexSet = H.vertexSet +vertexSet = T.vertexSet -- | The set of vertices of a given graph. Like 'vertexSet' but specialised for -- graphs with vertices of type 'Int'. @@ -481,7 +490,7 @@ -- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' -- @ vertexIntSet :: Fold Int -> IntSet.IntSet -vertexIntSet = H.vertexIntSet +vertexIntSet = T.vertexIntSet -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. @@ -493,62 +502,116 @@ -- edgeSet . 'edges' == Set.'Set.fromList' -- @ edgeSet :: Ord a => Fold a -> Set.Set (a, a) -edgeSet = R.edgeSet . C.toGraph +edgeSet = T.edgeSet --- | Construct a /mesh graph/ from two lists of vertices. --- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the --- lengths of the given lists. +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. -- -- @ --- mesh xs [] == 'empty' --- mesh [] ys == 'empty' --- mesh [x] [y] == 'vertex' (x, y) --- mesh xs ys == 'box' ('path' xs) ('path' ys) --- mesh [1..3] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\')) --- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ] +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] +-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] +-- 'stars' . adjacencyList == id -- @ -mesh :: (C.Graph g, C.Vertex g ~ (a, b)) => [a] -> [b] -> g -mesh xs ys = C.path xs `box` C.path ys +adjacencyList :: Ord a => Fold a -> [(a, [a])] +adjacencyList = T.adjacencyList --- | Construct a /torus graph/ from two lists of vertices. --- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the +-- | The /path/ on a list of vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- path [] == 'empty' +-- path [x] == 'vertex' x +-- path [x,y] == 'edge' x y +-- path . 'reverse' == 'transpose' . path +-- @ +path :: [a] -> Fold a +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- circuit [] == 'empty' +-- circuit [x] == 'edge' x x +-- circuit [x,y] == 'edges' [(x,y), (y,x)] +-- circuit . 'reverse' == 'transpose' . circuit +-- @ +circuit :: [a] -> Fold a +circuit [] = empty +circuit (x:xs) = path $ [x] ++ xs ++ [x] + +-- | The /clique/ on a list of vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique . 'reverse' == 'transpose' . clique +-- @ +clique :: [a] -> Fold a +clique = connects . map vertex +{-# NOINLINE [1] clique #-} + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. -- -- @ --- torus xs [] == 'empty' --- torus [] ys == 'empty' --- torus [x] [y] == 'edge' (x, y) (x, y) --- torus xs ys == 'box' ('circuit' xs) ('circuit' ys) --- torus [1,2] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\')) --- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] +-- biclique [] [] == 'empty' +-- biclique [x] [] == 'vertex' x +-- biclique [] [y] == 'vertex' y +-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ -torus :: (C.Graph g, C.Vertex g ~ (a, b)) => [a] -> [b] -> g -torus xs ys = C.circuit xs `box` C.circuit ys +biclique :: [a] -> [a] -> Fold a +biclique xs [] = vertices xs +biclique [] ys = vertices ys +biclique xs ys = connect (vertices xs) (vertices ys) --- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols --- from a given alphabet. --- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the --- alphabet and /D/ is the dimension of the graph. +-- | The /star/ formed by a centre vertex connected to a list of leaves. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. -- -- @ --- deBruijn 0 xs == 'edge' [] [] --- n > 0 ==> deBruijn n [] == 'empty' --- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] --- deBruijn 2 "0" == 'edge' "00" "00" --- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") --- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] --- 'transpose' (deBruijn n xs) == 'gmap' 'reverse' $ deBruijn n xs --- 'vertexCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^n --- n > 0 ==> 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) +-- star x [] == 'vertex' x +-- star x [y] == 'edge' x y +-- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ -deBruijn :: (C.Graph g, C.Vertex g ~ [a]) => Int -> [a] -> g -deBruijn 0 _ = edge [] [] -deBruijn len alphabet = bind skeleton expand - where - overlaps = mapM (const alphabet) [2..len] - skeleton = C.edges [ (Left s, Right s) | s <- overlaps ] - expand v = C.vertices [ either ([a] ++) (++ [a]) v | a <- alphabet ] +star :: a -> [a] -> Fold a +star x [] = vertex x +star x ys = connect (vertex x) (vertices ys) +{-# INLINE star #-} +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the +-- input. +-- +-- @ +-- stars [] == 'empty' +-- stars [(x, [])] == 'vertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . map (uncurry 'star') +-- stars . 'adjacencyList' == id +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) +-- @ +stars :: [(a, [a])] -> Fold a +stars = overlays . map (uncurry star) +{-# INLINE stars #-} + -- | Remove a vertex from a given graph. -- Complexity: /O(s)/ time, memory and size. -- @@ -559,71 +622,30 @@ -- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ -removeVertex :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> Fold (C.Vertex g) -> g +removeVertex :: Eq a => a -> Fold a -> Fold a removeVertex v = induce (/= v) -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size. -- -- @ --- removeEdge x y ('edge' x y) == 'vertices' [x, y] +-- removeEdge x y ('edge' x y) == 'vertices' [x,y] -- removeEdge x y . removeEdge x y == removeEdge x y -- removeEdge x y . 'removeVertex' x == 'removeVertex' x -- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ -removeEdge :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> C.Vertex g -> Fold (C.Vertex g) -> g +removeEdge :: Eq a => a -> a -> Fold a -> Fold a removeEdge s t = filterContext s (/=s) (/=t) -- TODO: Export -- | Filter vertices in a subgraph context. -filterContext :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> (C.Vertex g -> Bool) - -> (C.Vertex g -> Bool) -> Fold (C.Vertex g) -> g -filterContext s i o g = maybe (C.toGraph g) go $ context (==s) g +filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Fold a -> Fold a +filterContext s i o g = maybe g go $ G.context (==s) (toGraph g) where - go (Context is os) = overlays [ induce (/=s) g - , C.starTranspose s (filter i is) - , C.star s (filter o os) ] - --- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a --- given graph expression. If @y@ already exists, @x@ and @y@ will be merged. --- Complexity: /O(s)/ time, memory and size. --- --- @ --- replaceVertex x x == id --- replaceVertex x y ('vertex' x) == 'vertex' y --- replaceVertex x y == 'mergeVertices' (== x) y --- @ -replaceVertex :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> C.Vertex g -> Fold (C.Vertex g) -> g -replaceVertex u v = gmap $ \w -> if w == u then v else w - --- | Merge vertices satisfying a given predicate into a given vertex. --- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. --- --- @ --- mergeVertices (const False) x == id --- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 --- @ -mergeVertices :: C.Graph g => (C.Vertex g -> Bool) -> C.Vertex g -> Fold (C.Vertex g) -> g -mergeVertices p v = gmap $ \u -> if p u then v else u - --- | Split a vertex into a list of vertices with the same connectivity. --- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of --- occurrences of the vertex in the expression and /L/ is the length of the --- given list. --- --- @ --- splitVertex x [] == 'removeVertex' x --- splitVertex x [x] == id --- splitVertex x [y] == 'replaceVertex' x y --- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) --- @ -splitVertex :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> [C.Vertex g] -> Fold (C.Vertex g) -> g -splitVertex v vs g = bind g $ \u -> if u == v then C.vertices vs else C.vertex u + go (G.Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is)) + `overlay` star s (filter o os) -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -636,38 +658,23 @@ -- transpose ('box' x y) == 'box' (transpose x) (transpose y) -- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ -transpose :: C.Graph g => Fold (C.Vertex g) -> g -transpose = foldg C.empty C.vertex C.overlay (flip C.connect) +transpose :: Fold a -> Fold a +transpose = foldg empty vertex overlay (flip connect) +{-# NOINLINE [1] transpose #-} --- | Transform a given graph by applying a function to each of its vertices. --- This is similar to 'fmap' but can be used with non-fully-parametric graphs. --- --- @ --- gmap f 'empty' == 'empty' --- gmap f ('vertex' x) == 'vertex' (f x) --- gmap f ('edge' x y) == 'edge' (f x) (f y) --- gmap id == id --- gmap f . gmap g == gmap (f . g) --- @ -gmap :: C.Graph g => (a -> C.Vertex g) -> Fold a -> g -gmap f = foldg C.empty (C.vertex . f) C.overlay C.connect +{-# RULES +"transpose/empty" transpose empty = empty +"transpose/vertex" forall x. transpose (vertex x) = vertex x +"transpose/overlay" forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2) +"transpose/connect" forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1) --- | Transform a given graph by substituting each of its vertices with a subgraph. --- This is similar to Monad's bind '>>=' but can be used with non-fully-parametric --- graphs. --- --- @ --- bind 'empty' f == 'empty' --- bind ('vertex' x) f == f x --- bind ('edge' x y) f == 'connect' (f x) (f y) --- bind ('vertices' xs) f == 'overlays' ('map' f xs) --- bind x (const 'empty') == 'empty' --- bind x 'vertex' == x --- bind (bind x f) g == bind x (\\y -> bind (f y) g) --- @ -bind :: C.Graph g => Fold a -> (a -> g) -> g -bind g f = foldg C.empty f C.overlay C.connect g +"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs) +"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs)) +"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs +"transpose/clique" forall xs. transpose (clique xs) = clique (reverse xs) + #-} + -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes @@ -680,8 +687,8 @@ -- induce p . induce q == induce (\\x -> p x && q x) -- 'isSubgraphOf' (induce p x) x == True -- @ -induce :: C.Graph g => (C.Vertex g -> Bool) -> Fold (C.Vertex g) -> g -induce p = C.toGraph . foldg empty (\x -> if p x then vertex x else empty) (k overlay) (k connect) +induce :: (a -> Bool) -> Fold a -> Fold a +induce p = foldg empty (\x -> if p x then vertex x else empty) (k overlay) (k connect) where k f x y | isEmpty x = y -- Constant folding to get rid of Empty leaves | isEmpty y = x @@ -704,8 +711,8 @@ -- simplify (1 + 2 + 1) ~> 1 + 2 -- simplify (1 * 1 * 1) ~> 1 * 1 -- @ -simplify :: (Eq g, C.Graph g) => Fold (C.Vertex g) -> g -simplify = foldg C.empty C.vertex (simple C.overlay) (simple C.connect) +simplify :: Ord a => Fold a -> Fold a +simplify = foldg empty vertex (simple overlay) (simple connect) simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y @@ -714,34 +721,3 @@ | otherwise = z where z = op x y - --- | Compute the /Cartesian product/ of graphs. --- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the --- sizes of the given graphs. --- --- @ --- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\')) --- , ((0,\'a\'), (1,\'a\')) --- , ((0,\'b\'), (1,\'b\')) --- , ((1,\'a\'), (1,\'b\')) ] --- @ --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton --- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@ --- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. --- --- @ --- box x y ~~ box y x --- box x (box y z) ~~ box (box x y) z --- box x ('overlay' y z) == 'overlay' (box x y) (box x z) --- box x ('vertex' ()) ~~ x --- box x 'empty' ~~ 'empty' --- 'transpose' (box x y) == box ('transpose' x) ('transpose' y) --- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y --- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y --- @ -box :: (C.Graph g, C.Vertex g ~ (a, b)) => Fold a -> Fold b -> g -box x y = C.overlays $ xs ++ ys - where - xs = map (\b -> gmap (,b) x) $ toList y - ys = map (\a -> gmap (a,) y) $ toList x diff --git a/src/Algebra/Graph/HigherKinded/Class.hs b/src/Algebra/Graph/HigherKinded/Class.hs --- a/src/Algebra/Graph/HigherKinded/Class.hs +++ b/src/Algebra/Graph/HigherKinded/Class.hs @@ -53,11 +53,7 @@ removeVertex, replaceVertex, mergeVertices, splitVertex, induce, -- * Graph composition - box, - - -- * Conversion between graph data types - ToGraph (..) - + box ) where import Prelude () @@ -68,8 +64,10 @@ import Data.Foldable (toList) import Data.Tree -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Fold as F +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set {-| The core type class for constructing algebraic graphs is defined by introducing @@ -138,6 +136,12 @@ -- | Connect two graphs. connect :: g a -> g a -> g a +instance Graph G.Graph where + connect = G.connect + +instance Graph F.Fold where + connect = F.connect + -- | Construct the graph comprising a single isolated vertex. An alias for 'pure'. vertex :: Graph g => a -> g a vertex = pure @@ -212,7 +216,9 @@ -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: Graph g => [a] -> g a -vertices = overlays . map vertex +vertices [] = empty +vertices [x] = vertex x +vertices (x:xs) = vertex x `overlay` vertices xs -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -495,7 +501,7 @@ -- @ -- torus xs [] == 'empty' -- torus [] ys == 'empty' --- torus [x] [y] == 'edge' (x, y) (x, y) +-- torus [x] [y] == 'edge' (x,y) (x,y) -- torus xs ys == 'box' ('circuit' xs) ('circuit' ys) -- torus [1,2] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\')) -- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] @@ -623,15 +629,3 @@ where xs = map (\b -> fmap (,b) x) $ toList y ys = map (\a -> fmap (a,) y) $ toList x - --- | The 'ToGraph' type class captures data types that can be converted to --- polymorphic graph expressions. The conversion method 'toGraph' semantically --- acts as the identity on graph data structures, but allows to convert graphs --- between different data representations. --- --- @ --- toGraph (g :: 'Algebra.Graph.Graph' a ) :: 'Algebra.Graph.Graph' a == g --- 'show' (toGraph (1 * 2 :: 'Algebra.Graph.Graph' Int) :: 'Algebra.Graph.Fold' Int) == "edge 1 2" --- @ -class ToGraph t where - toGraph :: Graph g => t a -> g a diff --git a/src/Algebra/Graph/IntAdjacencyMap.hs b/src/Algebra/Graph/IntAdjacencyMap.hs deleted file mode 100644 --- a/src/Algebra/Graph/IntAdjacencyMap.hs +++ /dev/null @@ -1,646 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.IntAdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- __Alga__ is a library for algebraic construction and manipulation of graphs --- in Haskell. See for the --- motivation behind the library, the underlying theory, and implementation details. --- --- This module defines the 'IntAdjacencyMap' data type, as well as associated --- operations and algorithms. 'IntAdjacencyMap' is an instance of the 'C.Graph' --- type class, which can be used for polymorphic graph construction --- and manipulation. See "Algebra.Graph.AdjacencyMap" for graphs with --- non-@Int@ vertices. ------------------------------------------------------------------------------ -module Algebra.Graph.IntAdjacencyMap ( - -- * Data structure - IntAdjacencyMap, adjacencyMap, - - -- * Basic graph construction primitives - empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - fromAdjacencyList, - - -- * Relations on graphs - isSubgraphOf, - - -- * Graph properties - isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexIntSet, edgeSet, postIntSet, - - -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest, - - -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, - - -- * Algorithms - dfsForest, dfsForestFrom, dfs, topSort, isTopSort - ) where - -import Data.IntSet (IntSet) -import Data.Maybe -import Data.Set (Set) -import Data.Tree - -import Algebra.Graph.IntAdjacencyMap.Internal - -import qualified Algebra.Graph.Class as C -import qualified Data.Graph as KL -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'isEmpty' empty == True --- 'hasVertex' x empty == False --- 'vertexCount' empty == 0 --- 'edgeCount' empty == 0 --- @ -empty :: IntAdjacencyMap -empty = C.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True --- 'vertexCount' (vertex x) == 1 --- 'edgeCount' (vertex x) == 0 --- @ -vertex :: Int -> IntAdjacencyMap -vertex = C.vertex - --- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory. --- --- @ --- edge x y == 'connect' ('vertex' x) ('vertex' y) --- 'hasEdge' x y (edge x y) == True --- 'edgeCount' (edge x y) == 1 --- 'vertexCount' (edge 1 1) == 1 --- 'vertexCount' (edge 1 2) == 2 --- @ -edge :: Int -> Int -> IntAdjacencyMap -edge = C.edge - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (overlay x y) >= 'vertexCount' x --- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (overlay x y) >= 'edgeCount' x --- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y --- 'vertexCount' (overlay 1 2) == 2 --- 'edgeCount' (overlay 1 2) == 0 --- @ -overlay :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap -overlay = C.overlay - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (connect x y) >= 'vertexCount' x --- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (connect x y) >= 'edgeCount' x --- 'edgeCount' (connect x y) >= 'edgeCount' y --- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y --- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y --- 'vertexCount' (connect 1 2) == 2 --- 'edgeCount' (connect 1 2) == 1 --- @ -connect :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap -connect = C.connect - --- | Construct the graph comprising a given list of isolated vertices. --- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length --- of the given list. --- --- @ --- vertices [] == 'empty' --- vertices [x] == 'vertex' x --- 'hasVertex' x . vertices == 'elem' x --- 'vertexCount' . vertices == 'length' . 'Data.List.nub' --- 'vertexIntSet' . vertices == IntSet.'IntSet.fromList' --- @ -vertices :: [Int] -> IntAdjacencyMap -vertices = mkAM . IntMap.fromList . map (\x -> (x, IntSet.empty)) - --- | Construct the graph from a list of edges. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- edges [] == 'empty' --- edges [(x, y)] == 'edge' x y --- 'edgeCount' . edges == 'length' . 'Data.List.nub' --- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' --- @ -edges :: [(Int, Int)] -> IntAdjacencyMap -edges = fromAdjacencyList . map (fmap return) - --- | Overlay a given list of graphs. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- overlays [] == 'empty' --- overlays [x] == x --- overlays [x,y] == 'overlay' x y --- overlays == 'foldr' 'overlay' 'empty' --- 'isEmpty' . overlays == 'all' 'isEmpty' --- @ -overlays :: [IntAdjacencyMap] -> IntAdjacencyMap -overlays = C.overlays - --- | Connect a given list of graphs. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- connects [] == 'empty' --- connects [x] == x --- connects [x,y] == 'connect' x y --- connects == 'foldr' 'connect' 'empty' --- 'isEmpty' . connects == 'all' 'isEmpty' --- @ -connects :: [IntAdjacencyMap] -> IntAdjacencyMap -connects = C.connects - --- | Construct a graph from an adjacency list. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyList [] == 'empty' --- fromAdjacencyList [(x, [])] == 'vertex' x --- fromAdjacencyList [(x, [y])] == 'edge' x y --- fromAdjacencyList . 'adjacencyList' == id --- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) --- @ -fromAdjacencyList :: [(Int, [Int])] -> IntAdjacencyMap -fromAdjacencyList as = mkAM $ IntMap.unionWith IntSet.union vs es - where - ss = map (fmap IntSet.fromList) as - vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss - es = IntMap.fromListWith IntSet.union ss - --- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the --- first graph is a /subgraph/ of the second. --- Complexity: /O((n + m) * log(n))/ time. --- --- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True --- @ -isSubgraphOf :: IntAdjacencyMap -> IntAdjacencyMap -> Bool -isSubgraphOf x y = IntMap.isSubmapOfBy IntSet.isSubsetOf (adjacencyMap x) (adjacencyMap y) - --- | Check if a graph is empty. --- Complexity: /O(1)/ time. --- --- @ --- isEmpty 'empty' == True --- isEmpty ('overlay' 'empty' 'empty') == True --- isEmpty ('vertex' x) == False --- isEmpty ('removeVertex' x $ 'vertex' x) == True --- isEmpty ('removeEdge' x y $ 'edge' x y) == False --- @ -isEmpty :: IntAdjacencyMap -> Bool -isEmpty = IntMap.null . adjacencyMap - --- | Check if a graph contains a given vertex. --- Complexity: /O(log(n))/ time. --- --- @ --- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False --- @ -hasVertex :: Int -> IntAdjacencyMap -> Bool -hasVertex x = IntMap.member x . adjacencyMap - --- | Check if a graph contains a given edge. --- Complexity: /O(log(n))/ time. --- --- @ --- hasEdge x y 'empty' == False --- hasEdge x y ('vertex' z) == False --- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False --- hasEdge x y == 'elem' (x,y) . 'edgeList' --- @ -hasEdge :: Int -> Int -> IntAdjacencyMap -> Bool -hasEdge u v a = case IntMap.lookup u (adjacencyMap a) of - Nothing -> False - Just vs -> IntSet.member v vs - --- | The number of vertices in a graph. --- Complexity: /O(1)/ time. --- --- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' --- @ -vertexCount :: IntAdjacencyMap -> Int -vertexCount = IntMap.size . adjacencyMap - --- | The number of edges in a graph. --- Complexity: /O(n)/ time. --- --- @ --- edgeCount 'empty' == 0 --- edgeCount ('vertex' x) == 0 --- edgeCount ('edge' x y) == 1 --- edgeCount == 'length' . 'edgeList' --- @ -edgeCount :: IntAdjacencyMap -> Int -edgeCount = IntMap.foldr (\es r -> (IntSet.size es + r)) 0 . adjacencyMap - --- | The sorted list of vertices of a given graph. --- Complexity: /O(n)/ time and memory. --- --- @ --- vertexList 'empty' == [] --- vertexList ('vertex' x) == [x] --- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' --- @ -vertexList :: IntAdjacencyMap -> [Int] -vertexList = IntMap.keys . adjacencyMap - --- | The sorted list of edges of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- edgeList 'empty' == [] --- edgeList ('vertex' x) == [] --- edgeList ('edge' x y) == [(x,y)] --- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] --- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList --- @ -edgeList :: IntAdjacencyMap -> [(Int, Int)] -edgeList (AM m _) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] - --- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- adjacencyList 'empty' == [] --- adjacencyList ('vertex' x) == [(x, [])] --- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] --- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] --- 'fromAdjacencyList' . adjacencyList == id --- @ -adjacencyList :: IntAdjacencyMap -> [(Int, [Int])] -adjacencyList = map (fmap IntSet.toAscList) . IntMap.toAscList . adjacencyMap - --- | The set of vertices of a given graph. --- Complexity: /O(n)/ time and memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: IntAdjacencyMap -> IntSet -vertexIntSet = IntMap.keysSet . adjacencyMap - --- | The set of edges of a given graph. --- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. --- --- @ --- edgeSet 'empty' == Set.'Set.empty' --- edgeSet ('vertex' x) == Set.'Set.empty' --- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) --- edgeSet . 'edges' == Set.'Set.fromList' --- @ -edgeSet :: IntAdjacencyMap -> Set (Int, Int) -edgeSet = IntMap.foldrWithKey combine Set.empty . adjacencyMap - where - combine u es = Set.union (Set.fromAscList [ (u, v) | v <- IntSet.toAscList es ]) - --- | The /postset/ (here 'postIntSet') of a vertex is the set of its /direct successors/. --- --- @ --- postIntSet x 'empty' == IntSet.'IntSet.empty' --- postIntSet x ('vertex' x) == IntSet.'IntSet.empty' --- postIntSet x ('edge' x y) == IntSet.'IntSet.fromList' [y] --- postIntSet 2 ('edge' 1 2) == IntSet.'IntSet.empty' --- @ -postIntSet :: Int -> IntAdjacencyMap -> IntSet -postIntSet x = IntMap.findWithDefault IntSet.empty x . adjacencyMap - --- | The /path/ on a list of vertices. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- path [] == 'empty' --- path [x] == 'vertex' x --- path [x,y] == 'edge' x y --- path . 'reverse' == 'transpose' . path --- @ -path :: [Int] -> IntAdjacencyMap -path = C.path - --- | The /circuit/ on a list of vertices. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- circuit [] == 'empty' --- circuit [x] == 'edge' x x --- circuit [x,y] == 'edges' [(x,y), (y,x)] --- circuit . 'reverse' == 'transpose' . circuit --- @ -circuit :: [Int] -> IntAdjacencyMap -circuit = C.circuit - --- | The /clique/ on a list of vertices. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- clique [] == 'empty' --- clique [x] == 'vertex' x --- clique [x,y] == 'edge' x y --- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] --- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) --- clique . 'reverse' == 'transpose' . clique --- @ -clique :: [Int] -> IntAdjacencyMap -clique = C.clique - --- | The /biclique/ on two lists of vertices. --- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. --- --- @ --- biclique [] [] == 'empty' --- biclique [x] [] == 'vertex' x --- biclique [] [y] == 'vertex' y --- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] --- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) --- @ -biclique :: [Int] -> [Int] -> IntAdjacencyMap -biclique xs ys = mkAM $ IntMap.fromSet adjacent (x `IntSet.union` y) - where - x = IntSet.fromList xs - y = IntSet.fromList ys - adjacent v - | v `IntSet.member` x = y - | otherwise = IntSet.empty - --- | The /star/ formed by a centre vertex connected to a list of leaves. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- star x [] == 'vertex' x --- star x [y] == 'edge' x y --- star x [y,z] == 'edges' [(x,y), (x,z)] --- star x ys == 'connect' ('vertex' x) ('vertices' ys) --- @ -star :: Int -> [Int] -> IntAdjacencyMap -star = C.star - --- | The /star transpose/ formed by a list of leaves connected to a centre vertex. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- starTranspose x [] == 'vertex' x --- starTranspose x [y] == 'edge' y x --- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] --- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) --- starTranspose x ys == 'transpose' ('star' x ys) --- @ -starTranspose :: Int -> [Int] -> IntAdjacencyMap -starTranspose = C.starTranspose - --- | The /tree graph/ constructed from a given 'Tree' data structure. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- tree (Node x []) == 'vertex' x --- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] --- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] --- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] --- @ -tree :: Tree Int -> IntAdjacencyMap -tree = C.tree - --- | The /forest graph/ constructed from a given 'Forest' data structure. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- forest [] == 'empty' --- forest [x] == 'tree' x --- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' --- @ -forest :: Forest Int -> IntAdjacencyMap -forest = C.forest - --- | Remove a vertex from a given graph. --- Complexity: /O(n*log(n))/ time. --- --- @ --- removeVertex x ('vertex' x) == 'empty' --- removeVertex 1 ('vertex' 2) == 'vertex' 2 --- removeVertex x ('edge' x x) == 'empty' --- removeVertex 1 ('edge' 1 2) == 'vertex' 2 --- removeVertex x . removeVertex x == removeVertex x --- @ -removeVertex :: Int -> IntAdjacencyMap -> IntAdjacencyMap -removeVertex x = mkAM . IntMap.map (IntSet.delete x) . IntMap.delete x . adjacencyMap - --- | Remove an edge from a given graph. --- Complexity: /O(log(n))/ time. --- --- @ --- removeEdge x y ('edge' x y) == 'vertices' [x, y] --- removeEdge x y . removeEdge x y == removeEdge x y --- removeEdge x y . 'removeVertex' x == 'removeVertex' x --- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 --- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 --- @ -removeEdge :: Int -> Int -> IntAdjacencyMap -> IntAdjacencyMap -removeEdge x y = mkAM . IntMap.adjust (IntSet.delete y) x . adjacencyMap - --- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a --- given 'IntAdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. --- Complexity: /O((n + m) * log(n))/ time. --- --- @ --- replaceVertex x x == id --- replaceVertex x y ('vertex' x) == 'vertex' y --- replaceVertex x y == 'mergeVertices' (== x) y --- @ -replaceVertex :: Int -> Int -> IntAdjacencyMap -> IntAdjacencyMap -replaceVertex u v = gmap $ \w -> if w == u then v else w - --- | Merge vertices satisfying a given predicate into a given vertex. --- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes --- /O(1)/ to be evaluated. --- --- @ --- mergeVertices (const False) x == id --- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 --- @ -mergeVertices :: (Int -> Bool) -> Int -> IntAdjacencyMap -> IntAdjacencyMap -mergeVertices p v = gmap $ \u -> if p u then v else u - --- | Transpose a given graph. --- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. --- --- @ --- transpose 'empty' == 'empty' --- transpose ('vertex' x) == 'vertex' x --- transpose ('edge' x y) == 'edge' y x --- transpose . transpose == id --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' --- @ -transpose :: IntAdjacencyMap -> IntAdjacencyMap -transpose (AM m _) = mkAM $ IntMap.foldrWithKey combine vs m - where - combine v es = IntMap.unionWith IntSet.union (IntMap.fromSet (const $ IntSet.singleton v) es) - vs = IntMap.fromSet (const IntSet.empty) (IntMap.keysSet m) - --- | Transform a graph by applying a function to each of its vertices. This is --- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric --- 'IntAdjacencyMap'. --- Complexity: /O((n + m) * log(n))/ time. --- --- @ --- gmap f 'empty' == 'empty' --- gmap f ('vertex' x) == 'vertex' (f x) --- gmap f ('edge' x y) == 'edge' (f x) (f y) --- gmap id == id --- gmap f . gmap g == gmap (f . g) --- @ -gmap :: (Int -> Int) -> IntAdjacencyMap -> IntAdjacencyMap -gmap f = mkAM . IntMap.map (IntSet.map f) . IntMap.mapKeysWith IntSet.union f . adjacencyMap - --- | Construct the /induced subgraph/ of a given graph by removing the --- vertices that do not satisfy a given predicate. --- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. --- --- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' --- induce (/= x) == 'removeVertex' x --- induce p . induce q == induce (\\x -> p x && q x) --- 'isSubgraphOf' (induce p x) x == True --- @ -induce :: (Int -> Bool) -> IntAdjacencyMap -> IntAdjacencyMap -induce p = mkAM . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyMap - --- | Compute the /depth-first search/ forest of a graph. --- --- @ --- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1, 2] --- 'isSubgraphOf' ('forest' $ dfsForest x) x == True --- dfsForest . 'forest' . dfsForest == dfsForest --- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'dfsForestFrom' ('vertexList' x) x == dfsForest x --- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] }]} --- , Node { rootLabel = 3 --- , subForest = [ Node { rootLabel = 4 --- , subForest = [] }]}] --- @ -dfsForest :: IntAdjacencyMap -> Forest Int -dfsForest (AM _ (GraphKL g r _)) = fmap (fmap r) (KL.dff g) - --- | Compute the /depth-first search/ forest of a graph, searching from each of --- the given vertices in order. Note that the resulting forest does not --- necessarily span the whole graph, as some vertices may be unreachable. --- --- @ --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2, 1] $ 'edge' 1 2) == 'vertices' [1, 2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1, 4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] --- @ -dfsForestFrom :: [Int] -> IntAdjacencyMap -> Forest Int -dfsForestFrom vs (AM _ (GraphKL g r t)) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) - --- | Compute the list of vertices visited by the /depth-first search/ in a graph, --- when searching from each of the given vertices in order. --- --- @ --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1, 2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1, 2] $ 'edge' 1 2 == [1, 2] --- dfs [2, 1] $ 'edge' 1 2 == [2, 1] --- dfs [] $ x == [] --- dfs [1, 4] $ 3 * (1 + 4) * (1 + 5) == [1, 5, 4] --- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True --- @ -dfs :: [Int] -> IntAdjacencyMap -> [Int] -dfs vs = concatMap flatten . dfsForestFrom vs - --- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph --- is cyclic. --- --- @ --- topSort (1 * 2 + 3 * 1) == Just [3,1,2] --- topSort (1 * 2 + 2 * 1) == Nothing --- fmap (flip 'isTopSort' x) (topSort x) /= Just False --- @ -topSort :: IntAdjacencyMap -> Maybe [Int] -topSort m@(AM _ (GraphKL g r _)) = - if isTopSort result m then Just result else Nothing - where - result = map r (KL.topSort g) - --- | Check if a given list of vertices is a valid /topological sort/ of a graph. --- --- @ --- isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True --- isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False --- isTopSort [] (1 * 2 + 3 * 1) == False --- isTopSort [] 'empty' == True --- isTopSort [x] ('vertex' x) == True --- isTopSort [x] ('edge' x x) == False --- @ -isTopSort :: [Int] -> IntAdjacencyMap -> Bool -isTopSort xs m = go IntSet.empty xs - where - go seen [] = seen == IntMap.keysSet (adjacencyMap m) - go seen (v:vs) = let newSeen = seen `seq` IntSet.insert v seen - in postIntSet v m `IntSet.intersection` newSeen == IntSet.empty && go newSeen vs diff --git a/src/Algebra/Graph/IntAdjacencyMap/Internal.hs b/src/Algebra/Graph/IntAdjacencyMap/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/IntAdjacencyMap/Internal.hs +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.IntAdjacencyMap.Internal --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of adjacency maps. The API is unstable --- and unsafe, and is exposed only for documentation. You should use the --- non-internal module "Algebra.Graph.IntAdjacencyMap" instead. ------------------------------------------------------------------------------ -module Algebra.Graph.IntAdjacencyMap.Internal ( - -- * Adjacency map implementation - IntAdjacencyMap (..), mkAM, consistent, - - -- * Interoperability with King-Launchbury graphs - GraphKL (..), mkGraphKL - ) where - -import Data.IntMap.Strict (IntMap, keysSet, fromSet) -import Data.IntSet (IntSet) -import Data.List - -import Algebra.Graph.Class - -import qualified Data.Graph as KL -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet - -{-| The 'IntAdjacencyMap' data type represents a graph by a map of vertices to -their adjacency sets. We define a 'Num' instance as a convenient notation for -working with graphs: - - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) - -The 'Show' instance is defined using basic graph construction primitives: - -@show (empty :: IntAdjacencyMap Int) == "empty" -show (1 :: IntAdjacencyMap Int) == "vertex 1" -show (1 + 2 :: IntAdjacencyMap Int) == "vertices [1,2]" -show (1 * 2 :: IntAdjacencyMap Int) == "edge 1 2" -show (1 * 2 * 3 :: IntAdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]" -show (1 * 2 + 3 :: IntAdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@ - -The 'Eq' instance satisfies all axioms of algebraic graphs: - - * 'Algebra.Graph.IntAdjacencyMap.overlay' is commutative and associative: - - > x + y == y + x - > x + (y + z) == (x + y) + z - - * 'Algebra.Graph.IntAdjacencyMap.connect' is associative and has - 'Algebra.Graph.IntAdjacencyMap.empty' as the identity: - - > x * empty == x - > empty * x == x - > x * (y * z) == (x * y) * z - - * 'Algebra.Graph.IntAdjacencyMap.connect' distributes over - 'Algebra.Graph.IntAdjacencyMap.overlay': - - > x * (y + z) == x * y + x * z - > (x + y) * z == x * z + y * z - - * 'Algebra.Graph.IntAdjacencyMap.connect' can be decomposed: - - > x * y * z == x * y + x * z + y * z - -The following useful theorems can be proved from the above set of axioms. - - * 'Algebra.Graph.IntAdjacencyMap.overlay' has - 'Algebra.Graph.IntAdjacencyMap.empty' as the identity and is idempotent: - - > x + empty == x - > empty + x == x - > x + x == x - - * Absorption and saturation of 'Algebra.Graph.IntAdjacencyMap.connect': - - > x * y + x + y == x * y - > x * x * x == x * x - -When specifying the time and memory complexity of graph algorithms, /n/ and /m/ -will denote the number of vertices and edges in the graph, respectively. --} -data IntAdjacencyMap = AM { - -- | The /adjacency map/ of the graph: each vertex is associated with a set - -- of its direct successors. - adjacencyMap :: !(IntMap IntSet), - -- | Cached King-Launchbury representation. - -- /Note: this field is for internal use only/. - graphKL :: GraphKL } - --- | Construct an 'AdjacencyMap' from a map of successor sets and (lazily) --- compute the corresponding King-Launchbury representation. --- /Note: this function is for internal use only/. -mkAM :: IntMap IntSet -> IntAdjacencyMap -mkAM m = AM m (mkGraphKL m) - -instance Eq IntAdjacencyMap where - x == y = adjacencyMap x == adjacencyMap y - -instance Show IntAdjacencyMap where - show (AM m _) - | null vs = "empty" - | null es = vshow vs - | vs == used = eshow es - | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" - where - vs = IntSet.toAscList (keysSet m) - es = internalEdgeList m - vshow [x] = "vertex " ++ show x - vshow xs = "vertices " ++ show xs - eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y - eshow xs = "edges " ++ show xs - used = IntSet.toAscList (referredToVertexSet m) - -instance Graph IntAdjacencyMap where - type Vertex IntAdjacencyMap = Int - empty = mkAM IntMap.empty - vertex x = mkAM $ IntMap.singleton x IntSet.empty - overlay x y = mkAM $ IntMap.unionWith IntSet.union (adjacencyMap x) (adjacencyMap y) - connect x y = mkAM $ IntMap.unionsWith IntSet.union [ adjacencyMap x, adjacencyMap y, - fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] - -instance Num IntAdjacencyMap where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id - -instance ToGraph IntAdjacencyMap where - type ToVertex IntAdjacencyMap = Int - toGraph = overlays . map (uncurry star . fmap IntSet.toList) . IntMap.toList . adjacencyMap - --- | Check if the internal graph representation is consistent, i.e. that all --- edges refer to existing vertices. It should be impossible to create an --- inconsistent adjacency map, and we use this function in testing. --- /Note: this function is for internal use only/. --- --- @ --- consistent 'Algebra.Graph.IntAdjacencyMap.empty' == True --- consistent ('Algebra.Graph.IntAdjacencyMap.vertex' x) == True --- consistent ('Algebra.Graph.IntAdjacencyMap.overlay' x y) == True --- consistent ('Algebra.Graph.IntAdjacencyMap.connect' x y) == True --- consistent ('Algebra.Graph.IntAdjacencyMap.edge' x y) == True --- consistent ('Algebra.Graph.IntAdjacencyMap.edges' xs) == True --- consistent ('Algebra.Graph.IntAdjacencyMap.graph' xs ys) == True --- consistent ('Algebra.Graph.IntAdjacencyMap.fromAdjacencyList' xs) == True --- @ -consistent :: IntAdjacencyMap -> Bool -consistent (AM m _) = referredToVertexSet m `IntSet.isSubsetOf` keysSet m - --- The set of vertices that are referred to by the edges -referredToVertexSet :: IntMap IntSet -> IntSet -referredToVertexSet = IntSet.fromList . uncurry (++) . unzip . internalEdgeList - --- The list of edges in adjacency map -internalEdgeList :: IntMap IntSet -> [(Int, Int)] -internalEdgeList m = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] - --- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in --- the "Data.Graph" module of the @containers@ library. --- /Note: this data structure is for internal use only/. --- --- If @mkGraphKL (adjacencyMap g) == h@ then the following holds: --- --- @ --- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.vertexList' g --- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.edgeList' g --- @ -data GraphKL = GraphKL { - -- | Array-based graph representation (King and Launchbury, 1995). - toGraphKL :: KL.Graph, - -- | A mapping of "Data.Graph.Vertex" to vertices of type @Int@. - fromVertexKL :: KL.Vertex -> Int, - -- | A mapping from vertices of type @Int@ to "Data.Graph.Vertex". - -- Returns 'Nothing' if the argument is not in the graph. - toVertexKL :: Int -> Maybe KL.Vertex } - --- | Build 'GraphKL' from a map of successor sets. --- /Note: this function is for internal use only/. -mkGraphKL :: IntMap IntSet -> GraphKL -mkGraphKL m = GraphKL - { toGraphKL = g - , fromVertexKL = \u -> case r u of (_, v, _) -> v - , toVertexKL = t } - where - (g, r, t) = KL.graphFromEdges [ ((), v, IntSet.toAscList us) | (v, us) <- IntMap.toAscList m ] diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs --- a/src/Algebra/Graph/Internal.hs +++ b/src/Algebra/Graph/Internal.hs @@ -20,7 +20,9 @@ List (..), -- * Data structures for graph traversal - Focus, focus, Context (..), context + Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, Hit (..), + + foldr1Safe ) where import Prelude () @@ -29,8 +31,6 @@ import Data.Foldable import Data.Semigroup -import Algebra.Graph.Class (ToGraph(..)) - import qualified GHC.Exts as Exts -- | An abstract list data type with /O(1)/ time concatenation (the current @@ -77,6 +77,15 @@ return = pure x >>= f = Exts.fromList (toList x >>= toList . f) +-- | The /focus/ of a graph expression is a flattened represenentation of the +-- subgraph under focus, its context, as well as the list of all encountered +-- vertices. See 'Algebra.Graph.removeEdge' for a use-case example. +data Focus a = Focus + { ok :: Bool -- ^ True if focus on the specified subgraph is obtained. + , is :: List a -- ^ Inputs into the focused subgraph. + , os :: List a -- ^ Outputs out of the focused subgraph. + , vs :: List a } -- ^ All vertices (leaves) of the graph expression. + -- | Focus on the empty graph. emptyFocus :: Focus a emptyFocus = Focus False mempty mempty mempty @@ -97,27 +106,15 @@ xs = if ok y then vs x else is x ys = if ok x then vs y else os y --- | The context of a subgraph comprises the input and output vertices outside --- the subgraph that are connected to the vertices inside the subgraph. -data Context a = Context { inputs :: [a], outputs :: [a] } +-- | An auxiliary data type for 'hasEdge': when searching for an edge, we can hit +-- its 'Tail', i.e. the source vertex, the whole 'Edge', or 'Miss' it entirely. +data Hit = Miss | Tail | Edge deriving (Eq, Ord) --- | Extract the context from a graph 'Focus'. Returns @Nothing@ if the focus --- could not be obtained. -context :: ToGraph g => (ToVertex g -> Bool) -> g -> Maybe (Context (ToVertex g)) -context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) - | otherwise = Nothing +-- | A safe version of 'foldr1' +foldr1Safe :: (a -> a -> a) -> [a] -> Maybe a +foldr1Safe f = foldr mf Nothing where - f = focus p g - --- | The /focus/ of a graph expression is a flattened represenentation of the --- subgraph under focus, its context, as well as the list of all encountered --- vertices. See 'Algebra.Graph.removeEdge' for a use-case example. -data Focus a = Focus - { ok :: Bool -- ^ True if focus on the specified subgraph is obtained. - , is :: List a -- ^ Inputs into the focused subgraph. - , os :: List a -- ^ Outputs out of the focused subgraph. - , vs :: List a } -- ^ All vertices (leaves) of the graph expression. - --- | 'Focus' on a specified subgraph. -focus :: ToGraph g => (ToVertex g -> Bool) -> g -> Focus (ToVertex g) -focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci + mf x m = Just (case m of + Nothing -> x + Just y -> f x y) +{-# INLINE foldr1Safe #-} diff --git a/src/Algebra/Graph/Label.hs b/src/Algebra/Graph/Label.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Label.hs @@ -0,0 +1,126 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Label +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module provides basic data types and type classes for representing edge +-- labels in edge-labelled graphs, e.g. see "Algebra.Graph.Labelled". +-- +----------------------------------------------------------------------------- +module Algebra.Graph.Label ( + -- * Type classes for edge labels + Semilattice (..), Dioid (..), + + -- * Data types for edge labels + Distance (..) + ) where + +import Prelude () +import Prelude.Compat +import Data.Set (Set) + +import qualified Data.Set as Set + +{-| A /bounded join semilattice/, satisfying the following laws: + + * Commutativity: + + > x \/ y == y \/ x + + * Associativity: + + > x \/ (y \/ z) == (x \/ y) \/ z + + * Identity: + + > x \/ zero == x + + * Idempotence: + + > x \/ x == x +-} +class Semilattice a where + zero :: a + (\/) :: a -> a -> a + +{-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following laws: + + * Associativity: + + > x /\ (y /\ z) == (x /\ y) /\ z + + * Identity: + + > x /\ one == x + > one /\ x == x + + * Annihilating zero: + + > x /\ zero == zero + > zero /\ x == zero + + * Distributivity: + + > x /\ (y \/ z) == x /\ y \/ x /\ z + > (x \/ y) /\ z == x /\ z \/ y /\ z +-} +class Semilattice a => Dioid a where + one :: a + (/\) :: a -> a -> a + +infixl 6 \/ +infixl 7 /\ + +instance Semilattice Bool where + zero = False + (\/) = (||) + +instance Dioid Bool where + one = True + (/\) = (&&) + +-- | A /distance/ is a non-negative value that can be 'Finite' or 'Infinite'. +data Distance a = Finite a | Infinite deriving (Eq, Ord, Show) + +instance (Ord a, Num a) => Num (Distance a) where + fromInteger = Finite . fromInteger + + Infinite + _ = Infinite + _ + Infinite = Infinite + Finite x + Finite y = Finite (x + y) + + Infinite * _ = Infinite + _ * Infinite = Infinite + Finite x * Finite y = Finite (x * y) + + negate _ = error "Negative distances not allowed" + + signum (Finite 0) = 0 + signum _ = 1 + + abs = id + +instance Ord a => Semilattice (Distance a) where + zero = Infinite + + Infinite \/ x = x + x \/ Infinite = x + Finite x \/ Finite y = Finite (min x y) + +instance (Num a, Ord a) => Dioid (Distance a) where + one = Finite 0 + + Infinite /\ _ = Infinite + _ /\ Infinite = Infinite + Finite x /\ Finite y = Finite (x + y) + +instance Ord a => Semilattice (Set a) where + zero = Set.empty + (\/) = Set.union diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module provides a minimal and experimental implementation of algebraic +-- graphs with edge labels. The API will be expanded in the next release. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled ( + -- * Algebraic data type for edge-labeleld graphs + Graph (..), UnlabelledGraph, empty, vertex, edge, overlay, connect, + connectBy, (-<), (>-), + + -- * Operations + edgeLabel + ) where + +import Prelude () +import Prelude.Compat + +import Algebra.Graph.Label +import qualified Algebra.Graph.Class as C + +-- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. +-- For example, @Graph Bool a@ is isomorphic to unlabelled graphs defined in +-- the top-level module "Algebra.Graph.Graph", where @False@ and @True@ denote +-- the lack of and the existence of an unlabelled edge, respectively. +data Graph e a = Empty + | Vertex a + | Connect e (Graph e a) (Graph e a) + deriving (Foldable, Functor, Show, Traversable) + +-- | A type synonym for unlabelled graphs. +type UnlabelledGraph a = Graph Bool a + +-- | Construct the /empty graph/. An alias for the constructor 'Empty'. +-- Complexity: /O(1)/ time, memory and size. +empty :: Graph e a +empty = Empty + +-- | Construct the graph comprising /a single isolated vertex/. An alias for the +-- constructor 'Vertex'. +-- Complexity: /O(1)/ time, memory and size. +vertex :: a -> Graph e a +vertex = Vertex + +-- | Construct the graph comprising /a single edge/ with the label 'one'. +-- Complexity: /O(1)/ time, memory and size. +edge :: Dioid e => a -> a -> Graph e a +edge = C.edge + +-- | /Overlay/ two graphs. An alias for 'Connect' 'zero'. This is a commutative, +-- associative and idempotent operation with the identity 'empty'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +overlay :: Semilattice e => Graph e a -> Graph e a -> Graph e a +overlay = Connect zero + +-- | /Connect/ two graphs. An alias for 'Connect' 'one'. This is an associative +-- operation with the identity 'empty', which distributes over 'overlay' and +-- obeys the decomposition axiom. See the full list of laws in "Algebra.Graph". +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number +-- of edges in the resulting graph is quadratic with respect to the number of +-- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +connect :: Dioid e => Graph e a -> Graph e a -> Graph e a +connect = Connect one + +-- | /Connect/ two graphs with edges labelled by a given label. An alias for +-- 'Connect'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number +-- of edges in the resulting graph is quadratic with respect to the number of +-- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +connectBy :: e -> Graph e a -> Graph e a -> Graph e a +connectBy = Connect + +-- | The left-hand part of a convenient ternary-ish operator @x -\- y@ for +-- connecting graphs with labelled edges. For example: +-- +-- @ +-- x = 'vertex' "x" +-- y = 'vertex' "y" +-- z = x -\<2\>- y +-- @ +(-<) :: Graph e a -> e -> (Graph e a, e) +g -< e = (g, e) + +-- | The right-hand part of a convenient ternary-ish operator @x -\- y@ for +-- connecting graphs with labelled edges. For example: +-- +-- @ +-- x = 'vertex' "x" +-- y = 'vertex' "y" +-- z = x -\<2\>- y +-- @ +(>-) :: (Graph e a, e) -> Graph e a -> Graph e a +(g, e) >- h = Connect e g h + +infixl 5 -< +infixl 5 >- + +instance Dioid e => C.Graph (Graph e a) where + type Vertex (Graph e a) = a + empty = Empty + vertex = Vertex + overlay = overlay + connect = connect + +-- | Extract the label of a specified edge from a graph. +edgeLabel :: (Eq a, Semilattice e) => a -> a -> Graph e a -> e +edgeLabel _ _ Empty = zero +edgeLabel _ _ (Vertex _) = zero +edgeLabel x y (Connect e g h) = edgeLabel x y g \/ edgeLabel x y h \/ new + where + new | x `elem` g && y `elem` h = e + | otherwise = zero diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -36,11 +36,11 @@ vertexSet, vertexIntSet, edgeSet, -- * Standard families of graphs - path1, circuit1, clique1, biclique1, star, starTranspose, tree, mesh1, torus1, + path1, circuit1, clique1, biclique1, star, stars1, tree, mesh1, torus1, -- * Graph transformation removeVertex1, removeEdge, replaceVertex, mergeVertices, splitVertex1, - transpose, induce1, simplify, + transpose, induce1, simplify, sparsify, -- * Graph composition box @@ -55,20 +55,18 @@ import Control.DeepSeq (NFData (..)) import Control.Monad.Compat +import Control.Monad.State (runState, get, put) import Data.List.NonEmpty (NonEmpty (..)) import Algebra.Graph.Internal -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.HigherKinded.Class as H -import qualified Algebra.Graph.IntAdjacencyMap as IAM -import qualified Algebra.Graph.Relation as R -import qualified Data.IntSet as IntSet -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Set as Set -import qualified Data.Tree as Tree +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.ToGraph as T +import qualified Data.IntSet as IntSet +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import qualified Data.Tree as Tree {-| The 'NonEmptyGraph' data type is a deep embedding of the core graph construction primitives 'vertex', 'overlay' and 'connect'. As one can guess from @@ -143,12 +141,10 @@ rnf (Overlay x y) = rnf x `seq` rnf y rnf (Connect x y) = rnf x `seq` rnf y -instance C.ToGraph (NonEmptyGraph a) where +instance T.ToGraph (NonEmptyGraph a) where type ToVertex (NonEmptyGraph a) = a foldg _ = foldg1 - -instance H.ToGraph NonEmptyGraph where - toGraph = foldg1 H.vertex H.overlay H.connect + hasEdge = hasEdge instance Num a => Num (NonEmptyGraph a) where fromInteger = Vertex . fromInteger @@ -159,8 +155,19 @@ negate = id instance Ord a => Eq (NonEmptyGraph a) where - x == y = C.toGraph x == (C.toGraph y :: AM.AdjacencyMap a) + (==) = equals +-- TODO: Find a more efficient equality check. +-- | Compare two graphs by converting them to their adjacency maps. +{-# NOINLINE [1] equals #-} +{-# RULES "equalsInt" equals = equalsInt #-} +equals :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool +equals x y = T.adjacencyMap x == T.adjacencyMap y + +-- | Like @equals@ but specialised for graphs with vertices of type 'Int'. +equalsInt :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool +equalsInt x y = T.adjacencyIntMap x == T.adjacencyIntMap y + instance Applicative NonEmptyGraph where pure = Vertex (<*>) = ap @@ -196,6 +203,7 @@ -- @ vertex :: a -> NonEmptyGraph a vertex = Vertex +{-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory and size. @@ -226,6 +234,7 @@ -- @ overlay :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a overlay = Overlay +{-# INLINE overlay #-} -- | Overlay a possibly empty graph with a non-empty graph. If the first -- argument is 'G.empty', the function returns the second argument; otherwise @@ -260,6 +269,7 @@ -- @ connect :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a connect = Connect +{-# INLINE connect #-} -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -273,6 +283,7 @@ -- @ vertices1 :: NonEmpty a -> NonEmptyGraph a vertices1 = overlays1 . fmap vertex +{-# NOINLINE [1] vertices1 #-} -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -283,7 +294,7 @@ -- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @ edges1 :: NonEmpty (a, a) -> NonEmptyGraph a -edges1 = overlays1 . fmap (uncurry edge) +edges1 = overlays1 . fmap (uncurry edge) -- | Overlay a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -294,8 +305,8 @@ -- overlays1 (x ':|' [y]) == 'overlay' x y -- @ overlays1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a -overlays1 (x :| xs) = case xs of [] -> x - (y:ys) -> overlay x (overlays1 $ y :| ys) +overlays1 = concatg1 overlay +{-# INLINE [2] overlays1 #-} -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -306,9 +317,13 @@ -- connects1 (x ':|' [y]) == 'connect' x y -- @ connects1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a -connects1 (x :| xs) = case xs of [] -> x - (y:ys) -> connect x (connects1 $ y :| ys) +connects1 = concatg1 connect +{-# INLINE [2] connects1 #-} +-- | Auxiliary function, similar to 'sconcat'. +concatg1 :: (NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a) -> NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +concatg1 combine (x :| xs) = maybe x (combine x) $ foldr1Safe combine xs + -- | Generalised graph folding: recursively collapse a 'NonEmptyGraph' by -- applying the provided functions to the leaves and internal nodes of the -- expression. The order of arguments is: vertex, overlay and connect. @@ -336,6 +351,7 @@ -- isSubgraphOf ('overlay' x y) ('connect' x y) == True -- isSubgraphOf ('path1' xs) ('circuit1' xs) == True -- @ +{-# SPECIALISE isSubgraphOf :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-} isSubgraphOf :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool isSubgraphOf x y = overlay x y == y @@ -348,6 +364,7 @@ -- 1 + 2 === 2 + 1 == False -- x + y === x * y == False -- @ +{-# SPECIALISE (===) :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-} (===) :: Eq a => NonEmptyGraph a -> NonEmptyGraph a -> Bool (Vertex x1 ) === (Vertex x2 ) = x1 == x2 (Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2 @@ -376,9 +393,11 @@ -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False -- @ +{-# SPECIALISE hasVertex :: Int -> NonEmptyGraph Int -> Bool #-} hasVertex :: Eq a => a -> NonEmptyGraph a -> Bool hasVertex v = foldg1 (==v) (||) (||) +-- TODO: Reduce code duplication with 'Algebra.Graph.hasEdge'. -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. -- @@ -388,8 +407,19 @@ -- hasEdge x y . 'removeEdge' x y == const False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -hasEdge :: Ord a => a -> a -> NonEmptyGraph a -> Bool -hasEdge u v = G.hasEdge u v . H.toGraph +{-# SPECIALISE hasEdge :: Int -> Int -> NonEmptyGraph Int -> Bool #-} +hasEdge :: Eq a => a -> a -> NonEmptyGraph a -> Bool +hasEdge s t g = hit g == Edge + where + hit (Vertex x ) = if x == s then Tail else Miss + hit (Overlay x y) = case hit x of + Miss -> hit y + Tail -> max Tail (hit y) + Edge -> Edge + hit (Connect x y) = case hit x of + Miss -> hit y + Tail -> if hasVertex t y then Edge else Tail + Edge -> Edge -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. @@ -399,9 +429,15 @@ -- vertexCount x >= 1 -- vertexCount == 'length' . 'vertexList1' -- @ +{-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} +{-# INLINE [1] vertexCount #-} vertexCount :: Ord a => NonEmptyGraph a -> Int -vertexCount = length . vertexList1 +vertexCount = T.vertexCount +-- | Like 'vertexCount' but specialised for NonEmptyGraph with vertices of type 'Int'. +vertexIntCount :: NonEmptyGraph Int -> Int +vertexIntCount = IntSet.size . vertexIntSet + -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a -- graph can be quadratic with respect to the expression size /s/. @@ -411,9 +447,15 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ +{-# INLINE [1] edgeCount #-} +{-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-} edgeCount :: Ord a => NonEmptyGraph a -> Int -edgeCount = AM.edgeCount . C.toGraph +edgeCount = T.edgeCount +-- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. +edgeCountInt :: NonEmptyGraph Int -> Int +edgeCountInt = AIM.edgeCount . T.toAdjacencyIntMap + -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- @@ -421,9 +463,15 @@ -- vertexList1 ('vertex' x) == x ':|' [] -- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' -- @ +{-# RULES "vertexList1/Int" vertexList1 = vertexIntList1 #-} +{-# INLINE [1] vertexList1 #-} vertexList1 :: Ord a => NonEmptyGraph a -> NonEmpty a -vertexList1 = NonEmpty.fromList . G.vertexList . H.toGraph +vertexList1 = NonEmpty.fromList . Set.toAscList . vertexSet +-- | Like 'vertexList1' but specialised for NonEmptyGraph with vertices of type 'Int'. +vertexIntList1 :: NonEmptyGraph Int -> NonEmpty Int +vertexIntList1 = NonEmpty.fromList . IntSet.toAscList . vertexIntSet + -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of -- edges /m/ of a graph can be quadratic with respect to the expression size /s/. @@ -435,9 +483,15 @@ -- edgeList . 'edges1' == 'Data.List.nub' . 'Data.List.sort' . 'Data.List.NonEmpty.toList' -- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList -- @ +{-# RULES "edgeList/Int" edgeList = edgeIntList #-} +{-# INLINE [1] edgeList #-} edgeList :: Ord a => NonEmptyGraph a -> [(a, a)] -edgeList = AM.edgeList . C.toGraph +edgeList = T.edgeList +-- | Like 'edgeList' but specialised for NonEmptyGraph with vertices of type 'Int'. +edgeIntList :: NonEmptyGraph Int -> [(Int,Int)] +edgeIntList = AIM.edgeList . T.toAdjacencyIntMap + -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- @@ -447,7 +501,7 @@ -- vertexSet . 'clique1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @ vertexSet :: Ord a => NonEmptyGraph a -> Set.Set a -vertexSet = AM.vertexSet . C.toGraph +vertexSet = T.vertexSet -- | The set of vertices of a given graph. Like 'vertexSet' but specialised for -- graphs with vertices of type 'Int'. @@ -459,7 +513,7 @@ -- vertexIntSet . 'clique1' == IntSet.'IntSet.fromList' . 'Data.List.NonEmpty.toList' -- @ vertexIntSet :: NonEmptyGraph Int -> IntSet.IntSet -vertexIntSet = IAM.vertexIntSet . C.toGraph +vertexIntSet = T.vertexIntSet -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. @@ -470,7 +524,7 @@ -- edgeSet . 'edges1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @ edgeSet :: Ord a => NonEmptyGraph a -> Set.Set (a, a) -edgeSet = R.edgeSet . C.toGraph +edgeSet = T.edgeSet -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -510,6 +564,7 @@ -- @ clique1 :: NonEmpty a -> NonEmptyGraph a clique1 = connects1 . fmap vertex +{-# NOINLINE [1] clique1 #-} -- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -534,20 +589,22 @@ star :: a -> [a] -> NonEmptyGraph a star x [] = vertex x star x (y:ys) = connect (vertex x) (vertices1 $ y :| ys) +{-# INLINE star #-} --- | The /star transpose/ formed by a list of leaves connected to a centre vertex. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. +-- | The /stars/ formed by overlaying a non-empty list of 'star's. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the +-- input. -- -- @ --- starTranspose x [] == 'vertex' x --- starTranspose x [y] == 'edge' y x --- starTranspose x [y,z] == 'edges1' ((y,x) ':|' [(z,x)]) --- starTranspose x ys == 'transpose' ('star' x ys) +-- stars1 ((x, []) ':|' []) == 'vertex' x +-- stars1 ((x, [y]) ':|' []) == 'edge' x y +-- stars1 ((x, ys) ':|' []) == 'star' x ys +-- stars1 == 'overlays1' . fmap (uncurry 'star') +-- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs <> ys) -- @ -starTranspose :: a -> [a] -> NonEmptyGraph a -starTranspose x [] = vertex x -starTranspose x (y:ys) = connect (vertices1 $ y :| ys) (vertex x) +stars1 :: NonEmpty (a, [a]) -> NonEmptyGraph a +stars1 = overlays1 . fmap (uncurry star) +{-# INLINE stars1 #-} -- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the @@ -575,14 +632,34 @@ -- , ((3,\'a\'),(3,\'b\')) ]) -- @ mesh1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b) -mesh1 xs ys = path1 xs `box` path1 ys +mesh1 xx@(x:|xs) yy@(y:|ys) = + case NonEmpty.nonEmpty ipxs of + Nothing -> + case NonEmpty.nonEmpty ipys of + Nothing -> vertex (x,y) + Just ipys' -> + stars1 $ fmap (\(y1,y2) -> ((x,y1), [(x,y2)]) ) ipys' + Just ipxs' -> + case NonEmpty.nonEmpty ipys of + Nothing -> + stars1 $ fmap (\(x1,x2) -> ((x1,y), [(x2,y)]) ) ipxs' + Just ipys' -> + stars1 $ + appendNonEmpty (fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) $ liftM2 (,) ipxs' ipys') $ + [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] + ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] + where + lx = last xs + ly = last ys + ipxs = NonEmpty.init (pairs1 xx) + ipys = NonEmpty.init (pairs1 yy) -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. -- -- @ --- torus1 (x ':|' []) (y ':|' []) == 'edge' (x, y) (x, y) +-- torus1 (x ':|' []) (y ':|' []) == 'edge' (x,y) (x,y) -- torus1 xs ys == 'box' ('circuit1' xs) ('circuit1' ys) -- torus1 (1 ':|' [2]) (\'a\' ':|' "b") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')) -- , ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\')) @@ -590,8 +667,16 @@ -- , ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ]) -- @ torus1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b) -torus1 xs ys = circuit1 xs `box` circuit1 ys +torus1 xs ys = stars1 $ fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) $ liftM2 (,) (pairs1 xs) (pairs1 ys) +-- | Auxiliary function for 'mesh1' and 'torus1' +pairs1 :: NonEmpty a -> NonEmpty (a, a) +pairs1 as@(x:|xs) = NonEmpty.zip as $ maybe (x :| []) (`appendNonEmpty` [x]) $ NonEmpty.nonEmpty xs + +-- | Append a list to a non-empty one +appendNonEmpty :: NonEmpty a -> [a] -> NonEmpty a +appendNonEmpty (w:|ws) zs = w :| (ws++zs) + -- | Remove a vertex from a given graph. Returns @Nothing@ if the resulting -- graph is empty. -- Complexity: /O(s)/ time, memory and size. @@ -603,6 +688,7 @@ -- removeVertex1 1 ('edge' 1 2) == Just ('vertex' 2) -- removeVertex1 x '>=>' removeVertex1 x == removeVertex1 x -- @ +{-# SPECIALISE removeVertex1 :: Int -> NonEmptyGraph Int -> Maybe (NonEmptyGraph Int) #-} removeVertex1 :: Eq a => a -> NonEmptyGraph a -> Maybe (NonEmptyGraph a) removeVertex1 x = induce1 (/= x) @@ -616,17 +702,17 @@ -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ +{-# SPECIALISE removeEdge :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} removeEdge :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a removeEdge s t = filterContext s (/=s) (/=t) -- TODO: Export --- TODO: Here if @context (==s) g == Just ctx@ then we know for sure that --- @induce1 (/=s) g == Just subgraph@. Can we exploit this? +{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> NonEmptyGraph Int -> NonEmptyGraph Int #-} filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> NonEmptyGraph a -> NonEmptyGraph a -filterContext s i o g = maybe g go $ context (==s) g +filterContext s i o g = maybe g go $ G.context (==s) (T.toGraph g) where - go (Context is os) = G.induce (/=s) (C.toGraph g) `overlay1` - starTranspose s (filter i is) `overlay` star s (filter o os) + go (G.Context is os) = G.induce (/=s) (T.toGraph g) `overlay1` + transpose (star s (filter i is)) `overlay` star s (filter o os) -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'NonEmptyGraph'. If @y@ already exists, @x@ and @y@ will be merged. @@ -637,6 +723,7 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y == 'mergeVertices' (== x) y -- @ +{-# SPECIALISE replaceVertex :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} replaceVertex :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a replaceVertex u v = fmap $ \w -> if w == u then v else w @@ -663,6 +750,7 @@ -- splitVertex1 x (y ':|' [] ) == 'replaceVertex' x y -- splitVertex1 1 (0 ':|' [1]) $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @ +{-# SPECIALISE splitVertex1 :: Int -> NonEmpty Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} splitVertex1 :: Eq a => a -> NonEmpty a -> NonEmptyGraph a -> NonEmptyGraph a splitVertex1 v us g = g >>= \w -> if w == v then vertices1 us else vertex w @@ -678,7 +766,20 @@ -- @ transpose :: NonEmptyGraph a -> NonEmptyGraph a transpose = foldg1 vertex overlay (flip connect) +{-# NOINLINE [1] transpose #-} +{-# RULES +"transpose/Vertex" forall x. transpose (Vertex x) = Vertex x +"transpose/Overlay" forall g1 g2. transpose (Overlay g1 g2) = Overlay (transpose g1) (transpose g2) +"transpose/Connect" forall g1 g2. transpose (Connect g1 g2) = Connect (transpose g2) (transpose g1) + +"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs) +"transpose/connects1" forall xs. transpose (connects1 xs) = connects1 (NonEmpty.reverse (fmap transpose xs)) + +"transpose/vertices1" forall xs. transpose (vertices1 xs) = vertices1 xs +"transpose/clique1" forall xs. transpose (clique1 xs) = clique1 (NonEmpty.reverse xs) + #-} + -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. Returns @Nothing@ if the -- resulting graph is empty. @@ -692,7 +793,14 @@ -- induce1 p '>=>' induce1 q == induce1 (\\x -> p x && q x) -- @ induce1 :: (a -> Bool) -> NonEmptyGraph a -> Maybe (NonEmptyGraph a) -induce1 p = toNonEmptyGraph . G.induce p . C.toGraph +induce1 p = foldg1 + (\x -> if p x then Just (Vertex x) else Nothing) + (k Overlay) + (k Connect) + where + k _ Nothing a = a + k _ a Nothing = a + k f (Just a) (Just b) = Just $ f a b -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra. @@ -709,9 +817,11 @@ -- simplify (1 + 2 + 1) '===' 1 + 2 -- simplify (1 * 1 * 1) '===' 1 * 1 -- @ +{-# SPECIALISE simplify :: NonEmptyGraph Int -> NonEmptyGraph Int #-} simplify :: Ord a => NonEmptyGraph a -> NonEmptyGraph a simplify = foldg1 Vertex (simple Overlay) (simple Connect) +{-# SPECIALISE simple :: (NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int) -> NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y | x == z = x @@ -749,6 +859,32 @@ where xs = fmap (\b -> fmap (,b) x) $ toNonEmpty y ys = fmap (\a -> fmap (a,) y) $ toNonEmpty x + +-- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the +-- original vertices (wrapping the latter in 'Right') such that the resulting +-- graph is /sparse/, i.e. contains only O(s) edges, but preserves the +-- reachability relation between the original vertices. Sparsification is useful +-- when working with dense graphs, as it can reduce the number of edges from +-- O(n^2) down to O(n) by replacing cliques, bicliques and similar densely +-- connected structures by sparse subgraphs built out of intermediate vertices. +-- Complexity: O(s) time, memory and size. +-- +-- @ +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' ('Data.Either.Right' x) . sparsify +-- 'vertexCount' (sparsify x) <= 'vertexCount' x + 'size' x + 1 +-- 'edgeCount' (sparsify x) <= 3 * 'size' x +-- 'size' (sparsify x) <= 3 * 'size' x +-- @ +sparsify :: NonEmptyGraph a -> NonEmptyGraph (Either Int a) +sparsify graph = res + where + (res, end) = runState (foldg1 v o c graph 0 end) 1 + v x s t = return $ clique1 (Left s :| [Right x, Left t]) + o x y s t = overlay <$> s `x` t <*> s `y` t + c x y s t = do + m <- get + put (m + 1) + overlay <$> s `x` m <*> m `y` t -- Shall we export this? I suggest to wait for Foldable1 type class instead. toNonEmpty :: NonEmptyGraph a -> NonEmpty a diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -20,17 +20,16 @@ -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - fromAdjacencyList, -- * Relations on graphs isSubgraphOf, -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - vertexSet, vertexIntSet, edgeSet, preSet, postSet, + adjacencyList, vertexSet, vertexIntSet, edgeSet, preSet, postSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest, + path, circuit, clique, biclique, star, stars, tree, forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, @@ -42,38 +41,14 @@ import Prelude () import Prelude.Compat +import Data.Tree import Data.Tuple import Algebra.Graph.Relation.Internal -import qualified Algebra.Graph.Class as C -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set -import qualified Data.Tree as Tree - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'isEmpty' empty == True --- 'hasVertex' x empty == False --- 'vertexCount' empty == 0 --- 'edgeCount' empty == 0 --- @ -empty :: Ord a => Relation a -empty = C.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True --- 'vertexCount' (vertex x) == 1 --- 'edgeCount' (vertex x) == 0 --- @ -vertex :: Ord a => a -> Relation a -vertex = C.vertex +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import qualified Data.Tree as Tree -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory and size. @@ -86,45 +61,7 @@ -- 'vertexCount' (edge 1 2) == 2 -- @ edge :: Ord a => a -> a -> Relation a -edge = C.edge - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (overlay x y) >= 'vertexCount' x --- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (overlay x y) >= 'edgeCount' x --- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y --- 'vertexCount' (overlay 1 2) == 2 --- 'edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => Relation a -> Relation a -> Relation a -overlay = C.overlay - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (connect x y) >= 'vertexCount' x --- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (connect x y) >= 'edgeCount' x --- 'edgeCount' (connect x y) >= 'edgeCount' y --- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y --- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y --- 'vertexCount' (connect 1 2) == 2 --- 'edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => Relation a -> Relation a -> Relation a -connect = C.connect +edge x y = Relation (Set.fromList [x, y]) (Set.singleton (x, y)) -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length @@ -162,7 +99,7 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: Ord a => [Relation a] -> Relation a -overlays = C.overlays +overlays xs = Relation (Set.unions $ map domain xs) (Set.unions $ map relation xs) -- | Connect a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -175,22 +112,7 @@ -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: Ord a => [Relation a] -> Relation a -connects = C.connects - --- | Construct a graph from an adjacency list. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyList [] == 'empty' --- fromAdjacencyList [(x, [])] == 'vertex' x --- fromAdjacencyList [(x, [y])] == 'edge' x y --- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) --- @ -fromAdjacencyList :: Ord a => [(a, [a])] -> Relation a -fromAdjacencyList as = Relation (Set.fromList vs) (Set.fromList es) - where - vs = concatMap (uncurry (:)) as - es = [ (x, y) | (x, ys) <- as, y <- ys ] +connects = foldr connect empty -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. @@ -329,7 +251,24 @@ edgeSet :: Relation a -> Set.Set (a, a) edgeSet = relation --- | The /preset/ (here 'preSet') of an element @x@ is the set of elements that are related to +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] +-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] +-- 'stars' . adjacencyList == id +-- @ +adjacencyList :: Eq a => Relation a -> [(a, [a])] +adjacencyList r = go (Set.toAscList $ domain r) (Set.toAscList $ relation r) + where + go [] _ = [] + go vs [] = map ((,[])) vs + go (x:vs) es = let (ys, zs) = span ((==x) . fst) es in (x, map snd ys) : go vs zs + +-- | The /preset/ of an element @x@ is the set of elements that are related to -- it on the /left/, i.e. @preSet x == { a | aRx }@. In the context of directed -- graphs, this corresponds to the set of /direct predecessors/ of vertex @x@. -- Complexity: /O(n + m)/ time and /O(n)/ memory. @@ -343,7 +282,7 @@ preSet :: Ord a => a -> Relation a -> Set.Set a preSet x = Set.mapMonotonic fst . Set.filter ((== x) . snd) . relation --- | The /postset/ (here 'postSet') of an element @x@ is the set of elements that are related to +-- | The /postset/ of an element @x@ is the set of elements that are related to -- it on the /right/, i.e. @postSet x == { a | xRa }@. In the context of directed -- graphs, this corresponds to the set of /direct successors/ of vertex @x@. -- Complexity: /O(n + m)/ time and /O(n)/ memory. @@ -367,7 +306,9 @@ -- path . 'reverse' == 'transpose' . path -- @ path :: Ord a => [a] -> Relation a -path = C.path +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) -- | The /circuit/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -379,7 +320,8 @@ -- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: Ord a => [a] -> Relation a -circuit = C.circuit +circuit [] = empty +circuit (x:xs) = path $ [x] ++ xs ++ [x] -- | The /clique/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -393,7 +335,12 @@ -- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> Relation a -clique = C.clique +clique xs = Relation (Set.fromList xs) (fst $ go xs) + where + go [] = (Set.empty, Set.empty) + go (x:xs) = (Set.union res (Set.map (x,) set), Set.insert x set) + where + (res, set) = go xs -- | The /biclique/ on two lists of vertices. -- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. @@ -411,6 +358,7 @@ x = Set.fromList xs y = Set.fromList ys +-- TODO: Optimise. -- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -421,21 +369,28 @@ -- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Ord a => a -> [a] -> Relation a -star = C.star +star x [] = vertex x +star x ys = connect (vertex x) (vertices ys) --- | The /star transpose/ formed by a list of leaves connected to a centre vertex. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L * log(n))/ time, memory and size, where /L/ is the total +-- size of the input. -- -- @ --- starTranspose x [] == 'vertex' x --- starTranspose x [y] == 'edge' y x --- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] --- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) --- starTranspose x ys == 'transpose' ('star' x ys) +-- stars [] == 'empty' +-- stars [(x, [])] == 'vertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . map (uncurry 'star') +-- stars . 'adjacencyList' == id +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ -starTranspose :: Ord a => a -> [a] -> Relation a -starTranspose = C.starTranspose +stars :: Ord a => [(a, [a])] -> Relation a +stars as = Relation (Set.fromList vs) (Set.fromList es) + where + vs = concatMap (uncurry (:)) as + es = [ (x, y) | (x, ys) <- as, y <- ys ] -- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -447,7 +402,9 @@ -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] -- @ tree :: Ord a => Tree.Tree a -> Relation a -tree = C.tree +tree (Node x []) = vertex x +tree (Node x f ) = star x (map rootLabel f) + `overlay` forest (filter (not . null . subForest) f) -- | The /forest graph/ constructed from a given 'Tree.Forest' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -459,7 +416,7 @@ -- forest == 'overlays' . map 'tree' -- @ forest :: Ord a => Tree.Forest a -> Relation a -forest = C.forest +forest = overlays. map tree -- | Remove a vertex from a given graph. -- Complexity: /O(n + m)/ time. @@ -480,7 +437,7 @@ -- Complexity: /O(log(m))/ time. -- -- @ --- removeEdge x y ('AdjacencyMap.edge' x y) == 'vertices' [x, y] +-- removeEdge x y ('AdjacencyMap.edge' x y) == 'vertices' [x,y] -- removeEdge x y . removeEdge x y == removeEdge x y -- removeEdge x y . 'removeVertex' x == 'removeVertex' x -- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 diff --git a/src/Algebra/Graph/Relation/Internal.hs b/src/Algebra/Graph/Relation/Internal.hs --- a/src/Algebra/Graph/Relation/Internal.hs +++ b/src/Algebra/Graph/Relation/Internal.hs @@ -12,15 +12,16 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Relation.Internal ( -- * Binary relation implementation - Relation (..), consistent, setProduct, referredToVertexSet + Relation (..), empty, vertex, overlay, connect, setProduct, consistent, + referredToVertexSet ) where import Data.Set (Set, union) -import Algebra.Graph.Class - import qualified Data.Set as Set +import Control.DeepSeq (NFData, rnf) + {-| The 'Relation' data type represents a graph as a /binary relation/. We define a 'Num' instance as a convenient notation for working with graphs: @@ -102,14 +103,72 @@ eshow xs = "edges " ++ show xs used = referredToVertexSet r -instance Ord a => Graph (Relation a) where - type Vertex (Relation a) = a - empty = Relation Set.empty Set.empty - vertex x = Relation (Set.singleton x) Set.empty - overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y) - connect x y = Relation (domain x `union` domain y) (relation x `union` relation y - `union` (domain x `setProduct` domain y)) +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.Relation.isEmpty' empty == True +-- 'Algebra.Graph.Relation.hasVertex' x empty == False +-- 'Algebra.Graph.Relation.vertexCount' empty == 0 +-- 'Algebra.Graph.Relation.edgeCount' empty == 0 +-- @ +empty :: Relation a +empty = Relation Set.empty Set.empty +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.Relation.isEmpty' (vertex x) == False +-- 'Algebra.Graph.Relation.hasVertex' x (vertex x) == True +-- 'Algebra.Graph.Relation.vertexCount' (vertex x) == 1 +-- 'Algebra.Graph.Relation.edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> Relation a +vertex x = Relation (Set.singleton x) Set.empty + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'Algebra.Graph.Relation.isEmpty' (overlay x y) == 'Algebra.Graph.Relation.isEmpty' x && 'iAlgebra.Graph.Relation.sEmpty' y +-- 'Algebra.Graph.Relation.hasVertex' z (overlay x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y +-- 'Algebra.Graph.Relation.vertexCount' (overlay x y) >= 'Algebra.Graph.Relation.vertexCount' x +-- 'Algebra.Graph.Relation.vertexCount' (overlay x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y +-- 'Algebra.Graph.Relation.edgeCount' (overlay x y) >= 'Algebra.Graph.Relation.edgeCount' x +-- 'Algebra.Graph.Relation.edgeCount' (overlay x y) <= 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y +-- 'Algebra.Graph.Relation.vertexCount' (overlay 1 2) == 2 +-- 'Algebra.Graph.Relation.edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => Relation a -> Relation a -> Relation a +overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y) + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'Algebra.Graph.Relation.isEmpty' (connect x y) == 'Algebra.Graph.Relation.isEmpty' x && 'Algebra.Graph.Relation.isEmpty' y +-- 'Algebra.Graph.Relation.hasVertex' z (connect x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y +-- 'Algebra.Graph.Relation.vertexCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x +-- 'Algebra.Graph.Relation.vertexCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y +-- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' x +-- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' y +-- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y +-- 'Algebra.Graph.Relation.edgeCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y + 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y +-- 'Algebra.Graph.Relation.vertexCount' (connect 1 2) == 2 +-- 'Algebra.Graph.Relation.edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => Relation a -> Relation a -> Relation a +connect x y = Relation (domain x `union` domain y) + (relation x `union` relation y `union` (domain x `setProduct` domain y)) + +instance NFData a => NFData (Relation a) where + rnf (Relation d r) = rnf d `seq` rnf r `seq` () + -- | Compute the Cartesian product of two sets. /Note: this function is for internal use only/. setProduct :: Set a -> Set b -> Set (a, b) setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- Set.toAscList y ] @@ -122,10 +181,6 @@ abs = id negate = id -instance ToGraph (Relation a) where - type ToVertex (Relation a) = a - toGraph (Relation d r) = vertices (Set.toList d) `overlay` edges (Set.toList r) - -- | Check if the internal representation of a relation is consistent, i.e. if all -- pairs of elements in the 'relation' refer to existing elements in the 'domain'. -- It should be impossible to create an inconsistent 'Relation', and we use this @@ -133,14 +188,13 @@ -- /Note: this function is for internal use only/. -- -- @ --- consistent 'Algebra.Graph.Relation.empty' == True --- consistent ('Algebra.Graph.Relation.vertex' x) == True --- consistent ('Algebra.Graph.Relation.overlay' x y) == True --- consistent ('Algebra.Graph.Relation.connect' x y) == True --- consistent ('Algebra.Graph.Relation.edge' x y) == True --- consistent ('Algebra.Graph.Relation.edges' xs) == True --- consistent ('Algebra.Graph.Relation.graph' xs ys) == True --- consistent ('Algebra.Graph.Relation.fromAdjacencyList' xs) == True +-- consistent 'Algebra.Graph.Relation.empty' == True +-- consistent ('Algebra.Graph.Relation.vertex' x) == True +-- consistent ('Algebra.Graph.Relation.overlay' x y) == True +-- consistent ('Algebra.Graph.Relation.connect' x y) == True +-- consistent ('Algebra.Graph.Relation.edge' x y) == True +-- consistent ('Algebra.Graph.Relation.edges' xs) == True +-- consistent ('Algebra.Graph.Relation.stars' xs) == True -- @ consistent :: Ord a => Relation a -> Bool consistent (Relation d r) = referredToVertexSet r `Set.isSubsetOf` d diff --git a/src/Algebra/Graph/Relation/InternalDerived.hs b/src/Algebra/Graph/Relation/InternalDerived.hs --- a/src/Algebra/Graph/Relation/InternalDerived.hs +++ b/src/Algebra/Graph/Relation/InternalDerived.hs @@ -18,6 +18,9 @@ PreorderRelation (..) ) where + +import Control.DeepSeq (NFData (..)) + import Algebra.Graph.Class import Algebra.Graph.Relation (Relation, reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure) @@ -34,7 +37,7 @@ show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ -} newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } - deriving Num + deriving (Num, NFData) instance Ord a => Eq (ReflexiveRelation a) where x == y = reflexiveClosure (fromReflexive x) == reflexiveClosure (fromReflexive y) @@ -65,7 +68,7 @@ show (1 * 2 :: SymmetricRelation Int) == "edges [(1,2),(2,1)]"@ -} newtype SymmetricRelation a = SymmetricRelation { fromSymmetric :: Relation a } - deriving Num + deriving (Num, NFData) instance Ord a => Eq (SymmetricRelation a) where x == y = symmetricClosure (fromSymmetric x) == symmetricClosure (fromSymmetric y) @@ -100,7 +103,7 @@ show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ -} newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } - deriving Num + deriving (Num, NFData) instance Ord a => Eq (TransitiveRelation a) where x == y = transitiveClosure (fromTransitive x) == transitiveClosure (fromTransitive y) @@ -140,7 +143,7 @@ show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ -} newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } - deriving Num + deriving (Num, NFData) instance (Ord a, Show a) => Show (PreorderRelation a) where show = show . preorderClosure . fromPreorder diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/ToGraph.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.ToGraph +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines the type class 'ToGraph' for capturing data types that +-- can be converted to algebraic graphs. To make an instance of this class you +-- need to define just a single method ('toGraph' or 'foldg'), which gives you +-- access to many other useful methods for free. This type class is similar to +-- the standard "Data.Foldable" defined for lists. +-- +----------------------------------------------------------------------------- +module Algebra.Graph.ToGraph (ToGraph (..)) where + +import Prelude () +import Prelude.Compat + +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Map (Map) +import Data.Set (Set) +import Data.Tree + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Internal as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyIntMap.Internal as AIM +import qualified Algebra.Graph.Relation as R +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- | The 'ToGraph' type class captures data types that can be converted to +-- algebraic graphs. +class ToGraph t where + {-# MINIMAL toGraph | foldg #-} + type ToVertex t + + -- | Convert a value to the corresponding algebraic graph, see "Algebra.Graph". + -- + -- @ + -- toGraph == 'foldg' 'G.Empty' 'G.Vertex' 'G.Overlay' 'G.Connect' + -- @ + toGraph :: t -> G.Graph (ToVertex t) + toGraph = foldg G.Empty G.Vertex G.Overlay G.Connect + + -- | The method 'foldg' is used for generalised graph folding. It collapses + -- a given value by applying the provided graph construction primitives. The + -- order of arguments is: empty, vertex, overlay and connect, and it is + -- assumed that the arguments satisfy the axioms of the graph algebra. + -- + -- @ + -- foldg == Algebra.Graph.'G.foldg' . 'toGraph' + -- @ + foldg :: r -> (ToVertex t -> r) -> (r -> r -> r) -> (r -> r -> r) -> t -> r + foldg e v o c = G.foldg e v o c . toGraph + + -- | Check if a graph is empty. + -- + -- @ + -- isEmpty == 'foldg' True (const False) (&&) (&&) + -- @ + isEmpty :: t -> Bool + isEmpty = foldg True (const False) (&&) (&&) + + -- | The /size/ of a graph, i.e. the number of leaves of the expression + -- including 'empty' leaves. + -- + -- @ + -- size == 'foldg' 1 (const 1) (+) (+) + -- @ + size :: t -> Int + size = foldg 1 (const 1) (+) (+) + + -- | Check if a graph contains a given vertex. + -- + -- @ + -- hasVertex x == 'foldg' False (==x) (||) (||) + -- @ + hasVertex :: Eq (ToVertex t) => ToVertex t -> t -> Bool + hasVertex x = foldg False (==x) (||) (||) + + -- | Check if a graph contains a given edge. + -- + -- @ + -- hasEdge x y == Algebra.Graph.'G.hasEdge' x y . 'toGraph' + -- @ + hasEdge :: Eq (ToVertex t) => ToVertex t -> ToVertex t -> t -> Bool + hasEdge x y = G.hasEdge x y . toGraph + + -- | The number of vertices in a graph. + -- + -- @ + -- vertexCount == Set.'Set.size' . 'vertexSet' + -- @ + vertexCount :: Ord (ToVertex t) => t -> Int + vertexCount = Set.size . vertexSet + + -- | The number of edges in a graph. + -- + -- @ + -- edgeCount == Set.'Set.size' . 'edgeSet' + -- @ + edgeCount :: Ord (ToVertex t) => t -> Int + edgeCount = AM.edgeCount . toAdjacencyMap + + -- | The sorted list of vertices of a given graph. + -- + -- @ + -- vertexList == Set.'Set.toAscList' . 'vertexSet' + -- @ + vertexList :: Ord (ToVertex t) => t -> [ToVertex t] + vertexList = Set.toAscList . vertexSet + + -- | The sorted list of edges of a graph. + -- + -- @ + -- edgeList == Set.'Set.toAscList' . 'edgeSet' + -- @ + edgeList :: Ord (ToVertex t) => t -> [(ToVertex t, ToVertex t)] + edgeList = AM.edgeList . toAdjacencyMap + + -- | The set of vertices of a graph. + -- + -- @ + -- vertexSet == 'foldg' Set.'Set.empty' Set.'Set.singleton' Set.'Set.union' Set.'Set.union' + -- @ + vertexSet :: Ord (ToVertex t) => t -> Set (ToVertex t) + vertexSet = foldg Set.empty Set.singleton Set.union Set.union + + -- | The set of vertices of a graph. Like 'vertexSet' but specialised for + -- graphs with vertices of type 'Int'. + -- + -- @ + -- vertexIntSet == 'foldg' IntSet.'IntSet.empty' IntSet.'IntSet.singleton' IntSet.'IntSet.union' IntSet.'IntSet.union' + -- @ + vertexIntSet :: ToVertex t ~ Int => t -> IntSet + vertexIntSet = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union + + -- | The set of edges of a graph. + -- + -- @ + -- edgeSet == Algebra.Graph.AdjacencyMap.'AM.edgeSet' . 'toAdjacencyMap' + -- @ + edgeSet :: Ord (ToVertex t) => t -> Set (ToVertex t, ToVertex t) + edgeSet = AM.edgeSet . toAdjacencyMap + + -- | The /preset/ of a vertex is the set of its /direct predecessors/. + -- + -- @ + -- preSet x == Algebra.Graph.AdjacencyMap.'AM.preSet' x . 'toAdjacencyMap' + -- @ + preSet :: Ord (ToVertex t) => ToVertex t -> t -> Set (ToVertex t) + preSet x = AM.postSet x . toAdjacencyMapTranspose + + -- | The /preset/ (here @preIntSet@) of a vertex is the set of its + -- /direct predecessors/. Like 'preSet' but specialised for graphs with + -- vertices of type 'Int'. + -- + -- @ + -- preIntSet x == Algebra.Graph.AdjacencyIntMap.'AIM.preIntSet' x . 'toAdjacencyIntMap' + -- @ + preIntSet :: ToVertex t ~ Int => Int -> t -> IntSet + preIntSet x = AIM.postIntSet x . toAdjacencyIntMapTranspose + + -- | The /postset/ of a vertex is the set of its /direct successors/. + -- + -- @ + -- postSet x == Algebra.Graph.AdjacencyMap.'AM.postSet' x . 'toAdjacencyMap' + -- @ + postSet :: Ord (ToVertex t) => ToVertex t -> t -> Set (ToVertex t) + postSet x = AM.postSet x . toAdjacencyMap + + -- | The /postset/ (here @postIntSet@) of a vertex is the set of its + -- /direct successors/. Like 'postSet' but specialised for graphs with + -- vertices of type 'Int'. + -- + -- @ + -- postIntSet x == Algebra.Graph.AdjacencyIntMap.'AIM.postIntSet' x . 'toAdjacencyIntMap' + -- @ + postIntSet :: ToVertex t ~ Int => Int -> t -> IntSet + postIntSet x = AIM.postIntSet x . toAdjacencyIntMap + + -- | The sorted /adjacency list/ of a graph. + -- + -- @ + -- adjacencyList == Algebra.Graph.AdjacencyMap.'AM.adjacencyList' . 'toAdjacencyMap' + -- @ + adjacencyList :: Ord (ToVertex t) => t -> [(ToVertex t, [ToVertex t])] + adjacencyList = AM.adjacencyList . toAdjacencyMap + + -- | The /adjacency map/ of a graph: each vertex is associated with a set + -- of its /direct successors/. + -- + -- @ + -- adjacencyMap == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMap' + -- @ + adjacencyMap :: Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) + adjacencyMap = AM.adjacencyMap . toAdjacencyMap + + -- | The /adjacency map/ of a graph: each vertex is associated with a set + -- of its /direct successors/. Like 'adjacencyMap' but specialised for + -- graphs with vertices of type 'Int'. + -- + -- @ + -- adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMap' + -- @ + adjacencyIntMap :: ToVertex t ~ Int => t -> IntMap IntSet + adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap + + -- | The transposed /adjacency map/ of a graph: each vertex is associated + -- with a set of its /direct predecessors/. + -- + -- @ + -- adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMapTranspose' + -- @ + adjacencyMapTranspose :: Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) + adjacencyMapTranspose = AM.adjacencyMap . toAdjacencyMapTranspose + + -- | The transposed /adjacency map/ of a graph: each vertex is associated + -- with a set of its /direct predecessors/. Like 'adjacencyMapTranspose' but + -- specialised for graphs with vertices of type 'Int'. + -- + -- @ + -- adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMapTranspose' + -- @ + adjacencyIntMapTranspose :: ToVertex t ~ Int => t -> IntMap IntSet + adjacencyIntMapTranspose = AIM.adjacencyIntMap . toAdjacencyIntMapTranspose + + -- | Compute the /depth-first search/ forest of a graph that corresponds to + -- searching from each of the graph vertices in the 'Ord' @a@ order. + -- + -- @ + -- dfsForest == Algebra.Graph.AdjacencyMap.'AM.dfsForest' . toAdjacencyMap + -- @ + dfsForest :: Ord (ToVertex t) => t -> Forest (ToVertex t) + dfsForest = AM.dfsForest . toAdjacencyMap + + -- | Compute the /depth-first search/ forest of a graph, searching from each + -- of the given vertices in order. Note that the resulting forest does not + -- necessarily span the whole graph, as some vertices may be unreachable. + -- + -- @ + -- dfsForestFrom vs == Algebra.Graph.AdjacencyMap.'AM.dfsForestFrom' vs . toAdjacencyMap + -- @ + dfsForestFrom :: Ord (ToVertex t) => [ToVertex t] -> t -> Forest (ToVertex t) + dfsForestFrom vs = AM.dfsForestFrom vs . toAdjacencyMap + + -- | Compute the list of vertices visited by the /depth-first search/ in a + -- graph, when searching from each of the given vertices in order. + -- + -- @ + -- dfs vs == Algebra.Graph.AdjacencyMap.'AM.dfs' vs . toAdjacencyMap + -- @ + dfs :: Ord (ToVertex t) => [ToVertex t] -> t -> [ToVertex t] + dfs vs = AM.dfs vs . toAdjacencyMap + + -- | Compute the list of vertices that are /reachable/ from a given source + -- vertex in a graph. The vertices in the resulting list appear in the + -- /depth-first order/. + -- + -- @ + -- reachable x == Algebra.Graph.AdjacencyMap.'AM.reachable' x . toAdjacencyMap + -- @ + reachable :: Ord (ToVertex t) => ToVertex t -> t -> [ToVertex t] + reachable x = AM.reachable x . toAdjacencyMap + + -- | Compute the /topological sort/ of a graph or return @Nothing@ if the + -- graph is cyclic. + -- + -- @ + -- topSort == Algebra.Graph.AdjacencyMap.'AM.topSort' . toAdjacencyMap + -- @ + topSort :: Ord (ToVertex t) => t -> Maybe [ToVertex t] + topSort = AM.topSort . toAdjacencyMap + + -- | Check if a given graph is /acyclic/. + -- + -- @ + -- isAcyclic == Algebra.Graph.AdjacencyMap.'AM.isAcyclic' . toAdjacencyMap + -- @ + isAcyclic :: Ord (ToVertex t) => t -> Bool + isAcyclic = AM.isAcyclic . toAdjacencyMap + + -- | Convert a value to the corresponding 'AM.AdjacencyMap'. + -- + -- @ + -- toAdjacencyMap == 'foldg' 'AM.empty' 'AM.vertex' 'AM.overlay' 'AM.connect' + -- @ + toAdjacencyMap :: Ord (ToVertex t) => t -> AM.AdjacencyMap (ToVertex t) + toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect + + -- | Convert a value to the corresponding 'AM.AdjacencyMap' and transpose the + -- result. + -- + -- @ + -- toAdjacencyMapTranspose == 'foldg' 'AM.empty' 'AM.vertex' 'AM.overlay' (flip 'AM.connect') + -- @ + toAdjacencyMapTranspose :: Ord (ToVertex t) => t -> AM.AdjacencyMap (ToVertex t) + toAdjacencyMapTranspose = foldg AM.empty AM.vertex AM.overlay (flip AM.connect) + + -- | Convert a value to the corresponding 'AIM.AdjacencyIntMap'. + -- + -- @ + -- toAdjacencyIntMap == 'foldg' 'AIM.empty' 'AIM.vertex' 'AIM.overlay' 'AIM.connect' + -- @ + toAdjacencyIntMap :: ToVertex t ~ Int => t -> AIM.AdjacencyIntMap + toAdjacencyIntMap = foldg AIM.empty AIM.vertex AIM.overlay AIM.connect + + -- | Convert a value to the corresponding 'AIM.AdjacencyIntMap' and transpose + -- the result. + -- + -- @ + -- toAdjacencyIntMapTranspose == 'foldg' 'AIM.empty' 'AIM.vertex' 'AIM.overlay' (flip 'AIM.connect') + -- @ + toAdjacencyIntMapTranspose :: ToVertex t ~ Int => t -> AIM.AdjacencyIntMap + toAdjacencyIntMapTranspose = foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) + + -- | Check if a given forest is a valid /depth-first search/ forest of a + -- graph. + -- + -- @ + -- isDfsForestOf f == Algebra.Graph.AdjacencyMap.'AM.isDfsForestOf' f . toAdjacencyMap + -- @ + isDfsForestOf :: Ord (ToVertex t) => Forest (ToVertex t) -> t -> Bool + isDfsForestOf f = AM.isDfsForestOf f . toAdjacencyMap + + -- | Check if a given list of vertices is a valid /topological sort/ of a + -- graph. + -- + -- @ + -- isTopSortOf vs == Algebra.Graph.AdjacencyMap.'AM.isTopSortOf' vs . toAdjacencyMap + -- @ + isTopSortOf :: Ord (ToVertex t) => [ToVertex t] -> t -> Bool + isTopSortOf vs = AM.isTopSortOf vs . toAdjacencyMap + +instance Ord a => ToGraph (G.Graph a) where + type ToVertex (G.Graph a) = a + toGraph = id + foldg = G.foldg + hasEdge = G.hasEdge + +instance Ord a => ToGraph (AM.AdjacencyMap a) where + type ToVertex (AM.AdjacencyMap a) = a + toGraph = G.stars + . map (fmap Set.toList) + . Map.toList + . AM.adjacencyMap + isEmpty = AM.isEmpty + hasVertex = AM.hasVertex + hasEdge = AM.hasEdge + vertexCount = AM.vertexCount + edgeCount = AM.edgeCount + vertexList = AM.vertexList + vertexSet = AM.vertexSet + vertexIntSet = AM.vertexIntSet + edgeList = AM.edgeList + edgeSet = AM.edgeSet + adjacencyList = AM.adjacencyList + preSet = AM.preSet + postSet = AM.postSet + adjacencyMap = AM.adjacencyMap + adjacencyIntMap = IntMap.fromAscList + . map (fmap $ IntSet.fromAscList . Set.toAscList) + . Map.toAscList + . AM.adjacencyMap + dfsForest = AM.dfsForest + dfsForestFrom = AM.dfsForestFrom + dfs = AM.dfs + reachable = AM.reachable + topSort = AM.topSort + isAcyclic = AM.isAcyclic + toAdjacencyMap = id + toAdjacencyIntMap = AIM.AM . adjacencyIntMap + toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap + toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap + isDfsForestOf = AM.isDfsForestOf + isTopSortOf = AM.isTopSortOf + +instance ToGraph AIM.AdjacencyIntMap where + type ToVertex AIM.AdjacencyIntMap = Int + toGraph = G.stars + . map (fmap IntSet.toList) + . IntMap.toList + . AIM.adjacencyIntMap + isEmpty = AIM.isEmpty + hasVertex = AIM.hasVertex + hasEdge = AIM.hasEdge + vertexCount = AIM.vertexCount + edgeCount = AIM.edgeCount + vertexList = AIM.vertexList + vertexSet = Set.fromAscList . IntSet.toAscList . AIM.vertexIntSet + vertexIntSet = AIM.vertexIntSet + edgeList = AIM.edgeList + edgeSet = AIM.edgeSet + adjacencyList = AIM.adjacencyList + preIntSet = AIM.preIntSet + postIntSet = AIM.postIntSet + adjacencyMap = Map.fromAscList + . map (fmap $ Set.fromAscList . IntSet.toAscList) + . IntMap.toAscList + . AIM.adjacencyIntMap + dfsForest = AIM.dfsForest + dfsForestFrom = AIM.dfsForestFrom + dfs = AIM.dfs + reachable = AIM.reachable + topSort = AIM.topSort + isAcyclic = AIM.isAcyclic + adjacencyIntMap = AIM.adjacencyIntMap + toAdjacencyMap = AM.AM . adjacencyMap + toAdjacencyIntMap = id + toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap + toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap + isDfsForestOf = AIM.isDfsForestOf + isTopSortOf = AIM.isTopSortOf + +-- TODO: Get rid of "Relation.Internal" and move this instance to "Relation". +instance Ord a => ToGraph (R.Relation a) where + type ToVertex (R.Relation a) = a + toGraph r = G.vertices (Set.toList $ R.domain r) `G.overlay` + G.edges (Set.toList $ R.relation r) + isEmpty = R.isEmpty + hasVertex = R.hasVertex + hasEdge = R.hasEdge + vertexCount = R.vertexCount + edgeCount = R.edgeCount + vertexList = R.vertexList + vertexSet = R.vertexSet + vertexIntSet = R.vertexIntSet + edgeList = R.edgeList + edgeSet = R.edgeSet + adjacencyList = R.adjacencyList + adjacencyMap = Map.fromAscList + . map (fmap Set.fromAscList) + . R.adjacencyList + adjacencyIntMap = IntMap.fromAscList + . map (fmap IntSet.fromAscList) + . R.adjacencyList + toAdjacencyMap = AM.AM . adjacencyMap + toAdjacencyIntMap = AIM.AM . adjacencyIntMap + toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap + toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap diff --git a/src/Data/Graph/Typed.hs b/src/Data/Graph/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Typed.hs @@ -0,0 +1,160 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Graph.Typed +-- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module provides primitives for interoperability between this library and +-- the "Data.Graph" module of the containers library. It is for internal use only +-- and may be removed without notice at any point. +----------------------------------------------------------------------------- +module Data.Graph.Typed ( + -- * Data type and construction + GraphKL(..), fromAdjacencyMap, fromAdjacencyIntMap, + + -- * Basic algorithms + dfsForest, dfsForestFrom, dfs, topSort + ) where + +import Algebra.Graph.AdjacencyMap.Internal as AM +import Algebra.Graph.AdjacencyIntMap.Internal as AIM + +import Data.Tree +import Data.Maybe + +import qualified Data.Graph as KL +import qualified Data.Map.Strict as Map +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet + +-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in +-- the "Data.Graph" module of the @containers@ library. +data GraphKL a = GraphKL { + -- | Array-based graph representation (King and Launchbury, 1995). + toGraphKL :: KL.Graph, + -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. + -- This is partial and may fail if the vertex is out of bounds. + fromVertexKL :: KL.Vertex -> a, + -- | A mapping from vertices of type @a@ to "Data.Graph.Vertex". + -- Returns 'Nothing' if the argument is not in the graph. + toVertexKL :: a -> Maybe KL.Vertex } + +-- | Build 'GraphKL' from an 'AdjacencyMap'. +-- If @fromAdjacencyMap g == h@ then the following holds: +-- +-- @ +-- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.vertexList' g +-- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.edgeList' g +-- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] +-- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] +-- @ +fromAdjacencyMap :: Ord a => AdjacencyMap a -> GraphKL a +fromAdjacencyMap (AM.AM m) = GraphKL + { toGraphKL = g + , fromVertexKL = \u -> case r u of (_, v, _) -> v + , toVertexKL = t } + where + (g, r, t) = KL.graphFromEdges [ ((), v, Set.toAscList us) | (v, us) <- Map.toAscList m ] + +-- | Build 'GraphKL' from an 'AdjacencyIntMap'. +-- If @fromAdjacencyIntMap g == h@ then the following holds: +-- +-- @ +-- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Data.IntSet.toAscList' ('Algebra.Graph.AdjacencyIntMap.vertexIntSet' g) +-- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyIntMap.edgeList' g +-- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] +-- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] +-- @ +fromAdjacencyIntMap :: AdjacencyIntMap -> GraphKL Int +fromAdjacencyIntMap (AIM.AM m) = GraphKL + { toGraphKL = g + , fromVertexKL = \u -> case r u of (_, v, _) -> v + , toVertexKL = t } + where + (g, r, t) = KL.graphFromEdges [ ((), v, IntSet.toAscList us) | (v, us) <- IntMap.toAscList m ] + +-- | Compute the /depth-first search/ forest of a graph. +-- +-- In the following we will use the helper function: +-- +-- @ +-- (%) :: (GraphKL Int -> a) -> AM.AdjacencyMap Int -> a +-- a % g = a $ fromAdjacencyMap g +-- @ +-- for greater clarity. (One could use an AdjacencyIntMap just as well) +-- +-- @ +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 1 1) == 'AM.vertex' 1 +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.edge' 1 2 +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 2 1) == 'AM.vertices' [1, 2] +-- 'AM.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForest % x) x == True +-- dfsForest % 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % x) == dfsForest % x +-- dfsForest % 'AM.vertices' vs == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- 'Algebra.Graph.AdjacencyMap.dfsForestFrom' ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == dfsForest % x +-- dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 3 +-- , subForest = [ Node { rootLabel = 4 +-- , subForest = [] }]}] +-- @ +dfsForest :: GraphKL a -> Forest a +dfsForest (GraphKL g r _) = fmap (fmap r) (KL.dff g) + +-- | Compute the /depth-first search/ forest of a graph, searching from each of +-- the given vertices in order. Note that the resulting forest does not +-- necessarily span the whole graph, as some vertices may be unreachable. +-- +-- @ +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 1) == 'AM.vertex' 1 +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.edge' 1 2 +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'AM.vertex' 2 +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [3] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'AM.empty' +-- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [2, 1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.vertices' [1, 2] +-- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForestFrom vs % x) x == True +-- dfsForestFrom ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == 'dfsForest' % x +-- dfsForestFrom vs % 'Algebra.Graph.AdjacencyMap.vertices' vs == map (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom [] % x == [] +-- dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- @ +dfsForestFrom :: [a] -> GraphKL a -> Forest a +dfsForestFrom vs (GraphKL g r t) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) + +-- | Compute the list of vertices visited by the /depth-first search/ in a graph, +-- when searching from each of the given vertices in order. +-- +-- @ +-- dfs [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 1 == [1] +-- dfs [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [1,2] +-- dfs [2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [2] +-- dfs [3] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [] +-- dfs [1,2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [1,2] +-- dfs [2,1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [2,1] +-- dfs [] % x == [] +-- dfs [1,4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] +-- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.vertices' $ dfs vs x) x == True +-- @ +dfs :: [a] -> GraphKL a -> [a] +dfs vs = concatMap flatten . dfsForestFrom vs + +-- | Compute the /topological sort/ of a graph. +-- Unlike the (Int)AdjacencyMap algorithm this returns +-- a result even if the graph is cyclic. +-- +-- @ +-- topSort % (1 * 2 + 3 * 1) == [3,1,2] +-- topSort % (1 * 2 + 2 * 1) == [1,2] +-- @ +topSort :: GraphKL a -> [a] +topSort (GraphKL g r _) = map r (KL.topSort g) diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -14,126 +14,84 @@ GraphAPI (..) ) where -import Data.IntSet (IntSet) -import Data.Set (Set) import Data.Tree -import Algebra.Graph.Class hiding (toGraph) +import Algebra.Graph.Class (Graph (..)) -import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap -import qualified Algebra.Graph.Class as Class -import qualified Algebra.Graph.Fold as Fold -import qualified Algebra.Graph as Graph -import qualified Algebra.Graph.IntAdjacencyMap as IntAdjacencyMap -import qualified Algebra.Graph.Relation as Relation -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Algebra.Graph as Graph +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import qualified Algebra.Graph.AdjacencyMap.Internal as AdjacencyMap +import qualified Algebra.Graph.Fold as Fold +import qualified Algebra.Graph.HigherKinded.Class as HClass +import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap +import qualified Algebra.Graph.AdjacencyIntMap.Internal as AdjacencyIntMap +import qualified Algebra.Graph.Relation as Relation +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet class Graph g => GraphAPI g where - edge :: Vertex g -> Vertex g -> g - edge = notImplemented - vertices :: [Vertex g] -> g - vertices = notImplemented - edges :: [(Vertex g, Vertex g)] -> g - edges = notImplemented - overlays :: [g] -> g - overlays = notImplemented - connects :: [g] -> g - connects = notImplemented - fromAdjacencyList :: [(Vertex g, [Vertex g])] -> g - fromAdjacencyList = notImplemented - toGraph :: (Graph h, Vertex g ~ Vertex h) => g -> h - toGraph = notImplemented - foldg :: r -> (Vertex g -> r) -> (r -> r -> r) -> (r -> r -> r) -> g -> r - foldg = notImplemented - isSubgraphOf :: g -> g -> Bool - isSubgraphOf = notImplemented - (===) :: g -> g -> Bool - (===) = notImplemented - isEmpty :: g -> Bool - isEmpty = notImplemented - size :: g -> Int - size = notImplemented - hasVertex :: Vertex g -> g -> Bool - hasVertex = notImplemented - hasEdge :: Vertex g -> Vertex g -> g -> Bool - hasEdge = notImplemented - vertexCount :: g -> Int - vertexCount = notImplemented - edgeCount :: g -> Int - edgeCount = notImplemented - vertexList :: g -> [Vertex g] - vertexList = notImplemented - edgeList :: g -> [(Vertex g, Vertex g)] - edgeList = notImplemented - adjacencyList :: g -> [(Vertex g, [Vertex g])] - adjacencyList = notImplemented - vertexSet :: g -> Set (Vertex g) - vertexSet = notImplemented - vertexIntSet :: Vertex g ~ Int => g -> IntSet - vertexIntSet = notImplemented - edgeSet :: g -> Set (Vertex g, Vertex g) - edgeSet = notImplemented - preSet :: Vertex g -> g -> Set (Vertex g) - preSet = notImplemented - postSet :: Vertex g -> g -> Set (Vertex g) - postSet = notImplemented - postIntSet :: Vertex g ~ Int => Int -> g -> IntSet - postIntSet = notImplemented - path :: [Vertex g] -> g - path = notImplemented - circuit :: [Vertex g] -> g - circuit = notImplemented - clique :: [Vertex g] -> g - clique = notImplemented - biclique :: [Vertex g] -> [Vertex g] -> g - biclique = notImplemented - star :: Vertex g -> [Vertex g] -> g - star = notImplemented - starTranspose :: Vertex g -> [Vertex g] -> g - starTranspose = notImplemented - tree :: Tree (Vertex g) -> g - tree = notImplemented - forest :: Forest (Vertex g) -> g - forest = notImplemented - mesh :: Vertex g ~ (a, b) => [a] -> [b] -> g - mesh = notImplemented - torus :: Vertex g ~ (a, b) => [a] -> [b] -> g - torus = notImplemented - deBruijn :: Vertex g ~ [a] => Int -> [a] -> g - deBruijn = notImplemented - removeVertex :: Vertex g -> g -> g - removeVertex = notImplemented - removeEdge :: Vertex g -> Vertex g -> g -> g - removeEdge = notImplemented - replaceVertex :: Vertex g -> Vertex g -> g -> g - replaceVertex = notImplemented - mergeVertices :: (Vertex g -> Bool) -> Vertex g -> g -> g - mergeVertices = notImplemented - splitVertex :: Vertex g -> [Vertex g] -> g -> g - splitVertex = notImplemented - transpose :: g -> g - transpose = notImplemented - gmap :: Vertex g ~ Int => (Int -> Int) -> g -> g - gmap = notImplemented - induce :: (Vertex g -> Bool) -> g -> g - induce = notImplemented - bind :: Vertex g ~ Int => g -> (Int -> g) -> g - bind = notImplemented - simplify :: g -> g - simplify = notImplemented - box :: forall a b f. (Vertex (f a) ~ a, Vertex (f b) ~ b, Vertex (f (a, b)) ~ (a, b), g ~ f (a, b)) => f a -> f b -> f (a, b) - box = notImplemented - dfsForest :: g -> Forest (Vertex g) - dfsForest = notImplemented - dfsForestFrom :: [Vertex g] -> g -> Forest (Vertex g) - dfsForestFrom = notImplemented - dfs :: [Vertex g] -> g -> [Vertex g] - dfs = notImplemented - topSort :: g -> Maybe [Vertex g] - topSort = notImplemented - isTopSort :: [Vertex g] -> g -> Bool - isTopSort = notImplemented + edge :: Vertex g -> Vertex g -> g + edge = notImplemented + vertices :: [Vertex g] -> g + vertices = notImplemented + edges :: [(Vertex g, Vertex g)] -> g + edges = notImplemented + overlays :: [g] -> g + overlays = notImplemented + connects :: [g] -> g + connects = notImplemented + fromAdjacencySets :: [(Vertex g, Set.Set (Vertex g))] -> g + fromAdjacencySets = notImplemented + fromAdjacencyIntSets :: [(Int, IntSet.IntSet)] -> g + fromAdjacencyIntSets = notImplemented + isSubgraphOf :: g -> g -> Bool + isSubgraphOf = notImplemented + (===) :: g -> g -> Bool + (===) = notImplemented + path :: [Vertex g] -> g + path = notImplemented + circuit :: [Vertex g] -> g + circuit = notImplemented + clique :: [Vertex g] -> g + clique = notImplemented + biclique :: [Vertex g] -> [Vertex g] -> g + biclique = notImplemented + star :: Vertex g -> [Vertex g] -> g + star = notImplemented + stars :: [(Vertex g, [Vertex g])] -> g + stars = notImplemented + tree :: Tree (Vertex g) -> g + tree = notImplemented + forest :: Forest (Vertex g) -> g + forest = notImplemented + mesh :: Vertex g ~ (a, b) => [a] -> [b] -> g + mesh = notImplemented + torus :: Vertex g ~ (a, b) => [a] -> [b] -> g + torus = notImplemented + deBruijn :: Vertex g ~ [a] => Int -> [a] -> g + deBruijn = notImplemented + removeVertex :: Vertex g -> g -> g + removeVertex = notImplemented + removeEdge :: Vertex g -> Vertex g -> g -> g + removeEdge = notImplemented + replaceVertex :: Vertex g -> Vertex g -> g -> g + replaceVertex = notImplemented + mergeVertices :: (Vertex g -> Bool) -> Vertex g -> g -> g + mergeVertices = notImplemented + splitVertex :: Vertex g -> [Vertex g] -> g -> g + splitVertex = notImplemented + transpose :: g -> g + transpose = notImplemented + gmap :: Vertex g ~ Int => (Int -> Int) -> g -> g + gmap = notImplemented + induce :: (Vertex g -> Bool) -> g -> g + induce = notImplemented + bind :: Vertex g ~ Int => g -> (Int -> g) -> g + bind = notImplemented + simplify :: g -> g + simplify = notImplemented + box :: forall a b f. (Vertex (f a) ~ a, Vertex (f b) ~ b, Vertex (f (a, b)) ~ (a, b), g ~ f (a, b)) => f a -> f b -> f (a, b) + box = notImplemented notImplemented :: a notImplemented = error "Not implemented" @@ -144,26 +102,14 @@ edges = AdjacencyMap.edges overlays = AdjacencyMap.overlays connects = AdjacencyMap.connects - fromAdjacencyList = AdjacencyMap.fromAdjacencyList + fromAdjacencySets = AdjacencyMap.fromAdjacencySets isSubgraphOf = AdjacencyMap.isSubgraphOf - isEmpty = AdjacencyMap.isEmpty - hasVertex = AdjacencyMap.hasVertex - hasEdge = AdjacencyMap.hasEdge - vertexCount = AdjacencyMap.vertexCount - edgeCount = AdjacencyMap.edgeCount - vertexList = AdjacencyMap.vertexList - edgeList = AdjacencyMap.edgeList - adjacencyList = AdjacencyMap.adjacencyList - vertexSet = AdjacencyMap.vertexSet - vertexIntSet = IntSet.fromAscList . Set.toAscList . AdjacencyMap.vertexSet - edgeSet = AdjacencyMap.edgeSet - postSet = AdjacencyMap.postSet path = AdjacencyMap.path circuit = AdjacencyMap.circuit clique = AdjacencyMap.clique biclique = AdjacencyMap.biclique star = AdjacencyMap.star - starTranspose = AdjacencyMap.starTranspose + stars = AdjacencyMap.stars tree = AdjacencyMap.tree forest = AdjacencyMap.forest removeVertex = AdjacencyMap.removeVertex @@ -173,11 +119,6 @@ transpose = AdjacencyMap.transpose gmap = AdjacencyMap.gmap induce = AdjacencyMap.induce - dfsForest = AdjacencyMap.dfsForest - dfsForestFrom = AdjacencyMap.dfsForestFrom - dfs = AdjacencyMap.dfs - topSort = AdjacencyMap.topSort - isTopSort = AdjacencyMap.isTopSort instance Ord a => GraphAPI (Fold.Fold a) where edge = Fold.edge @@ -185,42 +126,29 @@ edges = Fold.edges overlays = Fold.overlays connects = Fold.connects - toGraph = Class.toGraph - foldg = Fold.foldg isSubgraphOf = Fold.isSubgraphOf - isEmpty = Fold.isEmpty - size = Fold.size - hasVertex = Fold.hasVertex - hasEdge = Fold.hasEdge - vertexCount = Fold.vertexCount - edgeCount = Fold.edgeCount - vertexList = Fold.vertexList - edgeList = Fold.edgeList - vertexSet = Fold.vertexSet - vertexIntSet = Fold.vertexIntSet - edgeSet = Fold.edgeSet path = Fold.path circuit = Fold.circuit clique = Fold.clique biclique = Fold.biclique star = Fold.star - starTranspose = Fold.starTranspose - tree = Fold.tree - forest = Fold.forest - mesh = Fold.mesh - torus = Fold.torus - deBruijn = Fold.deBruijn + stars = Fold.stars + tree = HClass.tree + forest = HClass.forest + mesh = HClass.mesh + torus = HClass.torus + deBruijn = HClass.deBruijn removeVertex = Fold.removeVertex removeEdge = Fold.removeEdge - replaceVertex = Fold.replaceVertex - mergeVertices = Fold.mergeVertices - splitVertex = Fold.splitVertex + replaceVertex = HClass.replaceVertex + mergeVertices = HClass.mergeVertices + splitVertex = HClass.splitVertex transpose = Fold.transpose gmap = fmap induce = Fold.induce bind = (>>=) simplify = Fold.simplify - box = Fold.box + box = HClass.box instance Ord a => GraphAPI (Graph.Graph a) where edge = Graph.edge @@ -228,27 +156,14 @@ edges = Graph.edges overlays = Graph.overlays connects = Graph.connects - toGraph = Class.toGraph - foldg = Graph.foldg isSubgraphOf = Graph.isSubgraphOf (===) = (Graph.===) - isEmpty = Graph.isEmpty - size = Graph.size - hasVertex = Graph.hasVertex - hasEdge = Graph.hasEdge - vertexCount = Graph.vertexCount - edgeCount = Graph.edgeCount - vertexList = Graph.vertexList - edgeList = Graph.edgeList - vertexSet = Graph.vertexSet - vertexIntSet = Graph.vertexIntSet - edgeSet = Graph.edgeSet path = Graph.path circuit = Graph.circuit clique = Graph.clique biclique = Graph.biclique star = Graph.star - starTranspose = Graph.starTranspose + stars = Graph.stars tree = Graph.tree forest = Graph.forest mesh = Graph.mesh @@ -266,80 +181,49 @@ simplify = Graph.simplify box = Graph.box -instance GraphAPI IntAdjacencyMap.IntAdjacencyMap where - edge = IntAdjacencyMap.edge - vertices = IntAdjacencyMap.vertices - edges = IntAdjacencyMap.edges - overlays = IntAdjacencyMap.overlays - connects = IntAdjacencyMap.connects - fromAdjacencyList = IntAdjacencyMap.fromAdjacencyList - isSubgraphOf = IntAdjacencyMap.isSubgraphOf - isEmpty = IntAdjacencyMap.isEmpty - hasVertex = IntAdjacencyMap.hasVertex - hasEdge = IntAdjacencyMap.hasEdge - vertexCount = IntAdjacencyMap.vertexCount - edgeCount = IntAdjacencyMap.edgeCount - vertexList = IntAdjacencyMap.vertexList - edgeList = IntAdjacencyMap.edgeList - postIntSet = IntAdjacencyMap.postIntSet - adjacencyList = IntAdjacencyMap.adjacencyList - vertexSet = Set.fromAscList . IntSet.toAscList . IntAdjacencyMap.vertexIntSet - vertexIntSet = IntAdjacencyMap.vertexIntSet - edgeSet = IntAdjacencyMap.edgeSet - path = IntAdjacencyMap.path - circuit = IntAdjacencyMap.circuit - clique = IntAdjacencyMap.clique - biclique = IntAdjacencyMap.biclique - star = IntAdjacencyMap.star - starTranspose = IntAdjacencyMap.starTranspose - tree = IntAdjacencyMap.tree - forest = IntAdjacencyMap.forest - removeVertex = IntAdjacencyMap.removeVertex - removeEdge = IntAdjacencyMap.removeEdge - replaceVertex = IntAdjacencyMap.replaceVertex - mergeVertices = IntAdjacencyMap.mergeVertices - transpose = IntAdjacencyMap.transpose - gmap = IntAdjacencyMap.gmap - induce = IntAdjacencyMap.induce - dfsForest = IntAdjacencyMap.dfsForest - dfsForestFrom = IntAdjacencyMap.dfsForestFrom - dfs = IntAdjacencyMap.dfs - topSort = IntAdjacencyMap.topSort - isTopSort = IntAdjacencyMap.isTopSort +instance GraphAPI AdjacencyIntMap.AdjacencyIntMap where + edge = AdjacencyIntMap.edge + vertices = AdjacencyIntMap.vertices + edges = AdjacencyIntMap.edges + overlays = AdjacencyIntMap.overlays + connects = AdjacencyIntMap.connects + fromAdjacencyIntSets = AdjacencyIntMap.fromAdjacencyIntSets + isSubgraphOf = AdjacencyIntMap.isSubgraphOf + path = AdjacencyIntMap.path + circuit = AdjacencyIntMap.circuit + clique = AdjacencyIntMap.clique + biclique = AdjacencyIntMap.biclique + star = AdjacencyIntMap.star + stars = AdjacencyIntMap.stars + tree = AdjacencyIntMap.tree + forest = AdjacencyIntMap.forest + removeVertex = AdjacencyIntMap.removeVertex + removeEdge = AdjacencyIntMap.removeEdge + replaceVertex = AdjacencyIntMap.replaceVertex + mergeVertices = AdjacencyIntMap.mergeVertices + transpose = AdjacencyIntMap.transpose + gmap = AdjacencyIntMap.gmap + induce = AdjacencyIntMap.induce instance Ord a => GraphAPI (Relation.Relation a) where - edge = Relation.edge - vertices = Relation.vertices - edges = Relation.edges - overlays = Relation.overlays - connects = Relation.connects - fromAdjacencyList = Relation.fromAdjacencyList - isSubgraphOf = Relation.isSubgraphOf - isEmpty = Relation.isEmpty - hasVertex = Relation.hasVertex - hasEdge = Relation.hasEdge - vertexCount = Relation.vertexCount - edgeCount = Relation.edgeCount - vertexList = Relation.vertexList - edgeList = Relation.edgeList - preSet = Relation.preSet - postSet = Relation.postSet - adjacencyList = AdjacencyMap.adjacencyList . Class.toGraph - vertexSet = Relation.vertexSet - vertexIntSet = IntSet.fromAscList . Set.toAscList . Relation.vertexSet - edgeSet = Relation.edgeSet - path = Relation.path - circuit = Relation.circuit - clique = Relation.clique - biclique = Relation.biclique - star = Relation.star - starTranspose = Relation.starTranspose - tree = Relation.tree - forest = Relation.forest - removeVertex = Relation.removeVertex - removeEdge = Relation.removeEdge - replaceVertex = Relation.replaceVertex - mergeVertices = Relation.mergeVertices - transpose = Relation.transpose - gmap = Relation.gmap - induce = Relation.induce + edge = Relation.edge + vertices = Relation.vertices + edges = Relation.edges + overlays = Relation.overlays + connects = Relation.connects + isSubgraphOf = Relation.isSubgraphOf + path = Relation.path + circuit = Relation.circuit + clique = Relation.clique + biclique = Relation.biclique + star = Relation.star + stars = Relation.stars + tree = Relation.tree + forest = Relation.forest + removeVertex = Relation.removeVertex + removeEdge = Relation.removeEdge + replaceVertex = Relation.replaceVertex + mergeVertices = Relation.mergeVertices + transpose = Relation.transpose + gmap = Relation.gmap + induce = Relation.induce diff --git a/test/Algebra/Graph/Test/AdjacencyIntMap.hs b/test/Algebra/Graph/Test/AdjacencyIntMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/AdjacencyIntMap.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.AdjacencyIntMap +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.AdjacencyIntMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.AdjacencyIntMap ( + -- * Testsuite + testAdjacencyIntMap + ) where + +import Algebra.Graph.AdjacencyIntMap +import Algebra.Graph.AdjacencyIntMap.Internal +import Algebra.Graph.Test +import Algebra.Graph.Test.Generic + +t :: Testsuite +t = testsuite "AdjacencyIntMap." empty + +testAdjacencyIntMap :: IO () +testAdjacencyIntMap = do + putStrLn "\n============ AdjacencyIntMap ============" + test "Axioms of graphs" (axioms :: GraphTestsuite AdjacencyIntMap) + + test "Consistency of arbitraryAdjacencyMap" $ \m -> + consistent m + + testShow t + testBasicPrimitives t + testFromAdjacencyIntSets t + testIsSubgraphOf t + testToGraph t + testGraphFamilies t + testTransformations t + testDfsForest t + testDfsForestFrom t + testDfs t + testReachable t + testTopSort t + testIsAcyclic t + testIsDfsForestOf t + testIsTopSortOf t diff --git a/test/Algebra/Graph/Test/AdjacencyMap.hs b/test/Algebra/Graph/Test/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyMap.hs @@ -18,7 +18,6 @@ import Algebra.Graph.Test import Algebra.Graph.Test.Generic -import qualified Data.Graph as KL import qualified Data.Set as Set t :: Testsuite @@ -34,23 +33,21 @@ test "Consistency of arbitraryAdjacencyMap" $ \(m :: AI) -> consistent m - test "Consistency of fromAdjacencyList" $ \xs -> - consistent (fromAdjacencyList xs :: AI) - testShow t testBasicPrimitives t - testFromAdjacencyList t + testFromAdjacencySets t testIsSubgraphOf t - testProperties t - testAdjacencyList t - testPostSet t + testToGraph t testGraphFamilies t testTransformations t testDfsForest t testDfsForestFrom t testDfs t + testReachable t testTopSort t - testIsTopSort t + testIsAcyclic t + testIsDfsForestOf t + testIsTopSortOf t putStrLn "\n============ AdjacencyMap.scc ============" test "scc empty == empty" $ @@ -70,12 +67,3 @@ , (Set.fromList [1,4], Set.fromList [5] ) , (Set.fromList [3] , Set.fromList [1,4]) , (Set.fromList [3] , Set.fromList [5 :: Int])] - - putStrLn "\n============ AdjacencyMap.Internal.GraphKL ============" - test "map (fromVertexKL h) (vertices $ toGraphKL h) == vertexList g" - $ \(g :: AI) -> let h = mkGraphKL (adjacencyMap g) in - map (fromVertexKL h) (KL.vertices $ toGraphKL h) == vertexList g - - test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" - $ \(g :: AI) -> let h = mkGraphKL (adjacencyMap g) in - map ( \(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == edgeList g diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Test.Arbitrary ( -- * Generators of arbitrary graph instances - arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, arbitraryIntAdjacencyMap + arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, arbitraryAdjacencyIntMap ) where import Prelude () @@ -25,13 +25,13 @@ import Algebra.Graph.AdjacencyMap.Internal import Algebra.Graph.Export import Algebra.Graph.Fold (Fold) -import Algebra.Graph.IntAdjacencyMap.Internal +import Algebra.Graph.AdjacencyIntMap.Internal import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.InternalDerived import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.IntAdjacencyMap as IntAdjacencyMap +import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap import qualified Algebra.Graph.NonEmpty as NE import qualified Algebra.Graph.Relation as Relation @@ -78,17 +78,17 @@ -- | Generate an arbitrary 'Relation'. arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation a) -arbitraryRelation = Relation.fromAdjacencyList <$> arbitrary +arbitraryRelation = Relation.stars <$> arbitrary -- | Generate an arbitrary 'AdjacencyMap'. It is guaranteed that the -- resulting adjacency map is 'consistent'. arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AdjacencyMap a) -arbitraryAdjacencyMap = AdjacencyMap.fromAdjacencyList <$> arbitrary +arbitraryAdjacencyMap = AdjacencyMap.stars <$> arbitrary --- | Generate an arbitrary 'IntAdjacencyMap'. It is guaranteed that the +-- | Generate an arbitrary 'AdjacencyIntMap'. It is guaranteed that the -- resulting adjacency map is 'consistent'. -arbitraryIntAdjacencyMap :: Gen IntAdjacencyMap -arbitraryIntAdjacencyMap = IntAdjacencyMap.fromAdjacencyList <$> arbitrary +arbitraryAdjacencyIntMap :: Gen AdjacencyIntMap +arbitraryAdjacencyIntMap = AdjacencyIntMap.stars <$> arbitrary -- TODO: Implement a custom shrink method. instance (Arbitrary a, Ord a) => Arbitrary (Relation a) where @@ -109,8 +109,8 @@ instance (Arbitrary a, Ord a) => Arbitrary (AdjacencyMap a) where arbitrary = arbitraryAdjacencyMap -instance Arbitrary IntAdjacencyMap where - arbitrary = arbitraryIntAdjacencyMap +instance Arbitrary AdjacencyIntMap where + arbitrary = arbitraryAdjacencyIntMap instance Arbitrary a => Arbitrary (Fold a) where arbitrary = arbitraryGraph diff --git a/test/Algebra/Graph/Test/Fold.hs b/test/Algebra/Graph/Test/Fold.hs --- a/test/Algebra/Graph/Test/Fold.hs +++ b/test/Algebra/Graph/Test/Fold.hs @@ -21,10 +21,7 @@ t :: Testsuite t = testsuite "Fold." (empty :: Fold Int) -h :: HTestsuite -h = hTestsuite "Fold." (empty :: Fold Int) - -type F = Fold Int +type F = Fold Int testFold :: IO () testFold = do @@ -33,101 +30,11 @@ testShow t testBasicPrimitives t - testToGraph h testIsSubgraphOf t + testToGraph t testSize t - testProperties t testGraphFamilies t testTransformations t - - putStrLn "\n============ Fold.mesh ============" - test "mesh xs [] == empty" $ \xs -> - mesh xs [] == (empty :: Fold (Int, Int)) - - test "mesh [] ys == empty" $ \ys -> - mesh [] ys == (empty :: Fold (Int, Int)) - - test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> - mesh [x] [y] == (vertex (x, y) :: Fold (Int, Int)) - - test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - mesh xs ys == (box (path xs) (path ys) :: Fold (Int, Int)) - - test "mesh [1..3] \"ab\" == " $ - (mesh [1..3] "ab" :: Fold (Int, Char)) == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) - , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3,'b')) ] - - putStrLn "\n============ Fold.torus ============" - test "torus xs [] == empty" $ \xs -> - torus xs [] == (empty :: Fold (Int, Int)) - - test "torus [] ys == empty" $ \ys -> - torus [] ys == (empty :: Fold (Int, Int)) - - test "torus [x] [y] == edge (x, y) (x, y)" $ \(x :: Int) (y :: Int) -> - torus [x] [y] == (edge (x, y) (x, y) :: Fold (Int, Int)) - - test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - torus xs ys == (box (circuit xs) (circuit ys) :: Fold (Int, Int)) - - test "torus [1,2] \"ab\" == " $ - (torus [1,2] "ab" :: Fold (Int, Char)) == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) - , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2,'a')) ] - - putStrLn "\n============ Fold.deBruijn ============" - test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> - deBruijn 0 xs ==(edge [] [] :: Fold [Int]) - - test "n > 0 ==> deBruijn n [] == empty" $ \n -> - n > 0 ==> deBruijn n [] == (empty :: Fold [Int]) - - test " deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ - deBruijn 1 [0,1] ==(edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] :: Fold [Int]) - - test " deBruijn 2 \"0\" == edge \"00\" \"00\"" $ - deBruijn 2 "0" ==(edge "00" "00" :: Fold String) - - test " deBruijn 2 \"01\" == " $ - deBruijn 2 "01" ==(edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") - , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] :: Fold String) - - test " transpose (deBruijn n xs) == gmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - transpose (deBruijn n xs) == ((gmap reverse $ deBruijn n xs) :: Fold [Int]) - - test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n - - test "n > 0 ==> edgeCount (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - n > 0 ==> edgeCount (deBruijn n xs) == (length $ nubOrd xs)^(n + 1) - - testSplitVertex t - testBind t - testSimplify t - - putStrLn "\n============ Fold.box ============" - let unit = fmap $ \(a, ()) -> a - comm = fmap $ \(a, b) -> (b, a) - test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: F) (y :: F) -> - comm (box x y) == (box y x :: Fold (Int, Int)) - - test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: F) (y :: F) z -> - box x (overlay y z) == (overlay (box x y) (box x z) :: Fold (Int, Int)) - - test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: F) -> - unit(box x (vertex ())) == x - - test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: F) -> - unit(box x empty) == empty - - let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) - test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: F) (y :: F) (z :: F) -> - assoc (box x (box y z)) == (box (box x y) z :: Fold ((Int, Int), Int)) - - test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: F) (y :: F) -> - transpose (box x y) == (box (transpose x) (transpose y) :: Fold (Int, Int)) - - test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: F) (y :: F) -> - vertexCount (box x y) == vertexCount x * vertexCount y - - test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: F) (y :: F) -> - edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + testSplitVertex t + testBind t + testSimplify t diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -11,11 +11,12 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Test.Generic ( -- * Generic tests - Testsuite, testsuite, HTestsuite, hTestsuite, testShow, testFromAdjacencyList, - testBasicPrimitives, testToGraph, testIsSubgraphOf, testSize, testProperties, - testAdjacencyList, testPreSet, testPostSet, testPostIntSet, testGraphFamilies, - testTransformations, testDfsForest, testDfsForestFrom, testDfs, testTopSort, - testIsTopSort, testSplitVertex, testBind, testSimplify + Testsuite, testsuite, testShow, testFromAdjacencySets, + testFromAdjacencyIntSets, testBasicPrimitives, testIsSubgraphOf, testSize, + testToGraph, testAdjacencyList, testPreSet, testPreIntSet, testPostSet, + testPostIntSet, testGraphFamilies, testTransformations, testSplitVertex, + testBind, testSimplify, testDfsForest, testDfsForestFrom, testDfs, + testReachable, testTopSort, testIsAcyclic, testIsDfsForestOf, testIsTopSortOf ) where import Prelude () @@ -24,36 +25,31 @@ import Control.Monad (when) import Data.Orphans () -import Data.Foldable (toList) import Data.List (nub) +import Data.Maybe import Data.Tree import Data.Tuple +import Algebra.Graph (Graph (..)) import Algebra.Graph.Class (Graph (..)) +import Algebra.Graph.ToGraph (ToGraph (..)) import Algebra.Graph.Test import Algebra.Graph.Test.API -import Algebra.Graph.Relation (Relation) -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet data Testsuite where - Testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int) + Testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) => String -> (forall r. (g -> r) -> g -> r) -> Testsuite -testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int) +testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) => String -> g -> Testsuite testsuite prefix g = Testsuite prefix (\f x -> f (x `asTypeOf` g)) -data HTestsuite where - HTestsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int, - g ~ f Int, Foldable f) - => String -> (forall r. (g -> r) -> g -> r) -> HTestsuite - -hTestsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int, - g ~ f Int, Foldable f) => String -> g -> HTestsuite -hTestsuite prefix g = HTestsuite prefix (\f x -> f (x `asTypeOf` g)) - testBasicPrimitives :: Testsuite -> IO () testBasicPrimitives = mconcat [ testEmpty , testVertex @@ -65,17 +61,24 @@ , testOverlays , testConnects ] -testProperties :: Testsuite -> IO () -testProperties = mconcat [ testIsEmpty - , testHasVertex - , testHasEdge - , testVertexCount - , testEdgeCount - , testVertexList - , testEdgeList - , testVertexSet - , testVertexIntSet - , testEdgeSet ] +testToGraph :: Testsuite -> IO () +testToGraph = mconcat [ testToGraphDefault + , testFoldg + , testIsEmpty + , testHasVertex + , testHasEdge + , testVertexCount + , testEdgeCount + , testVertexList + , testVertexSet + , testVertexIntSet + , testEdgeList + , testEdgeSet + , testAdjacencyList + , testPreSet + , testPreIntSet + , testPostSet + , testPostIntSet ] testGraphFamilies :: Testsuite -> IO () testGraphFamilies = mconcat [ testPath @@ -83,7 +86,7 @@ , testClique , testBiclique , testStar - , testStarTranspose + , testStars , testTree , testForest ] @@ -291,55 +294,66 @@ test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \xs -> isEmpty % connects xs == all isEmpty xs -testFromAdjacencyList :: Testsuite -> IO () -testFromAdjacencyList (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyList ============" - test "fromAdjacencyList [] == empty" $ - fromAdjacencyList [] == id % empty +testStars :: Testsuite -> IO () +testStars (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "stars ============" + test "stars [] == empty" $ + stars [] == id % empty - test "fromAdjacencyList [(x, [])] == vertex x" $ \x -> - fromAdjacencyList [(x, [])] == id % vertex x + test "stars [(x, [])] == vertex x" $ \x -> + stars [(x, [])] == id % vertex x - test "fromAdjacencyList [(x, [y])] == edge x y" $ \x y -> - fromAdjacencyList [(x, [y])] == id % edge x y + test "stars [(x, [y])] == edge x y" $ \x y -> + stars [(x, [y])] == id % edge x y - test "fromAdjacencyList . adjacencyList == id" $ \x -> - (fromAdjacencyList . adjacencyList) % x == x + test "stars [(x, ys)] == star x ys" $ \x ys -> + stars [(x, ys)] == id % star x ys - test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencyList xs) % fromAdjacencyList ys == fromAdjacencyList (xs ++ ys) + test "stars == overlays . map (uncurry star)" $ \xs -> + stars xs == id % overlays (map (uncurry star) xs) -testToGraph :: HTestsuite -> IO () -testToGraph (HTestsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "toGraph ============" - test " toGraph (g :: Graph a ) :: Graph a == g" $ \g -> - toGraph % g == g + test "stars . adjacencyList == id" $ \x -> + (stars . adjacencyList) x == id % x - test "show (toGraph (1 * 2 :: Graph Int) :: Relation Int) == \"edge 1 2\"" $ - show (toGraph % (1 * 2) :: Relation Int) == "edge 1 2" + test "overlay (stars xs) (stars ys) == stars (xs ++ ys)" $ \xs ys -> + overlay (stars xs) % stars ys == stars (xs ++ ys) - test "\ntoGraph == foldg empty vertex overlay connect" $ \x -> - toGraph % x == id % foldg empty vertex overlay connect x +testFromAdjacencySets :: Testsuite -> IO () +testFromAdjacencySets (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencySets ============" + test "fromAdjacencySets [] == empty" $ + fromAdjacencySets [] == id % empty - putStrLn $ "\n============ " ++ prefix ++ "foldg ============" - test "foldg empty vertex overlay connect == id" $ \x -> - foldg empty vertex overlay connect x == id % x + test "fromAdjacencySets [(x, Set.empty)] == vertex x" $ \x -> + fromAdjacencySets [(x, Set.empty)] == id % vertex x - test "foldg empty vertex overlay (flip connect) == transpose" $ \x -> - foldg empty vertex overlay (flip connect)x== transpose % x + test "fromAdjacencySets [(x, Set.singleton y)] == edge x y" $ \x y -> + fromAdjacencySets [(x, Set.singleton y)] == id % edge x y - test "foldg [] return (++) (++) == toList" $ \x -> - foldg [] return (++) (++) x == toList % x + test "fromAdjacencySets . map (fmap Set.fromList) . adjacencyList == id" $ \x -> + (fromAdjacencySets . map (fmap Set.fromList) . adjacencyList) % x == x - test "foldg 0 (const 1) (+) (+) == length" $ \x -> - foldg 0 (const 1) (+) (+) x == length % x + test "overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencySets xs) % fromAdjacencySets ys == fromAdjacencySets (xs ++ ys) - test "foldg 1 (const 1) (+) (+) == size" $ \x -> - foldg 1 (const 1) (+) (+) x == size % x +testFromAdjacencyIntSets :: Testsuite -> IO () +testFromAdjacencyIntSets (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyIntSets ============" + test "fromAdjacencyIntSets [] == empty" $ + fromAdjacencyIntSets [] == id % empty - test "foldg True (const False) (&&) (&&) == isEmpty" $ \x -> - foldg True (const False) (&&) (&&) x == isEmpty % x + test "fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x" $ \x -> + fromAdjacencyIntSets [(x, IntSet.empty)] == id % vertex x + test "fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y" $ \x y -> + fromAdjacencyIntSets [(x, IntSet.singleton y)] == id % edge x y + + test "fromAdjacencyIntSets . map (fmap IntSet.fromList) . adjacencyList == id" $ \x -> + (fromAdjacencyIntSets . map (fmap IntSet.fromList) . adjacencyList) % x == x + + test "overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyIntSets xs) % fromAdjacencyIntSets ys == fromAdjacencyIntSets (xs ++ ys) + testIsSubgraphOf :: Testsuite -> IO () testIsSubgraphOf (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "isSubgraphOf ============" @@ -358,6 +372,129 @@ test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> isSubgraphOf (path xs) % circuit xs == True +testToGraphDefault :: Testsuite -> IO () +testToGraphDefault (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" + test "toGraph == foldg Empty Vertex Overlay Connect" $ \x -> + toGraph % x == foldg Empty Vertex Overlay Connect x + + test "foldg == Algebra.Graph.foldg . toGraph" $ \e (apply -> v) (applyFun2 -> o) (applyFun2 -> c) x -> + foldg e v o c x == (G.foldg (e :: Int) v o c . toGraph) % x + + test "isEmpty == foldg True (const False) (&&) (&&)" $ \x -> + isEmpty x == foldg True (const False) (&&) (&&) % x + + test "size == foldg 1 (const 1) (+) (+)" $ \x -> + size x == foldg 1 (const 1) (+) (+) % x + + test "hasVertex x == foldg False (==x) (||) (||)" $ \x y -> + hasVertex x y == foldg False (==x) (||) (||) % y + + test "hasEdge x y == Algebra.Graph.hasEdge x y . toGraph" $ \x y z -> + hasEdge x y z == (G.hasEdge x y . toGraph) % z + + test "vertexCount == Set.size . vertexSet" $ \x -> + vertexCount x == (Set.size . vertexSet) % x + + test "edgeCount == Set.size . edgeSet" $ \x -> + edgeCount x == (Set.size . edgeSet) % x + + test "vertexList == Set.toAscList . vertexSet" $ \x -> + vertexList x == (Set.toAscList . vertexSet) % x + + test "edgeList == Set.toAscList . edgeSet" $ \x -> + edgeList x == (Set.toAscList . edgeSet) % x + + test "vertexSet == foldg Set.empty Set.singleton Set.union Set.union" $ \x -> + vertexSet x == foldg Set.empty Set.singleton Set.union Set.union % x + + test "vertexIntSet == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union" $ \x -> + vertexIntSet x == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union % x + + test "edgeSet == Algebra.Graph.AdjacencyMap.edgeSet . foldg empty vertex overlay connect" $ \x -> + edgeSet x == (AM.edgeSet . foldg empty vertex overlay connect) % x + + test "preSet x == Algebra.Graph.AdjacencyMap.preSet x . toAdjacencyMap" $ \x y -> + preSet x y == (AM.preSet x . toAdjacencyMap) % y + + test "preIntSet x == Algebra.Graph.AdjacencyIntMap.preIntSet x . toAdjacencyIntMap" $ \x y -> + preIntSet x y == (AIM.preIntSet x . toAdjacencyIntMap) % y + + test "postSet x == Algebra.Graph.AdjacencyMap.postSet x . toAdjacencyMap" $ \x y -> + postSet x y == (AM.postSet x . toAdjacencyMap) % y + + test "postIntSet x == Algebra.Graph.AdjacencyIntMap.postIntSet x . toAdjacencyIntMap" $ \x y -> + postIntSet x y == (AIM.postIntSet x . toAdjacencyIntMap) % y + + test "adjacencyList == Algebra.Graph.AdjacencyMap.adjacencyList . toAdjacencyMap" $ \x -> + adjacencyList x == (AM.adjacencyList . toAdjacencyMap) % x + + test "adjacencyMap == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMap" $ \x -> + adjacencyMap x == (AM.adjacencyMap . toAdjacencyMap) % x + + test "adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMap" $ \x -> + adjacencyIntMap x == (AIM.adjacencyIntMap . toAdjacencyIntMap) % x + + test "adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMapTranspose" $ \x -> + adjacencyMapTranspose x == (AM.adjacencyMap . toAdjacencyMapTranspose) % x + + test "adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMapTranspose" $ \x -> + adjacencyIntMapTranspose x == (AIM.adjacencyIntMap . toAdjacencyIntMapTranspose) % x + + test "dfsForest == Algebra.Graph.AdjacencyMap.dfsForest . toAdjacencyMap" $ \x -> + dfsForest x == (AM.dfsForest . toAdjacencyMap) % x + + test "dfsForestFrom vs == Algebra.Graph.AdjacencyMap.dfsForestFrom vs . toAdjacencyMap" $ \vs x -> + dfsForestFrom vs x == (AM.dfsForestFrom vs . toAdjacencyMap) % x + + test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> + dfs vs x == (AM.dfs vs . toAdjacencyMap) % x + + test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable x . toAdjacencyMap) % y + + test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> + topSort x == (AM.topSort . toAdjacencyMap) % x + + test "isAcyclic == Algebra.Graph.AdjacencyMap.isAcyclic . toAdjacencyMap" $ \x -> + isAcyclic x == (AM.isAcyclic . toAdjacencyMap) % x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x + + test "toAdjacencyMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyMap x == foldg AM.empty AM.vertex AM.overlay AM.connect % x + + test "toAdjacencyMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyMapTranspose x == foldg AM.empty AM.vertex AM.overlay (flip AM.connect) % x + + test "toAdjacencyIntMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyIntMap x == foldg AIM.empty AIM.vertex AIM.overlay AIM.connect % x + + test "toAdjacencyIntMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyIntMapTranspose x == foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) % x + + test "isDfsForestOf f == Algebra.Graph.AdjacencyMap.isDfsForestOf f . toAdjacencyMap" $ \f x -> + isDfsForestOf f x == (AM.isDfsForestOf f . toAdjacencyMap) % x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x + +testFoldg :: Testsuite -> IO () +testFoldg (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "foldg ============" + test "foldg empty vertex overlay connect == id" $ \x -> + foldg empty vertex overlay connect % x == id x + + test "foldg empty vertex overlay (flip connect) == transpose" $ \x -> + foldg empty vertex overlay (flip connect) % x == transpose x + + test "foldg 1 (const 1) (+) (+) == size" $ \x -> + foldg 1 (const 1) (+) (+) % x == size x + + test "foldg True (const False) (&&) (&&) == isEmpty" $ \x -> + foldg True (const False) (&&) (&&) % x == isEmpty x + testIsEmpty :: Testsuite -> IO () testIsEmpty (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "isEmpty ============" @@ -578,6 +715,21 @@ test "postSet 2 (edge 1 2) == Set.empty" $ postSet 2 % edge 1 2 == Set.empty +testPreIntSet :: Testsuite -> IO () +testPreIntSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "preIntSet ============" + test "preIntSet x empty == IntSet.empty" $ \x -> + preIntSet x % empty == IntSet.empty + + test "preIntSet x (vertex x) == IntSet.empty" $ \x -> + preIntSet x % vertex x == IntSet.empty + + test "preIntSet 1 (edge 1 2) == IntSet.empty" $ + preIntSet 1 % edge 1 2 == IntSet.empty + + test "preIntSet y (edge x y) == IntSet.fromList [x]" $ \x y -> + preIntSet y % edge x y == IntSet.fromList [x] + testPostIntSet :: Testsuite -> IO () testPostIntSet (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "postIntSet ============" @@ -587,12 +739,12 @@ test "postIntSet x (vertex x) == IntSet.empty" $ \x -> postIntSet x % vertex x == IntSet.empty - test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> - postIntSet x % edge x y == IntSet.fromList [y] - test "postIntSet 2 (edge 1 2) == IntSet.empty" $ postIntSet 2 % edge 1 2 == IntSet.empty + test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> + postIntSet x % edge x y == IntSet.fromList [y] + testPath :: Testsuite -> IO () testPath (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "path ============" @@ -668,24 +820,6 @@ test "star x ys == connect (vertex x) (vertices ys)" $ \x ys -> star x ys == connect (vertex x) % (vertices ys) -testStarTranspose :: Testsuite -> IO () -testStarTranspose (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "starTranspose ============" - test "starTranspose x [] == vertex x" $ \x -> - starTranspose x [] == id % vertex x - - test "starTranspose x [y] == edge y x" $ \x y -> - starTranspose x [y] == id % edge y x - - test "starTranspose x [y,z] == edges [(y,x), (z,x)]" $ \x y z -> - starTranspose x [y,z] == id % edges [(y,x), (z,x)] - - test "starTranspose x ys == connect (vertices ys) (vertex x)" $ \x ys -> - starTranspose x ys == connect (vertices ys) % (vertex x) - - test "starTranspose x ys == transpose (star x ys)" $ \x ys -> - starTranspose x ys == transpose % (star x ys) - testTree :: Testsuite -> IO () testTree (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "tree ============" @@ -737,8 +871,8 @@ testRemoveEdge :: Testsuite -> IO () testRemoveEdge (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "removeEdge ============" - test "removeEdge x y (edge x y) == vertices [x, y]" $ \x y -> - removeEdge x y % edge x y == vertices [x, y] + test "removeEdge x y (edge x y) == vertices [x,y]" $ \x y -> + removeEdge x y % edge x y == vertices [x,y] test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> (removeEdge x y . removeEdge x y) z == removeEdge x y % z @@ -890,18 +1024,24 @@ testDfsForest :: Testsuite -> IO () testDfsForest (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "dfsForest ============" + test "dfsForest empty == []" $ + dfsForest % empty == [] + test "forest (dfsForest $ edge 1 1) == vertex 1" $ forest (dfsForest % edge 1 1) == id % vertex 1 test "forest (dfsForest $ edge 1 2) == edge 1 2" $ forest (dfsForest % edge 1 2) == id % edge 1 2 - test "forest (dfsForest $ edge 2 1) == vertices [1, 2]" $ - forest (dfsForest % edge 2 1) == id % vertices [1, 2] + test "forest (dfsForest $ edge 2 1) == vertices [1,2]" $ + forest (dfsForest % edge 2 1) == id % vertices [1,2] test "isSubgraphOf (forest $ dfsForest x) x == True" $ \x -> isSubgraphOf (forest $ dfsForest x) % x == True + test "isDfsForestOf (dfsForest x) x == True" $ \x -> + isDfsForestOf (dfsForest x) % x == True + test "dfsForest . forest . dfsForest == dfsForest" $ \x -> dfsForest % forest (dfsForest x) == dfsForest % x @@ -919,99 +1059,210 @@ testDfsForestFrom :: Testsuite -> IO () testDfsForestFrom (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "dfsForestFrom ============" - test "forest (dfsForestFrom [1] $ edge 1 1) == vertex 1" $ - forest (dfsForestFrom [1] % edge 1 1) == id % vertex 1 + test "dfsForestFrom vs empty == []" $ \vs -> + dfsForestFrom vs % empty == [] - test "forest (dfsForestFrom [1] $ edge 1 2) == edge 1 2" $ - forest (dfsForestFrom [1] % edge 1 2) == id % edge 1 2 + test "forest (dfsForestFrom [1] $ edge 1 1) == vertex 1" $ + forest (dfsForestFrom [1] % edge 1 1) == id % vertex 1 - test "forest (dfsForestFrom [2] $ edge 1 2) == vertex 2" $ - forest (dfsForestFrom [2] % edge 1 2) == id % vertex 2 + test "forest (dfsForestFrom [1] $ edge 1 2) == edge 1 2" $ + forest (dfsForestFrom [1] % edge 1 2) == id % edge 1 2 - test "forest (dfsForestFrom [3] $ edge 1 2) == empty" $ - forest (dfsForestFrom [3] % edge 1 2) == id % empty + test "forest (dfsForestFrom [2] $ edge 1 2) == vertex 2" $ + forest (dfsForestFrom [2] % edge 1 2) == id % vertex 2 - test "forest (dfsForestFrom [2, 1] $ edge 1 2) == vertices [1, 2]" $ - forest (dfsForestFrom [2, 1] % edge 1 2) == id % vertices [1, 2] + test "forest (dfsForestFrom [3] $ edge 1 2) == empty" $ + forest (dfsForestFrom [3] % edge 1 2) == id % empty - test "isSubgraphOf (forest $ dfsForestFrom vs x) x == True" $ \vs x -> - isSubgraphOf (forest $ dfsForestFrom vs x) % x == True + test "forest (dfsForestFrom [2,1] $ edge 1 2) == vertices [1,2]" $ + forest (dfsForestFrom [2,1] % edge 1 2) == id % vertices [1,2] - test "dfsForestFrom (vertexList x) x == dfsForest x" $ \x -> - dfsForestFrom (vertexList x) % x == dfsForest % x + test "isSubgraphOf (forest $ dfsForestFrom vs x) x == True" $ \vs x -> + isSubgraphOf (forest $ dfsForestFrom vs x) % x == True - test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> - dfsForestFrom vs % vertices vs == map (\v -> Node v []) (nub vs) + test "isDfsForestOf (dfsForestFrom (vertexList x) x) x == True" $ \x -> + isDfsForestOf (dfsForestFrom (vertexList x) x) % x == True - test "dfsForestFrom [] x == []" $ \x -> - dfsForestFrom [] % x == [] + test "dfsForestFrom (vertexList x) x == dfsForest x" $ \x -> + dfsForestFrom (vertexList x) % x == dfsForest % x - test "dfsForestFrom [1, 4] $ 3 * (1 + 4) * (1 + 5) == " $ - dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 4 - , subForest = [] }] + test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> + dfsForestFrom vs % vertices vs == map (\v -> Node v []) (nub vs) + test "dfsForestFrom [] x == []" $ \x -> + dfsForestFrom [] % x == [] + + test "dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == " $ + dfsForestFrom [1,4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + testDfs :: Testsuite -> IO () testDfs (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "dfs ============" - test "dfs [1] $ edge 1 1 == [1]" $ - dfs [1] % edge 1 1 == [1] + test "dfs vs $ empty == []" $ \vs -> + dfs vs % empty == [] - test "dfs [1] $ edge 1 2 == [1, 2]" $ - dfs [1] % edge 1 2 == [1, 2] + test "dfs [1] $ edge 1 1 == [1]" $ + dfs [1] % edge 1 1 == [1] - test "dfs [2] $ edge 1 2 == [2]" $ - dfs [2] % edge 1 2 == [2] + test "dfs [1] $ edge 1 2 == [1,2]" $ + dfs [1] % edge 1 2 == [1,2] - test "dfs [3] $ edge 1 2 == []" $ - dfs [3] % edge 1 2 == [] + test "dfs [2] $ edge 1 2 == [2]" $ + dfs [2] % edge 1 2 == [2] - test "dfs [1, 2] $ edge 1 2 == [1, 2]" $ - dfs [1, 2] % edge 1 2 == [1, 2] + test "dfs [3] $ edge 1 2 == []" $ + dfs [3] % edge 1 2 == [] - test "dfs [2, 1] $ edge 1 2 == [2, 1]" $ - dfs [2, 1] % edge 1 2 == [2, 1] + test "dfs [1,2] $ edge 1 2 == [1,2]" $ + dfs [1,2] % edge 1 2 == [1,2] - test "dfs [] $ x == []" $ \x -> - dfs [] % x == [] + test "dfs [2,1] $ edge 1 2 == [2,1]" $ + dfs [2,1] % edge 1 2 == [2,1] - test "dfs [1, 4] $ 3 * (1 + 4) * (1 + 5) == [1, 5, 4]" $ - dfs [1, 4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] + test "dfs [] $ x == []" $ \x -> + dfs [] % x == [] + test "dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4]" $ + dfs [1,4] % (3 * (1 + 4) * (1 + 5)) == [1,5,4] + test "isSubgraphOf (vertices $ dfs vs x) x == True" $ \vs x -> isSubgraphOf (vertices $ dfs vs x) % x == True +testReachable :: Testsuite -> IO () +testReachable (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "dfs ============" + test "reachable x $ empty == []" $ \x -> + reachable x % empty == [] + + test "reachable 1 $ vertex 1 == [1]" $ + reachable 1 % vertex 1 == [1] + + test "reachable 1 $ vertex 2 == []" $ + reachable 1 % vertex 2 == [] + + test "reachable 1 $ edge 1 1 == [1]" $ + reachable 1 % edge 1 1 == [1] + + test "reachable 1 $ edge 1 2 == [1,2]" $ + reachable 1 % edge 1 2 == [1,2] + + test "reachable 4 $ path [1..8] == [4..8]" $ + reachable 4 % path [1..8] == [4..8] + + test "reachable 4 $ circuit [1..8] == [4..8] ++ [1..3]" $ + reachable 4 % circuit [1..8] == [4..8] ++ [1..3] + + test "reachable 8 $ clique [8,7..1] == [8] ++ [1..7]" $ + reachable 8 % clique [8,7..1] == [8] ++ [1..7] + + test "isSubgraphOf (vertices $ reachable x y) y == True" $ \x y -> + isSubgraphOf (vertices $ reachable x y) % y == True + testTopSort :: Testsuite -> IO () testTopSort (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "topSort ============" - test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ - topSort % (1 * 2 + 3 * 1) == Just [3,1,2] + test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ + topSort % (1 * 2 + 3 * 1) == Just [3,1,2] - test "topSort (1 * 2 + 2 * 1) == Nothing" $ - topSort % (1 * 2 + 2 * 1) == Nothing + test "topSort (1 * 2 + 2 * 1) == Nothing" $ + topSort % (1 * 2 + 2 * 1) == Nothing - test "fmap (flip isTopSort x) (topSort x) /= Just False" $ \x -> - fmap (flip isTopSort x) (topSort % x) /= Just False + test "fmap (flip isTopSortOf x) (topSort x) /= Just False" $ \x -> + fmap (flip isTopSortOf x) (topSort % x) /= Just False -testIsTopSort :: Testsuite -> IO () -testIsTopSort (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isTopSort ============" - test "isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True" $ - isTopSort [3, 1, 2] % (1 * 2 + 3 * 1) == True +testIsAcyclic :: Testsuite -> IO () +testIsAcyclic (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "testIsAcyclic ============" + test "isAcyclic (1 * 2 + 3 * 1) == True" $ + isAcyclic % (1 * 2 + 3 * 1) == True - test "isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False" $ - isTopSort [1, 2, 3] % (1 * 2 + 3 * 1) == False + test "isAcyclic (1 * 2 + 2 * 1) == False" $ + isAcyclic % (1 * 2 + 2 * 1) == False - test "isTopSort [] (1 * 2 + 3 * 1) == False" $ - isTopSort [] % (1 * 2 + 3 * 1) == False + test "isAcyclic . circuit == null" $ \xs -> + isAcyclic % circuit xs == null xs - test "isTopSort [] empty == True" $ - isTopSort [] % empty == True + test "isAcyclic == isJust . topSort" $ \x -> + isAcyclic % x == isJust (topSort x) - test "isTopSort [x] (vertex x) == True" $ \x -> - isTopSort [x] % vertex x == True +testIsDfsForestOf :: Testsuite -> IO () +testIsDfsForestOf (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "isDfsForestOf ============" + test "isDfsForestOf [] empty == True" $ + isDfsForestOf [] % empty == True - test "isTopSort [x] (edge x x) == False" $ \x -> - isTopSort [x] % edge x x == False + test "isDfsForestOf [] (vertex 1) == False" $ + isDfsForestOf [] % (vertex 1) == False + + test "isDfsForestOf [Node 1 []] (vertex 1) == True" $ + isDfsForestOf [Node 1 []] % (vertex 1) == True + + test "isDfsForestOf [Node 1 []] (vertex 2) == False" $ + isDfsForestOf [Node 1 []] % (vertex 2) == False + + test "isDfsForestOf [Node 1 [], Node 1 []] (vertex 1) == False" $ + isDfsForestOf [Node 1 [], Node 1 []] % (vertex 1) == False + + test "isDfsForestOf [Node 1 []] (edge 1 1) == True" $ + isDfsForestOf [Node 1 []] % (edge 1 1) == True + + test "isDfsForestOf [Node 1 []] (edge 1 2) == False" $ + isDfsForestOf [Node 1 []] % (edge 1 2) == False + + test "isDfsForestOf [Node 1 [], Node 2 []] (edge 1 2) == False" $ + isDfsForestOf [Node 1 [], Node 2 []] % (edge 1 2) == False + + test "isDfsForestOf [Node 2 [], Node 1 []] (edge 1 2) == True" $ + isDfsForestOf [Node 2 [], Node 1 []] % (edge 1 2) == True + + test "isDfsForestOf [Node 1 [Node 2 []]] (edge 1 2) == True" $ + isDfsForestOf [Node 1 [Node 2 []]] % (edge 1 2) == True + + test "isDfsForestOf [Node 1 [], Node 2 []] (vertices [1,2]) == True" $ + isDfsForestOf [Node 1 [], Node 2 []] % (vertices [1,2]) == True + + test "isDfsForestOf [Node 2 [], Node 1 []] (vertices [1,2]) == True" $ + isDfsForestOf [Node 2 [], Node 1 []] % (vertices [1,2]) == True + + test "isDfsForestOf [Node 1 [Node 2 []]] (vertices [1,2]) == False" $ + isDfsForestOf [Node 1 [Node 2 []]] % (vertices [1,2]) == False + + test "isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] (path [1,2,3]) == True" $ + isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] % (path [1,2,3]) == True + + test "isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] (path [1,2,3]) == False" $ + isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] % (path [1,2,3]) == False + + test "isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] (path [1,2,3]) == True" $ + isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] % (path [1,2,3]) == True + + test "isDfsForestOf [Node 2 [Node 3 []], Node 1 []] (path [1,2,3]) == True" $ + isDfsForestOf [Node 2 [Node 3 []], Node 1 []] % (path [1,2,3]) == True + + test "isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] (path [1,2,3]) == False" $ + isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] % (path [1,2,3]) == False + +testIsTopSortOf :: Testsuite -> IO () +testIsTopSortOf (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "isTopSortOf ============" + test "isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True" $ + isTopSortOf [3,1,2] % (1 * 2 + 3 * 1) == True + + test "isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False" $ + isTopSortOf [1,2,3] % (1 * 2 + 3 * 1) == False + + test "isTopSortOf [] (1 * 2 + 3 * 1) == False" $ + isTopSortOf [] % (1 * 2 + 3 * 1) == False + + test "isTopSortOf [] empty == True" $ + isTopSortOf [] % empty == True + + test "isTopSortOf [x] (vertex x) == True" $ \x -> + isTopSortOf [x] % vertex x == True + + test "isTopSortOf [x] (edge x x) == False" $ \x -> + isTopSortOf [x] % edge x x == False diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs --- a/test/Algebra/Graph/Test/Graph.hs +++ b/test/Algebra/Graph/Test/Graph.hs @@ -14,16 +14,16 @@ testGraph ) where +import Data.Either + import Algebra.Graph import Algebra.Graph.Test import Algebra.Graph.Test.Generic +import Algebra.Graph.ToGraph (reachable) t :: Testsuite t = testsuite "Graph." empty -h :: HTestsuite -h = hTestsuite "Graph." empty - type G = Graph Int testGraph :: IO () @@ -33,10 +33,9 @@ test "Theorems of graphs" (theorems :: GraphTestsuite G) testBasicPrimitives t - testToGraph h testIsSubgraphOf t + testToGraph t testSize t - testProperties t testGraphFamilies t testTransformations t @@ -57,39 +56,45 @@ (x + y === x * y) == False putStrLn "\n============ Graph.mesh ============" - test "mesh xs [] == empty" $ \xs -> - mesh xs [] == (empty :: Graph (Int, Int)) + test "mesh xs [] == empty" $ \xs -> + mesh xs [] == (empty :: Graph (Int, Int)) - test "mesh [] ys == empty" $ \ys -> - mesh [] ys == (empty :: Graph (Int, Int)) + test "mesh [] ys == empty" $ \ys -> + mesh [] ys == (empty :: Graph (Int, Int)) - test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> - mesh [x] [y] == vertex (x, y) + test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> + mesh [x] [y] == vertex (x, y) - test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - mesh xs ys == box (path xs) (path ys) + test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + mesh xs ys == box (path xs) (path ys) - test "mesh [1..3] \"ab\" == " $ - mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) + test "mesh [1..3] \"ab\" == " $ + mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ] + test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs :: [Int]) (ys :: [Int]) -> + size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) putStrLn "\n============ Graph.torus ============" - test "torus xs [] == empty" $ \xs -> - torus xs [] == (empty :: Graph (Int, Int)) + test "torus xs [] == empty" $ \xs -> + torus xs [] == (empty :: Graph (Int, Int)) - test "torus [] ys == empty" $ \ys -> - torus [] ys == (empty :: Graph (Int, Int)) + test "torus [] ys == empty" $ \ys -> + torus [] ys == (empty :: Graph (Int, Int)) - test "torus [x] [y] == edge (x, y) (x, y)" $ \(x :: Int) (y :: Int) -> - torus [x] [y] == edge (x, y) (x, y) + test "torus [x] [y] == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> + torus [x] [y] == edge (x,y) (x,y) - test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - torus xs ys == box (circuit xs) (circuit ys) + test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + torus xs ys == box (circuit xs) (circuit ys) - test "torus [1,2] \"ab\" == " $ - torus [1,2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) + test "torus [1,2] \"ab\" == " $ + torus [1,2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ] + test "size (torus xs ys) == max 1 (3 * length xs * length ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + size (torus xs ys) == max 1 (3 * length xs * length ys) + + putStrLn "\n============ Graph.deBruijn ============" test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> deBruijn 0 xs ==(edge [] [] :: Graph [Int]) @@ -147,3 +152,16 @@ test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + + putStrLn "\n============ Graph.sparsify ============" + test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> + (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y + + test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> + vertexCount (sparsify x) <= vertexCount x + size x + 1 + + test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> + edgeCount (sparsify x) <= 3 * size x + + test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> + size (sparsify x) <= 3 * size x diff --git a/test/Algebra/Graph/Test/IntAdjacencyMap.hs b/test/Algebra/Graph/Test/IntAdjacencyMap.hs deleted file mode 100644 --- a/test/Algebra/Graph/Test/IntAdjacencyMap.hs +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Test.IntAdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- Testsuite for "Algebra.Graph.IntAdjacencyMap". ------------------------------------------------------------------------------ -module Algebra.Graph.Test.IntAdjacencyMap ( - -- * Testsuite - testIntAdjacencyMap - ) where - -import Algebra.Graph.IntAdjacencyMap -import Algebra.Graph.IntAdjacencyMap.Internal -import Algebra.Graph.Test -import Algebra.Graph.Test.Generic - -import qualified Data.Graph as KL -import qualified Data.IntSet as IntSet - -t :: Testsuite -t = testsuite "IntAdjacencyMap." empty - -testIntAdjacencyMap :: IO () -testIntAdjacencyMap = do - putStrLn "\n============ IntAdjacencyMap ============" - test "Axioms of graphs" (axioms :: GraphTestsuite IntAdjacencyMap) - - test "Consistency of arbitraryAdjacencyMap" $ \m -> - consistent m - - test "Consistency of fromAdjacencyList" $ \xs -> - consistent (fromAdjacencyList xs) - - testShow t - testBasicPrimitives t - testFromAdjacencyList t - testIsSubgraphOf t - testProperties t - testAdjacencyList t - testPostIntSet t - testGraphFamilies t - testTransformations t - testDfsForest t - testDfsForestFrom t - testDfs t - testTopSort t - testIsTopSort t - - putStrLn "\n============ IntAdjacencyMap.Internal.GraphKL ============" - test "map (fromVertexKL h) (vertices $ toGraphKL h) == IntSet.toAscList (vertexIntSet g)" - $ \g -> let h = mkGraphKL (adjacencyMap g) in - map (fromVertexKL h) (KL.vertices $ toGraphKL h) == IntSet.toAscList (vertexIntSet g) - - test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" - $ \g -> let h = mkGraphKL (adjacencyMap g) in - map (\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == edgeList g diff --git a/test/Algebra/Graph/Test/NonEmptyGraph.hs b/test/Algebra/Graph/Test/NonEmptyGraph.hs --- a/test/Algebra/Graph/Test/NonEmptyGraph.hs +++ b/test/Algebra/Graph/Test/NonEmptyGraph.hs @@ -22,6 +22,7 @@ #endif import Control.Monad +import Data.Either import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Tree @@ -29,12 +30,12 @@ import Algebra.Graph.NonEmpty import Algebra.Graph.Test hiding (axioms, theorems) +import Algebra.Graph.ToGraph (reachable, toGraph) -import qualified Algebra.Graph as G -import qualified Algebra.Graph.Class as C -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Algebra.Graph as G +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet type G = NonEmptyGraph Int @@ -99,7 +100,7 @@ toNonEmptyGraph (G.empty :: G.Graph Int) == Nothing test "toNonEmptyGraph (toGraph x) == Just (x :: NonEmptyGraph a)" $ \x -> - toNonEmptyGraph (C.toGraph x) == Just (x :: NonEmptyGraph Int) + toNonEmptyGraph (toGraph x) == Just (x :: NonEmptyGraph Int) putStrLn $ "\n============ Graph.NonEmpty.vertex ============" test "hasVertex x (vertex x) == True" $ \(x :: Int) -> @@ -440,19 +441,25 @@ test "star x [y,z] == edges1 ((x,y) :| [(x,z)])" $ \(x :: Int) y z -> star x [y,z] == edges1 ((x,y) :| [(x,z)]) - putStrLn $ "\n============ Graph.NonEmpty.starTranspose ============" - test "starTranspose x [] == vertex x" $ \(x :: Int) -> - starTranspose x [] == vertex x + putStrLn $ "\n============ Graph.NonEmpty.stars1 ============" + test "stars1 ((x, []) :| []) == vertex x" $ \(x :: Int) -> + stars1 ((x, []) :| []) == vertex x - test "starTranspose x [y] == edge y x" $ \(x :: Int) y -> - starTranspose x [y] == edge y x + test "stars1 ((x, [y]) :| []) == edge x y" $ \(x :: Int) y -> + stars1 ((x, [y]) :| []) == edge x y - test "starTranspose x [y,z] == edges1 ((y,x) :| [(z,x)])" $ \(x :: Int) y z -> - starTranspose x [y,z] == edges1 ((y,x) :| [(z,x)]) + test "stars1 ((x, ys) :| []) == star x ys" $ \(x :: Int) ys -> + stars1 ((x, ys) :| []) == star x ys - test "starTranspose x ys == transpose (star x ys)" $ \(x :: Int) ys -> - starTranspose x ys == transpose (star x ys) + test "stars1 == overlays1 . fmap (uncurry star)" $ \(xs' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in stars1 xs == overlays1 (fmap (uncurry star) xs) + test "overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys)" $ \(xs' :: NonEmptyList (Int, [Int])) (ys' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys) + putStrLn $ "\n============ Graph.NonEmpty.tree ============" test "tree (Node x []) == vertex x" $ \(x :: Int) -> tree (Node x []) == vertex x @@ -481,9 +488,14 @@ , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')) , ((3,'a'),(3 :: Int,'b')) ]) + test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in size (mesh1 xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) + putStrLn $ "\n============ Graph.NonEmpty.torus1 ============" - test "torus1 (x :| []) (y :| []) == edge (x, y) (x, y)" $ \(x :: Int) (y :: Int) -> - torus1 (x :| []) (y :| []) == edge (x, y) (x, y) + test "torus1 (x :| []) (y :| []) == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> + torus1 (x :| []) (y :| []) == edge (x,y) (x,y) test "torus1 xs ys == box (circuit1 xs) (circuit1 ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> let xs = NonEmpty.fromList (getNonEmpty xs') @@ -496,6 +508,11 @@ , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')) , ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ]) + test "size (torus1 xs ys) == max 1 (3 * length xs * length ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in size (torus1 xs ys) == max 1 (3 * length xs * length ys) + putStrLn $ "\n============ Graph.NonEmpty.removeVertex1 ============" test "removeVertex1 x (vertex x) == Nothing" $ \(x :: Int) -> removeVertex1 x (vertex x) == Nothing @@ -633,3 +650,16 @@ test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + + putStrLn "\n============ Graph.NonEmpty.sparsify ============" + test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> + (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y + + test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> + vertexCount (sparsify x) <= vertexCount x + size x + 1 + + test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> + edgeCount (sparsify x) <= 3 * size x + + test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> + size (sparsify x) <= 3 * size x diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -41,19 +41,12 @@ test "Consistency of arbitraryRelation" $ \(m :: RI) -> consistent m - test "Consistency of fromAdjacencyList" $ \xs -> - consistent (fromAdjacencyList xs :: RI) - - testShow t - testBasicPrimitives t - testFromAdjacencyList t - testIsSubgraphOf t - testProperties t - testAdjacencyList t - testPreSet t - testPostSet t - testGraphFamilies t - testTransformations t + testShow t + testBasicPrimitives t + testIsSubgraphOf t + testToGraph t + testGraphFamilies t + testTransformations t putStrLn "\n============ Relation.compose ============" test "compose empty x == empty" $ \(x :: RI) -> diff --git a/test/Data/Graph/Test/Typed.hs b/test/Data/Graph/Test/Typed.hs new file mode 100644 --- /dev/null +++ b/test/Data/Graph/Test/Typed.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Graph.Test.Typed +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Data.Graph.Typed". +----------------------------------------------------------------------------- +module Data.Graph.Test.Typed ( + -- * Testsuite + testTyped + ) where + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import Algebra.Graph.Test +import Data.Array (array) +import Data.Graph.Typed +import Data.Tree +import Data.List + +import qualified Data.Graph as KL +import qualified Data.IntSet as IntSet + +type AI = AM.AdjacencyMap Int + +(%) :: (GraphKL Int -> a) -> AM.AdjacencyMap Int -> a +a % g = a $ fromAdjacencyMap g + +testTyped :: IO () +testTyped = do + putStrLn "\n============ Typed ============" + + putStrLn "\n============ Typed.fromAdjacencyMap ============" + + test "toGraphKL (fromAdjacencyMap (1 * 2 + 3 * 1)) == array (0,2) [(0,[1]), (1,[]), (2,[0])]" $ + toGraphKL (fromAdjacencyMap (1 * 2 + 3 * 1 :: AI)) == array (0,2) [(0,[1]), (1,[]), (2,[0])] + + test "toGraphKL (fromAdjacencyMap (1 * 2 + 2 * 1)) == array (0,1) [(0,[1]), (1,[0])]" $ + toGraphKL (fromAdjacencyMap (1 * 2 + 2 * 1 :: AI)) == array (0,1) [(0,[1]), (1,[0])] + + test "map (fromVertexKL h) (vertices $ toGraphKL h) == vertexList g" + $ \(g :: AI) -> let h = fromAdjacencyMap g in + map (fromVertexKL h) (KL.vertices $ toGraphKL h) == AM.vertexList g + + test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" + $ \(g :: AI) -> let h = fromAdjacencyMap g in + map (\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == AM.edgeList g + + putStrLn "\n============ Typed.fromAdjacencyIntMap ============" + + test "toGraphKL (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == array (0,2) [(0,[1]), (1,[]), (2,[0])]" $ + toGraphKL (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == array (0,2) [(0,[1]), (1,[]), (2,[0])] + + test "toGraphKL (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == array (0,1) [(0,[1]), (1,[0])]" $ + toGraphKL (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == array (0,1) [(0,[1]), (1,[0])] + + test "map (fromVertexKL h) (vertices $ toGraphKL h) == IntSet.toAscList (vertexIntSet g)" + $ \g -> let h = fromAdjacencyIntMap g in + map (fromVertexKL h) (KL.vertices $ toGraphKL h) == IntSet.toAscList (AIM.vertexIntSet g) + + test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" + $ \g -> let h = fromAdjacencyIntMap g in + map (\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == AIM.edgeList g + + putStrLn $ "\n============ Typed.dfsForest ============" + test "forest (dfsForest % edge 1 1) == vertex 1" $ + AM.forest (dfsForest % AM.edge 1 1) == AM.vertex 1 + + test "forest (dfsForest % edge 1 2) == edge 1 2" $ + AM.forest (dfsForest % AM.edge 1 2) == AM.edge 1 2 + + test "forest (dfsForest % edge 2 1) == vertices [1, 2]" $ + AM.forest (dfsForest % AM.edge 2 1) == AM.vertices [1, 2] + + test "isSubgraphOf (forest $ dfsForest % x) x == True" $ \x -> + AM.isSubgraphOf (AM.forest $ dfsForest % x) x == True + + test "dfsForest % forest (dfsForest % x) == dfsForest % x" $ \x -> + dfsForest % AM.forest (dfsForest % x) == dfsForest % x + + test "dfsForest % vertices vs == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> + dfsForest % AM.vertices vs == map (\v -> Node v []) (nub $ sort vs) + + test "dfsForest % (3 * (1 + 4) * (1 + 5)) == " $ + dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 3 + , subForest = [ Node { rootLabel = 4 + , subForest = [] }]}] + + putStrLn $ "\n============ Typed.dfsForestFrom ============" + test "forest (dfsForestFrom [1] % edge 1 1) == vertex 1" $ + AM.forest (dfsForestFrom [1] % AM.edge 1 1) == AM.vertex 1 + + test "forest (dfsForestFrom [1] % edge 1 2) == edge 1 2" $ + AM.forest (dfsForestFrom [1] % AM.edge 1 2) == AM.edge 1 2 + + test "forest (dfsForestFrom [2] % edge 1 2) == vertex 2" $ + AM.forest (dfsForestFrom [2] % AM.edge 1 2) == AM.vertex 2 + + test "forest (dfsForestFrom [3] % edge 1 2) == empty" $ + AM.forest (dfsForestFrom [3] % AM.edge 1 2) == AM.empty + + test "forest (dfsForestFrom [2, 1] % edge 1 2) == vertices [1, 2]" $ + AM.forest (dfsForestFrom [2, 1] % AM.edge 1 2) == AM.vertices [1, 2] + + test "isSubgraphOf (forest $ dfsForestFrom vs % x) x == True" $ \vs x -> + AM.isSubgraphOf (AM.forest (dfsForestFrom vs % x)) x == True + + test "dfsForestFrom (vertexList x) % x == dfsForest % x" $ \x -> + dfsForestFrom (AM.vertexList x) % x == dfsForest % x + + test "dfsForestFrom vs % (AM.vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> + dfsForestFrom vs % AM.vertices vs == map (\v -> Node v []) (nub vs) + + test "dfsForestFrom [] % x == []" $ \x -> + dfsForestFrom [] % x == [] + + test "dfsForestFrom [1, 4] % 3 * (1 + 4) * (1 + 5) == " $ + dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + + putStrLn $ "\n============ Typed.dfs ============" + test "dfs [1] % edge 1 1 == [1]" $ + dfs [1] % AM.edge 1 1 == [1] + + test "dfs [1] % edge 1 2 == [1,2]" $ + dfs [1] % AM.edge 1 2 == [1,2] + + test "dfs [2] % edge 1 2 == [2]" $ + dfs [2] % AM.edge 1 2 == [2] + + test "dfs [3] % edge 1 2 == []" $ + dfs [3] % AM.edge 1 2 == [] + + test "dfs [1, 2] % edge 1 2 == [1, 2]" $ + dfs [1, 2] % AM.edge 1 2 == [1, 2] + + test "dfs [2, 1] % edge 1 2 == [2, 1]" $ + dfs [2, 1] % AM.edge 1 2 == [2, 1] + + test "dfs [] % x == []" $ \x -> + dfs [] % x == [] + + test "dfs [1, 4] % 3 * (1 + 4) * (1 + 5) == [1, 5, 4]" $ + dfs [1, 4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] + + test "isSubgraphOf (vertices $ dfs vs % x) x == True" $ \vs x -> + AM.isSubgraphOf (AM.vertices $ dfs vs % x) x == True + + putStrLn "\n============ Typed.topSort ============" + test "topSort % (1 * 2 + 3 * 1) == [3,1,2]" $ + topSort % (1 * 2 + 3 * 1) == ([3,1,2] :: [Int]) + + test "topSort % (1 * 2 + 2 * 1) == [1,2]" $ + topSort % (1 * 2 + 2 * 1) == ([1,2] :: [Int]) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,18 +2,20 @@ import Algebra.Graph.Test.Export import Algebra.Graph.Test.Fold import Algebra.Graph.Test.Graph -import Algebra.Graph.Test.IntAdjacencyMap +import Algebra.Graph.Test.AdjacencyIntMap import Algebra.Graph.Test.Internal import Algebra.Graph.Test.NonEmptyGraph import Algebra.Graph.Test.Relation +import Data.Graph.Test.Typed main :: IO () main = do + testAdjacencyIntMap testAdjacencyMap testExport testFold testGraph testGraphNonEmpty - testIntAdjacencyMap testInternal testRelation + testTyped