From cda16d0c028b1487678cee92f6c577ddfdee1397 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Tue, 27 Nov 2018 23:44:02 +0000 Subject: [PATCH 01/17] Remove graph construction primitives from the internal module --- src/Algebra/Graph/Labelled.hs | 2 +- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 39 +++++++++++++- .../Graph/Labelled/AdjacencyMap/Internal.hs | 51 +++---------------- test/Algebra/Graph/Test/Arbitrary.hs | 1 - 4 files changed, 47 insertions(+), 46 deletions(-) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index b3d8d91b9..c55e0f69e 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -27,7 +27,7 @@ module Algebra.Graph.Labelled ( -- * Types of edge-labelled graphs UnlabelledGraph, Automaton, Network - ) where + ) where import Prelude () import Prelude.Compat diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index c5a15c1e5..6fb898b27 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -20,7 +20,8 @@ module Algebra.Graph.Labelled.AdjacencyMap ( AdjacencyMap, adjacencyMap, -- * Basic graph construction primitives - empty, vertex, overlay, connect, edge, vertices, edges, overlays, (-<), (>-), + empty, vertex, overlay, connect, edge, (-<), (>-), vertices, edges, + overlays, fromAdjacencyMaps, -- * Relations on graphs isSubgraphOf, @@ -53,6 +54,16 @@ import Algebra.Graph.Labelled.AdjacencyMap.Internal import qualified Data.Map.Strict as Map import qualified Data.Set as Set +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +empty :: AdjacencyMap e a +empty = AM Map.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +vertex :: a -> AdjacencyMap e a +vertex x = AM $ Map.singleton x Map.empty + -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. edge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a @@ -81,6 +92,24 @@ g -< e = (g, e) infixl 5 -< infixl 5 >- +-- | /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. +overlay :: (Ord a, Semigroup e) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +overlay (AM x) (AM y) = AM $ Map.unionWith (Map.unionWith (<+>)) x y + +-- | /Connect/ two graphs with edges labelled by a given label. When applied to +-- the same labels, 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)/. +connect :: (Ord a, Monoid e) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +connect e (AM x) (AM y) = AM $ Map.unionsWith (Map.unionWith mappend) + [ x, y, Map.fromSet (const targets) (Map.keysSet x) ] + where + targets = Map.fromSet (const e) (Map.keysSet 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 -- of the given list. @@ -100,6 +129,14 @@ edges = fromAdjacencyMaps . concatMap fromEdge overlays :: (Ord a, Semigroup e) => [AdjacencyMap e a] -> AdjacencyMap e a overlays = AM . Map.unionsWith (Map.unionWith (<+>)) . map adjacencyMap +-- | Construct a graph from a list of adjacency sets. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +fromAdjacencyMaps :: (Ord a, Eq e, Monoid e) => [(a, Map a e)] -> AdjacencyMap e a +fromAdjacencyMaps ss = AM $ Map.unionWith (Map.unionWith mappend) vs es + where + vs = Map.fromSet (const Map.empty) . Set.unions $ map (Map.keysSet . snd) ss + es = Map.fromListWith (Map.unionWith mappend) $ map (fmap $ Map.filter (/= zero)) ss + -- | 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 diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs index b92f9b88c..6273ad5cd 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs @@ -12,8 +12,7 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Labelled.AdjacencyMap.Internal ( -- * Labelled adjacency map implementation - AdjacencyMap (..), empty, vertex, overlay, connect, fromAdjacencyMaps, - consistent + AdjacencyMap (..), consistent ) where import Prelude () @@ -22,7 +21,6 @@ import Prelude.Compat import Control.DeepSeq import Data.Map.Strict (Map) import Data.Monoid (Monoid, getSum, Sum (..)) -import Data.Semigroup (Semigroup) import Data.Set (Set, (\\)) import qualified Data.Map.Strict as Map @@ -68,52 +66,19 @@ instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where vSet = Map.keysSet eNum = getSum . foldMap (Sum . Map.size) --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. -empty :: AdjacencyMap e a -empty = AM Map.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. -vertex :: a -> AdjacencyMap e a -vertex x = AM $ Map.singleton x Map.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. -overlay :: (Ord a, Semigroup e) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a -overlay (AM x) (AM y) = AM $ Map.unionWith (Map.unionWith (<+>)) x y - --- | /Connect/ two graphs with edges labelled by a given label. When applied to --- the same labels, 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)/. -connect :: (Ord a, Monoid e) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a -connect e (AM x) (AM y) = AM $ Map.unionsWith (Map.unionWith mappend) - [ x, y, Map.fromSet (const targets) (Map.keysSet x) ] - where - targets = Map.fromSet (const e) (Map.keysSet y) - -- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' -- for more details. instance (Ord a, Num a, Dioid e) => Num (AdjacencyMap e a) where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect one - signum = const empty + fromInteger x = AM $ Map.singleton (fromInteger x) Map.empty + AM x + AM y = AM $ Map.unionWith (Map.unionWith (<+>)) x y + AM x * AM y = AM $ Map.unionsWith (Map.unionWith (<+>)) + [ x, y, Map.fromSet (const targets) (Map.keysSet x) ] + where + targets = Map.fromSet (const one) (Map.keysSet y) + signum = const (AM Map.empty) abs = id negate = id --- | Construct a graph from a list of adjacency sets. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -fromAdjacencyMaps :: (Ord a, Eq e, Monoid e) => [(a, Map a e)] -> AdjacencyMap e a -fromAdjacencyMaps ss = AM $ Map.unionWith (Map.unionWith mappend) vs es - where - vs = Map.fromSet (const Map.empty) . Set.unions $ map (Map.keysSet . snd) ss - es = Map.fromListWith (Map.unionWith mappend) $ map (fmap $ Map.filter (/= zero)) ss - -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices, and there are no 'zero'-labelled edges. It -- should be impossible to create an inconsistent adjacency map, and we use this diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs index f3108d15f..b563a234b 100644 --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -35,7 +35,6 @@ import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM import qualified Algebra.Graph.Class as C import qualified Algebra.Graph.Labelled.AdjacencyMap as Labelled -import qualified Algebra.Graph.Labelled.AdjacencyMap.Internal as Labelled import qualified Algebra.Graph.NonEmpty as NonEmpty import qualified Algebra.Graph.Relation as Relation From 1beeb2d402a1566561a23076d4eb89a86f7ade9e Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 28 Nov 2018 02:19:52 +0000 Subject: [PATCH 02/17] Add docs and tests --- src/Algebra/Graph/Class.hs | 2 +- src/Algebra/Graph/Labelled.hs | 2 +- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 159 ++++++++++++++---- src/Algebra/Graph/ToGraph.hs | 34 ++++ test/Algebra/Graph/Test/API.hs | 23 ++- test/Algebra/Graph/Test/Arbitrary.hs | 4 + test/Algebra/Graph/Test/Generic.hs | 11 +- .../Graph/Test/Labelled/AdjacencyMap.hs | 118 ++++++++++++- test/Algebra/Graph/Test/Relation.hs | 3 - 9 files changed, 297 insertions(+), 59 deletions(-) diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs index fded2c617..75d5db9e6 100644 --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -148,7 +148,7 @@ instance Graph AIM.AdjacencyIntMap where overlay = AIM.overlay connect = AIM.connect -instance (Ord a, Dioid e) => Graph (LAM.AdjacencyMap e a) where +instance (Dioid e, Eq e, Ord a) => Graph (LAM.AdjacencyMap e a) where type Vertex (LAM.AdjacencyMap e a) = a empty = LAM.empty vertex = LAM.vertex diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index c55e0f69e..149a65005 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -52,7 +52,7 @@ instance (Ord a, Eq e, Monoid e) => Eq (Graph e a) where x == y = toAdjacencyMap x == toAdjacencyMap y -- | Extract the adjacency map of a graph. -toAdjacencyMap :: (Ord a, Monoid e) => Graph e a -> AM.AdjacencyMap e a +toAdjacencyMap :: (Eq e, Monoid e, Ord a) => Graph e a -> AM.AdjacencyMap e a toAdjacencyMap = foldg AM.empty AM.vertex AM.connect instance Dioid e => C.Graph (Graph e a) where diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index 6fb898b27..39b64c740 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -20,7 +20,7 @@ module Algebra.Graph.Labelled.AdjacencyMap ( AdjacencyMap, adjacencyMap, -- * Basic graph construction primitives - empty, vertex, overlay, connect, edge, (-<), (>-), vertices, edges, + empty, vertex, edge, (-<), (>-), overlay, connect, vertices, edges, overlays, fromAdjacencyMaps, -- * Relations on graphs @@ -28,7 +28,7 @@ module Algebra.Graph.Labelled.AdjacencyMap ( -- * Graph properties isEmpty, hasVertex, hasEdge, edgeLabel, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, postSet, preSet, + edgeList, vertexSet, postSet, preSet, skeleton, -- * Graph transformation removeVertex, removeEdge, replaceVertex, replaceEdge, mergeVertices, transpose, gmap, @@ -44,47 +44,72 @@ import Prelude.Compat import Data.Foldable (foldMap) import Data.Maybe import Data.Map (Map) -import Data.Monoid (Monoid, Sum (..)) +import Data.Monoid (Any, Monoid, Sum (..)) import Data.Semigroup (Semigroup) import Data.Set (Set) import Algebra.Graph.Label import Algebra.Graph.Labelled.AdjacencyMap.Internal -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set +import qualified Algebra.Graph.AdjacencyMap.Internal as AM +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 :: AdjacencyMap e a empty = AM Map.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 :: a -> AdjacencyMap e a vertex x = AM $ Map.singleton x Map.empty -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. +-- +-- @ +-- edge e x y == 'connect' e ('vertex' x) ('vertex' y) +-- edge 'zero' x y == 'vertices' [x,y] +-- 'hasEdge' x y (edge e x y) == (e /= 'zero') +-- 'edgeLabel' x y (edge e x y) == e +-- 'edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 +-- 'vertexCount' (edge e 1 1) == 1 +-- 'vertexCount' (edge e 1 2) == 2 +-- @ edge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a edge e x y | e == zero = vertices [x, y] | x == y = AM $ Map.singleton x (Map.singleton x e) | otherwise = AM $ Map.fromList [(x, Map.singleton y e), (y, Map.empty)] --- | The left-hand part of a convenient ternary-ish operator @x -\- y@ for --- creating labelled edges. For example: +-- | The left-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. -- -- @ --- z = x -\<2\>- y +-- x -\- y == 'edge' e x y -- @ (-<) :: a -> e -> (a, e) g -< e = (g, e) --- | The right-hand part of a convenient ternary-ish operator @x -\- y@ for --- creating labelled edges. For example: +-- | The right-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. -- -- @ --- z = x -\<2\>- y +-- x -\- y == 'edge' e x y -- @ (>-) :: (Eq e, Monoid e, Ord a) => (a, e) -> a -> AdjacencyMap e a (x, e) >- y = edge e x y @@ -95,8 +120,36 @@ infixl 5 >- -- | /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. -overlay :: (Ord a, Semigroup e) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a -overlay (AM x) (AM y) = AM $ Map.unionWith (Map.unionWith (<+>)) x y +-- +-- @ +-- '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 +-- @ +-- +-- Note: 'overlay' composes parallel edges using the operator '<+>': +-- +-- @ +-- overlay ('edge' e x y) ('edge' f x y) == 'edge' (e '<+>' f) x y +-- @ +-- +-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in +-- sequence using the operator '<.>': +-- +-- @ +-- 'transitiveClosure' (overlay ('edge' e 1 2) ('edge' f 2 3)) == 'overlays' ['edge' e 1 2, 'edge' f 2 3, 'edge' (e '<.>' f) 1 3] +-- @ +overlay :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +overlay (AM x) (AM y) = AM $ Map.unionWith nonZeroUnion x y + +-- Union maps, removing zero elements from the result. +nonZeroUnion :: (Eq e, Monoid e, Ord a) => Map a e -> Map a e -> Map a e +nonZeroUnion x y = Map.filter (/= zero) $ Map.unionWith mappend x y -- | /Connect/ two graphs with edges labelled by a given label. When applied to -- the same labels, this is an associative operation with the identity 'empty', @@ -104,20 +157,46 @@ overlay (AM x) (AM y) = AM $ Map.unionWith (Map.unionWith (<+>)) x y -- 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)/. -connect :: (Ord a, Monoid e) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a -connect e (AM x) (AM y) = AM $ Map.unionsWith (Map.unionWith mappend) - [ x, y, Map.fromSet (const targets) (Map.keysSet x) ] +-- +-- @ +-- 'isEmpty' (connect e x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect e x y) >= 'vertexCount' x +-- 'vertexCount' (connect e x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect e x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect e 1 2) == 2 +-- 'edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1 +-- @ +connect :: (Eq e, Monoid e, Ord a) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +connect e (AM x) (AM y) + | e == mempty = overlay (AM x) (AM y) + | otherwise = AM $ Map.unionsWith nonZeroUnion + [ x, y, Map.fromSet (const targets) (Map.keysSet x) ] where targets = Map.fromSet (const e) (Map.keysSet 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 -- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ vertices :: Ord a => [a] -> AdjacencyMap e a vertices = AM . Map.fromList . map (, Map.empty) -- | Construct the graph from a list of edges. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(e,x,y)] == 'edge' e x y +-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) +-- @ edges :: (Eq e, Monoid e, Ord a) => [(e, a, a)] -> AdjacencyMap e a edges = fromAdjacencyMaps . concatMap fromEdge where @@ -126,6 +205,14 @@ edges = fromAdjacencyMaps . concatMap fromEdge -- | 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 :: (Ord a, Semigroup e) => [AdjacencyMap e a] -> AdjacencyMap e a overlays = AM . Map.unionsWith (Map.unionWith (<+>)) . map adjacencyMap @@ -143,11 +230,9 @@ fromAdjacencyMaps ss = AM $ Map.unionWith (Map.unionWith mappend) vs es -- 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 x y ==> x <= y +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> Bool isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy (Map.isSubmapOfBy le) x y @@ -156,6 +241,14 @@ isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy (Map.isSubmapOfBy le) x 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' e x y) == False +-- @ isEmpty :: AdjacencyMap e a -> Bool isEmpty = Map.null . adjacencyMap @@ -213,6 +306,10 @@ preSet :: Ord a => a -> AdjacencyMap e a -> Map a e preSet x (AM m) = Map.fromAscList [ (a, e) | (a, es) <- Map.toAscList m, Just e <- [Map.lookup x es] ] +-- | Convert to unlabelled adjacency map. +skeleton :: AdjacencyMap Any a -> AM.AdjacencyMap a +skeleton (AM m) = AM.AM (Map.map Map.keysSet m) + -- | The /postset/ of a vertex is the set of its /direct successors/. -- Complexity: /O(log(n))/ time and /O(1)/ memory. postSet :: Ord a => a -> AdjacencyMap e a -> Map a e @@ -238,18 +335,18 @@ replaceVertex u v = gmap $ \w -> if w == u then v else w -- Complexity: /O(log(n))/ time. -- -- @ --- replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y) --- replaceEdge e2 x y (edge e1 x y) == edge e2 x y --- edgeLabel x y (replaceEdge e x y m) == e +-- replaceEdge e x y m == 'overlay' (removeEdge x y m) ('edge' e x y) +-- replaceEdge e x y ('edge' f x y) == 'edge' e x y +-- 'edgeLabel' x y (replaceEdge e x y m) == e -- @ replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a -> AdjacencyMap e a replaceEdge e x y - | e == zero = AM . createVertexY . Map.alter (Just . maybe Map.empty (Map.delete y)) x . adjacencyMap - | otherwise = AM . createVertexY . Map.alter replace x . adjacencyMap - where - createVertexY = Map.alter (Just . fromMaybe Map.empty) y - replace (Just m) = Just $ Map.insert y e m - replace Nothing = Just $ Map.singleton y e + | e == zero = AM . addY . Map.alter (Just . maybe Map.empty (Map.delete y)) x . adjacencyMap + | otherwise = AM . addY . Map.alter replace x . adjacencyMap + where + addY = Map.alter (Just . fromMaybe Map.empty) y + replace (Just m) = Just $ Map.insert y e m + replace Nothing = Just $ Map.singleton y e -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes @@ -299,7 +396,7 @@ reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Map.insertWith (<+>) k one) -- | Compute the /symmetric closure/ of a graph by overlaying it with its own -- transpose. -symmetricClosure :: (Ord a, Semiring e) => AdjacencyMap e a -> AdjacencyMap e a +symmetricClosure :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a symmetricClosure m = overlay m (transpose m) -- | Compute the /transitive closure/ of a graph over the underlying star diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs index 1e0c0e7a7..7df5b8376 100644 --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -48,6 +48,7 @@ import Prelude.Compat import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) +import Data.Monoid (Any) import Data.Set (Set) import Data.Tree @@ -55,6 +56,7 @@ import qualified Algebra.Graph as G import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM import qualified Algebra.Graph.AdjacencyMap.Internal as AM +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM import qualified Algebra.Graph.NonEmpty.AdjacencyMap.Internal as NAM import qualified Algebra.Graph.AdjacencyIntMap as AIM @@ -457,6 +459,38 @@ instance ToGraph AIM.AdjacencyIntMap where isDfsForestOf = AIM.isDfsForestOf isTopSortOf = AIM.isTopSortOf +-- | See "Algebra.Graph.Labelled.AdjacencyMap". +instance Ord a => ToGraph (LAM.AdjacencyMap Any a) where + type ToVertex (LAM.AdjacencyMap Any a) = a + toGraph = toGraph . LAM.skeleton + -- isEmpty _ = False + -- hasVertex = NAM.hasVertex + -- hasEdge = NAM.hasEdge + -- vertexCount = NAM.vertexCount + -- edgeCount = NAM.edgeCount + -- vertexList = vertexList . NAM.am + -- vertexSet = NAM.vertexSet + -- vertexIntSet = vertexIntSet . NAM.am + -- edgeList = NAM.edgeList + -- edgeSet = NAM.edgeSet + -- adjacencyList = adjacencyList . NAM.am + -- preSet = NAM.preSet + -- postSet = NAM.postSet + -- adjacencyMap = adjacencyMap . NAM.am + -- adjacencyIntMap = adjacencyIntMap . NAM.am + -- dfsForest = dfsForest . NAM.am + -- dfsForestFrom xs = dfsForestFrom xs . NAM.am + -- dfs xs = dfs xs . NAM.am + -- reachable x = reachable x . NAM.am + -- topSort = topSort . NAM.am + -- isAcyclic = isAcyclic . NAM.am + -- toAdjacencyMap = NAM.am + -- toAdjacencyIntMap = toAdjacencyIntMap . NAM.am + -- toAdjacencyMapTranspose = NAM.am . NAM.transpose + -- toAdjacencyIntMapTranspose = toAdjacencyIntMap . NAM.transpose + -- isDfsForestOf f = isDfsForestOf f . NAM.am + -- isTopSortOf x = isTopSortOf x . NAM.am + -- | See "Algebra.Graph.NonEmpty.AdjacencyMap". instance Ord a => ToGraph (NAM.AdjacencyMap a) where type ToVertex (NAM.AdjacencyMap a) = a diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs index 04c2cf11d..fa41930b4 100644 --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -14,18 +14,20 @@ module Algebra.Graph.Test.API ( GraphAPI (..) ) where +import Data.Monoid (Any) import Data.Tree import Algebra.Graph.Class (Graph (..)) -import qualified Algebra.Graph as Graph -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Fold as Fold -import qualified Algebra.Graph.HigherKinded.Class as HClass -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.Relation as R -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Algebra.Graph as Graph +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.Fold as Fold +import qualified Algebra.Graph.HigherKinded.Class as HClass +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.Relation as R +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet class Graph g => GraphAPI g where edge :: Vertex g -> Vertex g -> g @@ -250,3 +252,8 @@ instance Ord a => GraphAPI (R.Relation a) where reflexiveClosure = R.reflexiveClosure symmetricClosure = R.symmetricClosure transitiveClosure = R.transitiveClosure + +instance Ord a => GraphAPI (LAM.AdjacencyMap Any a) where + vertices = LAM.vertices + overlays = LAM.overlays + removeVertex = LAM.removeVertex diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs index b563a234b..497c9c0c3 100644 --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -27,6 +27,7 @@ import Algebra.Graph.AdjacencyMap.Internal import Algebra.Graph.AdjacencyIntMap.Internal import Algebra.Graph.Export import Algebra.Graph.Fold (Fold) +import Algebra.Graph.Label import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.InternalDerived @@ -164,3 +165,6 @@ instance Arbitrary a => Arbitrary (Tree a) where -- TODO: Implement a custom shrink method. instance Arbitrary s => Arbitrary (Doc s) where arbitrary = (mconcat . map literal) <$> arbitrary + +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Distance a) where + arbitrary = (\x -> if x < 0 then distance infinite else distance (unsafeFinite x)) <$> arbitrary diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs index 52b611ae8..1f1531e8c 100644 --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -9,16 +9,7 @@ -- -- Generic graph API testing. ----------------------------------------------------------------------------- -module Algebra.Graph.Test.Generic ( - -- * Generic tests - Testsuite, testsuite, testShow, testFromAdjacencySets, - testFromAdjacencyIntSets, testBasicPrimitives, testIsSubgraphOf, testSize, - testToGraph, testRelational, testAdjacencyList, testPreSet, testPreIntSet, - testPostSet, testPostIntSet, testGraphFamilies, testTransformations, - testSplitVertex, testBind, testSimplify, testDfsForest, testDfsForestFrom, - testDfs, testReachable, testTopSort, testIsAcyclic, testIsDfsForestOf, - testIsTopSortOf, testCompose - ) where +module Algebra.Graph.Test.Generic where import Prelude () import Prelude.Compat diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs index 4f1a7498c..7a53a6547 100644 --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -15,11 +15,18 @@ module Algebra.Graph.Test.Labelled.AdjacencyMap ( import Data.Monoid +import Algebra.Graph.Label import Algebra.Graph.Labelled.AdjacencyMap import Algebra.Graph.Labelled.AdjacencyMap.Internal import Algebra.Graph.Test +import Algebra.Graph.Test.Generic + +t :: Testsuite +t = testsuite "Labelled.AdjacencyMap." (empty :: LAI) type LAI = AdjacencyMap Any Int +type LAS = AdjacencyMap (Sum Int) Int +type LAD = AdjacencyMap (Distance Int) Int testLabelledAdjacencyMap :: IO () testLabelledAdjacencyMap = do @@ -30,13 +37,114 @@ testLabelledAdjacencyMap = do test "Consistency of fromAdjacencyMaps" $ \xs -> consistent (fromAdjacencyMaps xs :: LAI) + testEmpty t + testVertex t + + putStrLn "\n============ Labelled.AdjacencyMap.edge ============" + test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: Sum Int) (x :: Int) y -> + edge e x y == connect e (vertex x) (vertex y) + + test "edge zero x y == vertices [x,y]" $ \(x :: Int) y -> + edge (zero :: Sum Int) x y == vertices [x,y] + + test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: Sum Int) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= mempty) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: Sum Int) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: Sum Int) (x :: Int) y -> + edgeCount (edge e x y) == if e == mempty then 0 else 1 + + test "vertexCount (edge e 1 1) == 1" $ \(e :: Sum Int) -> + vertexCount (edge e 1 (1 :: Int)) == 1 + + test "vertexCount (edge e 1 2) == 2" $ \(e :: Sum Int) -> + vertexCount (edge e 1 (2 :: Int)) == 2 + + test "x -- y == edge e x y" $ \(e :: Sum Int) (x :: Int) y -> + x -- y == edge e x y + + testOverlay t + + putStrLn "" + test "overlay (edge e x y) (edge f x y) == edge (e <+> f) x y" $ \(e :: Sum Int) f (x :: Int) y -> + overlay (edge e x y) (edge f x y) == edge (e <+> f) x y + + putStrLn "" + test "transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == overlays [edge e 1 2, edge f 2 3, edge (e <.> f) 1 3]" $ \(e :: Distance Int) f -> + transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == overlays [edge e 1 2, edge f 2 3, edge (e <.> f) 1 (3 :: Int)] + + + putStrLn "\n============ Labelled.AdjacencyMap.connect ============" + test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + isEmpty (connect e x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y z -> + hasVertex z (connect e x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect e x y) >= vertexCount x" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + vertexCount (connect e x y) >= vertexCount x + + test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + vertexCount (connect e x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect e 1 2) == 2" $ \(e :: Any) -> + vertexCount (connect e 1 (2 :: LAI)) == 2 + + test "edgeCount (connect e 1 2) == if e == zero then 0 else 1" $ \(e :: Any) -> + edgeCount (connect e 1 (2 :: LAI)) == if e == zero then 0 else 1 + + testVertices t + + putStrLn "\n============ Labelled.AdjacencyMap.edges ============" + test "edges [] == empty" $ + edges [] == (empty :: LAS) + + test "edges [(e,x,y)] == edge e x y" $ \(e :: Sum Int) (x :: Int) y -> + edges [(e,x,y)] == edge e x y + + test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(Sum Int, Int, Int)]) -> + edges es ==(overlays . map (\(e, x, y) -> edge e x y)) es + + testOverlays t + + putStrLn "\n============ Labelled.AdjacencyMap.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: LAS) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x)(empty :: LAS)== False + + test "isSubgraphOf x y ==> x <= y" $ \(x :: LAD) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Labelled.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty :: LAS) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: Sum Int) (x :: Int) y -> + isEmpty (removeEdge x y $ edge e x y) == False + putStrLn "\n============ Labelled.AdjacencyMap.replaceEdge ============" + test "replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y)" $ \(e :: Sum Int) (x :: Int) (y :: Int) m -> + replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y) - test "replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y)" $ \(e :: Sum Int) (x :: Int) (y :: Int) m -> - replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y) + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: Sum Int) (f :: Sum Int) (x :: Int) (y :: Int) -> + replaceEdge e x y (edge f x y) == edge e x y test "edgeLabel x y (replaceEdge e x y m) == e" $ \(e :: Sum Int) (x :: Int) (y :: Int) m -> edgeLabel x y (replaceEdge e x y m) == e - - test "replaceEdge e2 x y (edge e1 x y) == edge e2 x y" $ \(e1 :: Sum Int) (e2 :: Sum Int) (x :: Int) (y :: Int) -> - replaceEdge e2 x y (edge e1 x y) == edge e2 x y \ No newline at end of file diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs index 3746f6a1d..ff4605dad 100644 --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -30,9 +30,6 @@ t = testsuite "Relation." empty type RI = Relation Int -sizeLimit :: Testable prop => prop -> Property -sizeLimit = mapSize (min 10) - testRelation :: IO () testRelation = do putStrLn "\n============ Relation ============" From e017e3616e7e7f7595a44d21e2ed5c18ecfa3c86 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 28 Nov 2018 02:20:16 +0000 Subject: [PATCH 03/17] Enable FlexibleInstances by default --- .ghci | 1 + algebraic-graphs.cabal | 2 ++ 2 files changed, 3 insertions(+) diff --git a/.ghci b/.ghci index 8eb699a81..e43a76398 100644 --- a/.ghci +++ b/.ghci @@ -5,6 +5,7 @@ :set -itest :set -XFlexibleContexts +:set -XFlexibleInstances :set -XGeneralizedNewtypeDeriving :set -XScopedTypeVariables :set -XTupleSections diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal index 46372b751..90572f21e 100644 --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -109,6 +109,7 @@ library build-depends: semigroups >= 0.18.3 && < 0.18.4 default-language: Haskell2010 default-extensions: FlexibleContexts + FlexibleInstances GeneralizedNewtypeDeriving ScopedTypeVariables TupleSections @@ -170,6 +171,7 @@ test-suite test-alga -Wincomplete-uni-patterns -Wredundant-constraints default-extensions: FlexibleContexts + FlexibleInstances GeneralizedNewtypeDeriving ScopedTypeVariables TupleSections From 69ed8b39c619117d7657c081885690a248a5fd41 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 28 Nov 2018 11:35:21 +0000 Subject: [PATCH 04/17] Fix constraint --- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index 39b64c740..6fc2013a1 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -356,10 +356,11 @@ 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 :: (Ord a, Semigroup e) => AdjacencyMap e a -> AdjacencyMap e a +transpose :: (Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a transpose (AM m) = AM $ Map.foldrWithKey combine vs m where - combine v es = Map.unionWith (Map.unionWith (<+>)) $ + -- No need to do use @nonZeroUnion@ here, since we do not add any new edges + combine v es = Map.unionWith (Map.unionWith mappend) $ Map.fromAscList [ (u, Map.singleton v e) | (u, e) <- Map.toAscList es ] vs = Map.fromSet (const Map.empty) (Map.keysSet m) From 954383d6f343c661c08a6648adb02cc2b52d5a21 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 28 Nov 2018 14:31:10 +0000 Subject: [PATCH 05/17] Minor revision --- src/Algebra/Graph.hs | 1 - src/Algebra/Graph/AdjacencyMap.hs | 7 +++---- src/Algebra/Graph/Fold.hs | 1 - src/Algebra/Graph/Relation.hs | 1 - test/Algebra/Graph/Test/Generic.hs | 3 --- 5 files changed, 3 insertions(+), 10 deletions(-) diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs index 17ff17883..8a43a3e31 100644 --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -643,7 +643,6 @@ edgeIntListR = AIM.edgeList . toAdjacencyIntMap -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Ord a => Graph a -> Set.Set a vertexSet = foldg Set.empty Set.singleton Set.union Set.union diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs index f20f4773b..b983d54a5 100644 --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -130,8 +130,8 @@ overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) -- '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, - Map.fromSet (const . Map.keysSet $ adjacencyMap y) (Map.keysSet $ adjacencyMap x) ] +connect x y = AM $ Map.unionsWith Set.union $ adjacencyMap x : adjacencyMap y : + [ Map.fromSet (const . Map.keysSet $ adjacencyMap y) (Map.keysSet $ adjacencyMap x) ] {-# NOINLINE [1] connect #-} -- | Construct the graph comprising a given list of isolated vertices. @@ -300,7 +300,6 @@ edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: AdjacencyMap a -> Set a vertexSet = Map.keysSet . adjacencyMap @@ -314,7 +313,7 @@ vertexSet = Map.keysSet . adjacencyMap -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges' == Set.'Set.fromList' -- @ -edgeSet :: Ord a => AdjacencyMap a -> Set (a, a) +edgeSet :: Eq a => AdjacencyMap a -> Set (a, a) edgeSet = Set.fromAscList . edgeList -- | The sorted /adjacency list/ of a graph. diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs index 3c4555aaa..722c6485c 100644 --- a/src/Algebra/Graph/Fold.hs +++ b/src/Algebra/Graph/Fold.hs @@ -501,7 +501,6 @@ edgeList = T.edgeList -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Ord a => Fold a -> Set.Set a vertexSet = T.vertexSet diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs index 758926ede..843ee292e 100644 --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -223,7 +223,6 @@ edgeList = Set.toAscList . relation -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Relation a -> Set.Set a vertexSet = domain diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs index 1f1531e8c..25dd78a12 100644 --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -709,9 +709,6 @@ testVertexSet (Testsuite prefix (%)) = do test "vertexSet . vertices == Set.fromList" $ \xs -> vertexSet % vertices xs == Set.fromList xs - test "vertexSet . clique == Set.fromList" $ \xs -> - vertexSet % clique xs == Set.fromList xs - testVertexIntSet :: Testsuite -> IO () testVertexIntSet (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "vertexIntSet ============" From d33071a2eed9c8f0889e4f008b96a8f70324442d Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 28 Nov 2018 14:31:22 +0000 Subject: [PATCH 06/17] Add more docs and tests --- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 78 +++++++++++++-- .../Graph/Labelled/AdjacencyMap/Internal.hs | 12 ++- .../Graph/Test/Labelled/AdjacencyMap.hs | 95 +++++++++++++++++-- 3 files changed, 165 insertions(+), 20 deletions(-) diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index 6fc2013a1..ed0d4ca02 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -28,7 +28,7 @@ module Algebra.Graph.Labelled.AdjacencyMap ( -- * Graph properties isEmpty, hasVertex, hasEdge, edgeLabel, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, postSet, preSet, skeleton, + edgeList, vertexSet, edgeSet, postSet, preSet, skeleton, -- * Graph transformation removeVertex, removeEdge, replaceVertex, replaceEdge, mergeVertices, transpose, gmap, @@ -132,17 +132,20 @@ infixl 5 >- -- 'edgeCount' (overlay 1 2) == 0 -- @ -- --- Note: 'overlay' composes parallel edges using the operator '<+>': +-- Note: 'overlay' composes edges in parallel using the operator '<+>' with +-- 'zero' acting as the identity: -- -- @ --- overlay ('edge' e x y) ('edge' f x y) == 'edge' (e '<+>' f) x y +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<+>' f -- @ -- -- Furthermore, when applied to transitive graphs, 'overlay' composes edges in --- sequence using the operator '<.>': +-- sequence using the operator '<.>' with 'one' acting as the identity: -- -- @ --- 'transitiveClosure' (overlay ('edge' e 1 2) ('edge' f 2 3)) == 'overlays' ['edge' e 1 2, 'edge' f 2 3, 'edge' (e '<.>' f) 1 3] +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f y z)) == e '<.>' f -- @ overlay :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a overlay (AM x) (AM y) = AM $ Map.unionWith nonZeroUnion x y @@ -170,8 +173,8 @@ nonZeroUnion x y = Map.filter (/= zero) $ Map.unionWith mappend x y connect :: (Eq e, Monoid e, Ord a) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a connect e (AM x) (AM y) | e == mempty = overlay (AM x) (AM y) - | otherwise = AM $ Map.unionsWith nonZeroUnion - [ x, y, Map.fromSet (const targets) (Map.keysSet x) ] + | otherwise = AM $ Map.unionsWith nonZeroUnion $ x : y : + [ Map.fromSet (const targets) (Map.keysSet x) ] where targets = Map.fromSet (const e) (Map.keysSet y) @@ -254,15 +257,38 @@ isEmpty = Map.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 :: Ord a => a -> AdjacencyMap e a -> Bool hasVertex x = Map.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' e x y) == (e /= 'zero') +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList' +-- @ hasEdge :: Ord a => a -> a -> AdjacencyMap e a -> Bool hasEdge x y (AM m) = fromMaybe False (Map.member y <$> Map.lookup x m) --- | Extract the label of a specified edge from a graph. +-- | Extract the label of a specified edge in a graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- edgeLabel x y 'empty' == 'zero' +-- edgeLabel x y ('vertex' z) == 'zero' +-- edgeLabel x y ('edge' e x y) == e +-- edgeLabel s t ('overlay' x y) == edgeLabel s t x <+> edgeLabel s t y +-- @ edgeLabel :: (Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> e edgeLabel x y (AM m) = fromMaybe zero (Map.lookup x m >>= Map.lookup y) @@ -280,26 +306,62 @@ vertexCount = Map.size . adjacencyMap -- | The number of (non-'zero') edges in a graph. -- Complexity: /O(n)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' e x y) == if e == 'zero' then 0 else 1 +-- edgeCount == 'length' . 'edgeList' +-- @ edgeCount :: AdjacencyMap e a -> Int edgeCount = getSum . foldMap (Sum . Map.size) . 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 :: AdjacencyMap e a -> [a] vertexList = Map.keys . adjacencyMap -- | The list of edges of a graph, sorted lexicographically with respect to -- pairs of connected vertices (i.e. edge-labels are ignored when sorting). -- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)] +-- @ edgeList :: AdjacencyMap e a -> [(e, a, a)] edgeList (AM m) = [ (e, x, y) | (x, ys) <- Map.toAscList m, (y, e) <- Map.toAscList ys ] -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ vertexSet :: AdjacencyMap e a -> Set a vertexSet = Map.keysSet . adjacencyMap +-- | The set of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y) +-- @ +edgeSet :: (Eq a, Eq e) => AdjacencyMap e a -> Set (e, a, a) +edgeSet = Set.fromAscList . edgeList + -- | The /preset/ of an element @x@ is the set of its /direct predecessors/. -- Complexity: /O(n * log(n))/ time and /O(n)/ memory. preSet :: Ord a => a -> AdjacencyMap e a -> Map a e diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs index 6273ad5cd..bdd3171e2 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs @@ -60,19 +60,21 @@ instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where [ compare (vNum x) (vNum y) , compare (vSet x) (vSet y) , compare (eNum x) (eNum y) + , compare (eSet x) (eSet y) , compare x y ] where - vNum = Map.size - vSet = Map.keysSet - eNum = getSum . foldMap (Sum . Map.size) + vNum = Map.size + vSet = Map.keysSet + eNum = getSum . foldMap (Sum . Map.size) + eSet m = [ (x, y) | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ] -- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' -- for more details. instance (Ord a, Num a, Dioid e) => Num (AdjacencyMap e a) where fromInteger x = AM $ Map.singleton (fromInteger x) Map.empty AM x + AM y = AM $ Map.unionWith (Map.unionWith (<+>)) x y - AM x * AM y = AM $ Map.unionsWith (Map.unionWith (<+>)) - [ x, y, Map.fromSet (const targets) (Map.keysSet x) ] + AM x * AM y = AM $ Map.unionsWith (Map.unionWith (<+>)) $ x : y : + [ Map.fromSet (const targets) (Map.keysSet x) ] where targets = Map.fromSet (const one) (Map.keysSet y) signum = const (AM Map.empty) diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs index 7a53a6547..892a442cc 100644 --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -21,6 +21,8 @@ import Algebra.Graph.Labelled.AdjacencyMap.Internal import Algebra.Graph.Test import Algebra.Graph.Test.Generic +import qualified Data.Set as Set + t :: Testsuite t = testsuite "Labelled.AdjacencyMap." (empty :: LAI) @@ -68,13 +70,18 @@ testLabelledAdjacencyMap = do testOverlay t putStrLn "" - test "overlay (edge e x y) (edge f x y) == edge (e <+> f) x y" $ \(e :: Sum Int) f (x :: Int) y -> - overlay (edge e x y) (edge f x y) == edge (e <+> f) x y + test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: Sum Int) (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge zero x y)) == e + + test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: Sum Int) f (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f putStrLn "" - test "transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == overlays [edge e 1 2, edge f 2 3, edge (e <.> f) 1 3]" $ \(e :: Distance Int) f -> - transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == overlays [edge e 1 2, edge f 2 3, edge (e <.> f) 1 (3 :: Int)] + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: Distance Int) -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: Distance Int) f -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f putStrLn "\n============ Labelled.AdjacencyMap.connect ============" test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> @@ -139,12 +146,86 @@ testLabelledAdjacencyMap = do test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: Sum Int) (x :: Int) y -> isEmpty (removeEdge x y $ edge e x y) == False + testHasVertex t + + putStrLn "\n============ Labelled.AdjacencyMap.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y empty == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False + + test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: Sum Int) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= zero) + + test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == not . null . filter (\\(_,ex,ey) -> ex == x && ey == y) . edgeList" $ \x y (z :: LAS) -> do + (_, u, v) <- elements ((zero, x, y) : edgeList z) + return $ hasEdge u v z == (not . null . filter (\(_,ex,ey) -> ex == u && ey == v) . edgeList) z + + putStrLn "\n============ Labelled.AdjacencyMap.edgeLabel ============" + test "edgeLabel x y empty == zero" $ \(x :: Int) y -> + edgeLabel x y empty == (zero :: Sum Int) + + test "edgeLabel x y (vertex z) == zero" $ \(x :: Int) y z -> + edgeLabel x y (vertex z) == (zero :: Sum Int) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: Sum Int) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y" $ \(x :: LAS) y -> do + z <- arbitrary + s <- elements ([z] ++ vertexList x ++ vertexList y) + t <- elements ([z] ++ vertexList x ++ vertexList y) + return $ edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y + + testVertexCount t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: Sum Int) (x :: Int) y -> + edgeCount (edge e x y) == if e == zero then 0 else 1 + + test "edgeCount == length . edgeList" $ \(x :: LAS) -> + edgeCount x == (length . edgeList) x + + testVertexList t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: LAS) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x :: LAS) == [] + + test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: Sum Int) (x :: Int) y -> + edgeList (edge e x y) == if e == zero then [] else [(e,x,y)] + + testVertexSet t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: LAS) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x :: LAS) == Set.empty + + test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: Sum Int) (x :: Int) y -> + edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) + putStrLn "\n============ Labelled.AdjacencyMap.replaceEdge ============" - test "replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y)" $ \(e :: Sum Int) (x :: Int) (y :: Int) m -> + test "replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y)" $ \(e :: Sum Int) (x :: Int) y m -> replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y) - test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: Sum Int) (f :: Sum Int) (x :: Int) (y :: Int) -> + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: Sum Int) f (x :: Int) y -> replaceEdge e x y (edge f x y) == edge e x y - test "edgeLabel x y (replaceEdge e x y m) == e" $ \(e :: Sum Int) (x :: Int) (y :: Int) m -> + test "edgeLabel x y (replaceEdge e x y m) == e" $ \(e :: Sum Int) (x :: Int) y m -> edgeLabel x y (replaceEdge e x y m) == e From 4ec7d60e903914bf9a11895e7f419726c02c4ec8 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 28 Nov 2018 17:42:53 +0000 Subject: [PATCH 07/17] More docs/tests --- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 44 +++++++++++-------- .../Graph/Test/Labelled/AdjacencyMap.hs | 34 ++++++++++++-- 2 files changed, 56 insertions(+), 22 deletions(-) diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index ed0d4ca02..2ca429c15 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -31,7 +31,7 @@ module Algebra.Graph.Labelled.AdjacencyMap ( edgeList, vertexSet, edgeSet, postSet, preSet, skeleton, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, replaceEdge, mergeVertices, transpose, gmap, + removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap, emap, induce, -- * Relational operations @@ -364,18 +364,32 @@ edgeSet = Set.fromAscList . edgeList -- | The /preset/ of an element @x@ is the set of its /direct predecessors/. -- Complexity: /O(n * log(n))/ time and /O(n)/ memory. -preSet :: Ord a => a -> AdjacencyMap e a -> Map a e -preSet x (AM m) = Map.fromAscList - [ (a, e) | (a, es) <- Map.toAscList m, Just e <- [Map.lookup x es] ] - --- | Convert to unlabelled adjacency map. -skeleton :: AdjacencyMap Any a -> AM.AdjacencyMap a -skeleton (AM m) = AM.AM (Map.map Map.keysSet m) +-- +-- @ +-- preSet x 'empty' == Set.'Set.empty' +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 ('edge' e 1 2) == Set.'Set.empty' +-- preSet y ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [x] +-- @ +preSet :: Ord a => a -> AdjacencyMap e a -> Set a +preSet x (AM m) = Set.fromAscList + [ a | (a, es) <- Map.toAscList m, Map.member x es ] -- | The /postset/ of a vertex is the set of its /direct successors/. -- Complexity: /O(log(n))/ time and /O(1)/ memory. -postSet :: Ord a => a -> AdjacencyMap e a -> Map a e -postSet x = Map.findWithDefault Map.empty x . adjacencyMap +-- +-- @ +-- postSet x 'empty' == Set.'Set.empty' +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet x ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [y] +-- postSet 2 ('edge' e 1 2) == Set.'Set.empty' +-- @ +postSet :: Ord a => a -> AdjacencyMap e a -> Set a +postSet x = Map.keysSet . Map.findWithDefault Map.empty x . adjacencyMap + +-- | Convert to the unlabelled 'AM.AdjacencyMap'. +skeleton :: AdjacencyMap Any a -> AM.AdjacencyMap a +skeleton (AM m) = AM.AM (Map.map Map.keysSet m) -- | Remove a vertex from a given graph. -- Complexity: /O(n*log(n))/ time. @@ -397,9 +411,9 @@ replaceVertex u v = gmap $ \w -> if w == u then v else w -- Complexity: /O(log(n))/ time. -- -- @ --- replaceEdge e x y m == 'overlay' (removeEdge x y m) ('edge' e x y) +-- replaceEdge e x y z == 'overlay' (removeEdge x y z) ('edge' e x y) -- replaceEdge e x y ('edge' f x y) == 'edge' e x y --- 'edgeLabel' x y (replaceEdge e x y m) == e +-- 'edgeLabel' x y (replaceEdge e x y z) == e -- @ replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a -> AdjacencyMap e a replaceEdge e x y @@ -410,12 +424,6 @@ replaceEdge e x y replace (Just m) = Just $ Map.insert y e m replace Nothing = Just $ Map.singleton y e --- | 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 :: (Ord a, Semigroup e) => (a -> Bool) -> a -> AdjacencyMap e a -> AdjacencyMap e a -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 :: (Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs index 892a442cc..0adb2b9a7 100644 --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -220,12 +220,38 @@ testLabelledAdjacencyMap = do test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: Sum Int) (x :: Int) y -> edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) + putStrLn "\n============ Labelled.AdjacencyMap.preSet ============" + test "preSet x empty == Set.empty" $ \x -> + preSet x (empty :: LAS) == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + preSet x (vertex x :: LAS) == Set.empty + + test "preSet 1 (edge e 1 2) == Set.empty" $ \e -> + preSet 1 (edge e 1 2 :: LAS) == Set.empty + + test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: Sum Int) (x :: Int) y -> + preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x] + + putStrLn "\n============ Labelled.AdjacencyMap.postSet ============" + test "postSet x empty == Set.empty" $ \x -> + postSet x (empty :: LAS) == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + postSet x (vertex x :: LAS) == Set.empty + + test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: Sum Int) (x :: Int) y -> + postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y] + + test "postSet 2 (edge e 1 2) == Set.empty" $ \e -> + postSet 2 (edge e 1 2 :: LAS) == Set.empty + putStrLn "\n============ Labelled.AdjacencyMap.replaceEdge ============" - test "replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y)" $ \(e :: Sum Int) (x :: Int) y m -> - replaceEdge e x y m == overlay (removeEdge x y m) (edge e x y) + test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: Sum Int) (x :: Int) y z -> + replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: Sum Int) f (x :: Int) y -> replaceEdge e x y (edge f x y) == edge e x y - test "edgeLabel x y (replaceEdge e x y m) == e" $ \(e :: Sum Int) (x :: Int) y m -> - edgeLabel x y (replaceEdge e x y m) == e + test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: Sum Int) (x :: Int) y z -> + edgeLabel x y (replaceEdge e x y z) == e From 608bc17cbbf6caeaa658de1b966c2a48b46cfda7 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 01:28:51 +0000 Subject: [PATCH 08/17] Finish labelled adjacency maps --- src/Algebra/Graph/AdjacencyMap.hs | 8 +- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 173 ++++++++-- src/Algebra/Graph/ToGraph.hs | 52 ++- test/Algebra/Graph/Test/API.hs | 2 + test/Algebra/Graph/Test/Generic.hs | 34 +- .../Graph/Test/Labelled/AdjacencyMap.hs | 300 +++++++++++++++--- test/Algebra/Graph/Test/Relation.hs | 14 +- 7 files changed, 458 insertions(+), 125 deletions(-) diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs index b983d54a5..3b8c2822f 100644 --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -390,7 +390,7 @@ circuit (x:xs) = path $ [x] ++ xs ++ [x] -- 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 (xs '++' ys) == 'connect' (clique xs) (clique ys) -- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> AdjacencyMap a @@ -444,7 +444,7 @@ star x ys = connect (vertex x) (vertices ys) -- stars [(x, ys)] == 'star' x ys -- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id --- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) +-- 'overlay' (stars xs) (stars ys) == stars (xs '++' ys) -- @ stars :: Ord a => [(a, [a])] -> AdjacencyMap a stars = fromAdjacencySets . map (fmap Set.fromList) @@ -457,7 +457,7 @@ stars = fromAdjacencySets . map (fmap Set.fromList) -- fromAdjacencySets [(x, Set.'Set.empty')] == 'vertex' x -- fromAdjacencySets [(x, Set.'Set.singleton' y)] == 'edge' x y -- fromAdjacencySets . 'map' ('fmap' Set.'Set.fromList') == 'stars' --- 'overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys) +-- '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 @@ -581,7 +581,7 @@ transpose (AM m) = AM $ Map.foldrWithKey combine vs m -- 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 'id' == 'id' -- gmap f . gmap g == gmap (f . g) -- @ gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index 2ca429c15..148f5d507 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -28,7 +28,7 @@ module Algebra.Graph.Labelled.AdjacencyMap ( -- * Graph properties isEmpty, hasVertex, hasEdge, edgeLabel, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, edgeSet, postSet, preSet, skeleton, + edgeList, vertexSet, edgeSet, preSet, postSet, skeleton, -- * Graph transformation removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap, @@ -44,14 +44,14 @@ import Prelude.Compat import Data.Foldable (foldMap) import Data.Maybe import Data.Map (Map) -import Data.Monoid (Any, Monoid, Sum (..)) -import Data.Semigroup (Semigroup) +import Data.Monoid (Monoid, Sum (..)) import Data.Set (Set) import Algebra.Graph.Label import Algebra.Graph.Labelled.AdjacencyMap.Internal -import qualified Algebra.Graph.AdjacencyMap.Internal as AM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Internal as AMI import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -154,6 +154,10 @@ overlay (AM x) (AM y) = AM $ Map.unionWith nonZeroUnion x y nonZeroUnion :: (Eq e, Monoid e, Ord a) => Map a e -> Map a e -> Map a e nonZeroUnion x y = Map.filter (/= zero) $ Map.unionWith mappend x y +-- Drop all edges with zero labels. +trimZeroes :: (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e) +trimZeroes = Map.map (Map.filter (/= zero)) + -- | /Connect/ two graphs with edges labelled by a given label. When applied to -- the same labels, this is an associative operation with the identity 'empty', -- which distributes over 'overlay' and obeys the decomposition axiom. @@ -201,10 +205,7 @@ vertices = AM . Map.fromList . map (, Map.empty) -- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) -- @ edges :: (Eq e, Monoid e, Ord a) => [(e, a, a)] -> AdjacencyMap e a -edges = fromAdjacencyMaps . concatMap fromEdge - where - fromEdge (e, x, y) | e == zero = [(x, Map.empty), (y, Map.empty)] - | otherwise = [(x, Map.singleton y e)] +edges es = fromAdjacencyMaps [ (x, Map.singleton y e) | (e, x, y) <- es ] -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -216,16 +217,23 @@ edges = fromAdjacencyMaps . concatMap fromEdge -- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ -overlays :: (Ord a, Semigroup e) => [AdjacencyMap e a] -> AdjacencyMap e a -overlays = AM . Map.unionsWith (Map.unionWith (<+>)) . map adjacencyMap +overlays :: (Eq e, Monoid e, Ord a) => [AdjacencyMap e a] -> AdjacencyMap e a +overlays = AM . Map.unionsWith nonZeroUnion . map adjacencyMap -- | Construct a graph from a list of adjacency sets. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -fromAdjacencyMaps :: (Ord a, Eq e, Monoid e) => [(a, Map a e)] -> AdjacencyMap e a -fromAdjacencyMaps ss = AM $ Map.unionWith (Map.unionWith mappend) vs es +-- +-- @ +-- fromAdjacencyMaps [] == 'empty' +-- fromAdjacencyMaps [(x, Map.'Map.empty')] == 'vertex' x +-- fromAdjacencyMaps [(x, Map.'Map.singleton' y e)] == if e == 'zero' then 'vertices' [x,y] else 'edge' e x y +-- 'overlay' (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs '++' ys) +-- @ +fromAdjacencyMaps :: (Eq e, Monoid e, Ord a) => [(a, Map a e)] -> AdjacencyMap e a +fromAdjacencyMaps xs = AM $ trimZeroes $ Map.unionWith mappend vs es where - vs = Map.fromSet (const Map.empty) . Set.unions $ map (Map.keysSet . snd) ss - es = Map.fromListWith (Map.unionWith mappend) $ map (fmap $ Map.filter (/= zero)) ss + vs = Map.fromSet (const Map.empty) . Set.unions $ map (Map.keysSet . snd) xs + es = Map.fromListWith (Map.unionWith mappend) xs -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. @@ -387,24 +395,51 @@ preSet x (AM m) = Set.fromAscList postSet :: Ord a => a -> AdjacencyMap e a -> Set a postSet x = Map.keysSet . Map.findWithDefault Map.empty x . adjacencyMap --- | Convert to the unlabelled 'AM.AdjacencyMap'. -skeleton :: AdjacencyMap Any a -> AM.AdjacencyMap a -skeleton (AM m) = AM.AM (Map.map Map.keysSet m) +-- | Convert a graph to the corresponding unlabelled 'AM.AdjacencyMap' by +-- forgetting labels on all non-'zero' edges. +-- +-- @ +-- 'hasEdge' x y == 'AM.hasEdge' x y . skeleton +-- @ +skeleton :: AdjacencyMap e a -> AM.AdjacencyMap a +skeleton (AM m) = AMI.AM (Map.map Map.keysSet m) -- | 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' e x x) == 'empty' +-- removeVertex 1 ('edge' e 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ removeVertex :: Ord a => a -> AdjacencyMap e a -> AdjacencyMap e a removeVertex x = AM . Map.map (Map.delete x) . Map.delete x . adjacencyMap -- | Remove an edge from a given graph. -- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge x y ('edge' e 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 e a -> AdjacencyMap e a removeEdge x y = AM . Map.adjust (Map.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. -- Complexity: /O((n + m) * log(n))/ time. -replaceVertex :: (Ord a, Semigroup e) => a -> a -> AdjacencyMap e a -> AdjacencyMap e a +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'gmap' (\\v -> if v == x then y else v) +-- @ +replaceVertex :: (Eq e, Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> AdjacencyMap e a replaceVertex u v = gmap $ \w -> if w == u then v else w -- | Replace an edge from a given graph. If it doesn't exist, it will be created. @@ -426,10 +461,17 @@ replaceEdge e x y -- | Transpose a given graph. -- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' e x y) == 'edge' e y x +-- transpose . transpose == id +-- @ transpose :: (Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a transpose (AM m) = AM $ Map.foldrWithKey combine vs m where - -- No need to do use @nonZeroUnion@ here, since we do not add any new edges + -- No need to use @nonZeroUnion@ here, since we do not add any new edges combine v es = Map.unionWith (Map.unionWith mappend) $ Map.fromAscList [ (u, Map.singleton v e) | (u, e) <- Map.toAscList es ] vs = Map.fromSet (const Map.empty) (Map.keysSet m) @@ -438,41 +480,122 @@ transpose (AM m) = AM $ Map.foldrWithKey combine vs m -- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric -- 'AdjacencyMap'. -- Complexity: /O((n + m) * log(n))/ time. -gmap :: (Ord a, Ord b, Semigroup e) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b -gmap f = AM . Map.map (Map.mapKeysWith (<+>) f) . - Map.mapKeysWith (Map.unionWith (<+>)) f . adjacencyMap +-- +-- @ +-- gmap f 'empty' == 'empty' +-- gmap f ('vertex' x) == 'vertex' (f x) +-- gmap f ('edge' e x y) == 'edge' e (f x) (f y) +-- gmap 'id' == 'id' +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Eq e, Monoid e, Ord a, Ord b) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b +gmap f = AM . trimZeroes . Map.map (Map.mapKeysWith (<+>) f) . + Map.mapKeysWith (Map.unionWith mappend) f . adjacencyMap --- | Transform a graph by applying a function to each of its edge labels. +-- | Transform a graph by applying a function @h@ to each of its edge labels. -- Complexity: /O((n + m) * log(n))/ time. -emap :: (e -> f) -> AdjacencyMap e a -> AdjacencyMap f a -emap f = AM . Map.map (Map.map f) . adjacencyMap +-- +-- The function @h@ is required to be a /homomorphism/ on the underlying type of +-- labels @e@. At the very least it must preserve 'zero' and '<+>': +-- +-- @ +-- h 'zero' == 'zero' +-- h x '<+>' h y == h (x '<+>' y) +-- @ +-- +-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative +-- structure: +-- +-- @ +-- h 'one' == 'one' +-- h x '<.>' h y == h (x '<.>' y) +-- @ +-- +-- If the above requirements hold, then the implementation provides the +-- following guarantees. +-- +-- @ +-- emap h 'empty' == 'empty' +-- emap h ('vertex' x) == 'vertex' x +-- emap h ('edge' e x y) == 'edge' (h e) x y +-- emap h ('overlay' x y) == 'overlay' (emap h x) (emap h y) +-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y) +-- emap 'id' == 'id' +-- emap g . emap h == emap (g . h) +-- @ +emap :: (Eq f, Monoid f) => (e -> f) -> AdjacencyMap e a -> AdjacencyMap f a +emap h = AM . trimZeroes . Map.map (Map.map h) . 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 :: (a -> Bool) -> AdjacencyMap e a -> AdjacencyMap e a induce p = AM . Map.map (Map.filterWithKey (\k _ -> p k)) . Map.filterWithKey (\k _ -> p k) . adjacencyMap -- | Compute the /reflexive and transitive closure/ of a graph over the -- underlying star semiring using the Warshall-Floyd-Kleene algorithm. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' 'one' x x +-- closure ('edge' e x x) == 'edge' 'one' x x +-- closure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- @ closure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a closure = goWarshallFloydKleene . reflexiveClosure -- | Compute the /reflexive closure/ of a graph over the underlying semiring by -- adding a self-loop of weight 'one' to every vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ reflexiveClosure :: (Ord a, Semiring e) => AdjacencyMap e a -> AdjacencyMap e a reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Map.insertWith (<+>) k one) m -- | Compute the /symmetric closure/ of a graph by overlaying it with its own -- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' e x y) == 'edges' [(e,x,y), (e,y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ symmetricClosure :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a symmetricClosure m = overlay m (transpose m) -- | Compute the /transitive closure/ of a graph over the underlying star -- semiring using a modified version of the Warshall-Floyd-Kleene algorithm, -- which omits the reflexivity step. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' e x y) == 'edge' e x y +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ transitiveClosure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a transitiveClosure = goWarshallFloydKleene diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs index 7df5b8376..a9f7be3de 100644 --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -48,7 +48,6 @@ import Prelude.Compat import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) -import Data.Monoid (Any) import Data.Set (Set) import Data.Tree @@ -460,36 +459,27 @@ instance ToGraph AIM.AdjacencyIntMap where isTopSortOf = AIM.isTopSortOf -- | See "Algebra.Graph.Labelled.AdjacencyMap". -instance Ord a => ToGraph (LAM.AdjacencyMap Any a) where - type ToVertex (LAM.AdjacencyMap Any a) = a - toGraph = toGraph . LAM.skeleton - -- isEmpty _ = False - -- hasVertex = NAM.hasVertex - -- hasEdge = NAM.hasEdge - -- vertexCount = NAM.vertexCount - -- edgeCount = NAM.edgeCount - -- vertexList = vertexList . NAM.am - -- vertexSet = NAM.vertexSet - -- vertexIntSet = vertexIntSet . NAM.am - -- edgeList = NAM.edgeList - -- edgeSet = NAM.edgeSet - -- adjacencyList = adjacencyList . NAM.am - -- preSet = NAM.preSet - -- postSet = NAM.postSet - -- adjacencyMap = adjacencyMap . NAM.am - -- adjacencyIntMap = adjacencyIntMap . NAM.am - -- dfsForest = dfsForest . NAM.am - -- dfsForestFrom xs = dfsForestFrom xs . NAM.am - -- dfs xs = dfs xs . NAM.am - -- reachable x = reachable x . NAM.am - -- topSort = topSort . NAM.am - -- isAcyclic = isAcyclic . NAM.am - -- toAdjacencyMap = NAM.am - -- toAdjacencyIntMap = toAdjacencyIntMap . NAM.am - -- toAdjacencyMapTranspose = NAM.am . NAM.transpose - -- toAdjacencyIntMapTranspose = toAdjacencyIntMap . NAM.transpose - -- isDfsForestOf f = isDfsForestOf f . NAM.am - -- isTopSortOf x = isTopSortOf x . NAM.am +instance (Eq e, Monoid e, Ord a) => ToGraph (LAM.AdjacencyMap e a) where + type ToVertex (LAM.AdjacencyMap e a) = a + toGraph = toGraph . LAM.skeleton + foldg e v o c = foldg e v o c . LAM.skeleton + isEmpty = LAM.isEmpty + hasVertex = LAM.hasVertex + hasEdge = LAM.hasEdge + vertexCount = LAM.vertexCount + edgeCount = LAM.edgeCount + vertexList = LAM.vertexList + vertexSet = LAM.vertexSet + vertexIntSet = IntSet.fromAscList . LAM.vertexList + edgeList = edgeList . LAM.skeleton + edgeSet = edgeSet . LAM.skeleton + adjacencyList = adjacencyList . LAM.skeleton + preSet = LAM.preSet + postSet = LAM.postSet + toAdjacencyMap = LAM.skeleton + toAdjacencyIntMap = toAdjacencyIntMap . LAM.skeleton + toAdjacencyMapTranspose = toAdjacencyMapTranspose . LAM.skeleton + toAdjacencyIntMapTranspose = toAdjacencyIntMapTranspose . LAM.skeleton -- | See "Algebra.Graph.NonEmpty.AdjacencyMap". instance Ord a => ToGraph (NAM.AdjacencyMap a) where diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs index fa41930b4..d7e692805 100644 --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -256,4 +256,6 @@ instance Ord a => GraphAPI (R.Relation a) where instance Ord a => GraphAPI (LAM.AdjacencyMap Any a) where vertices = LAM.vertices overlays = LAM.overlays + isSubgraphOf = LAM.isSubgraphOf removeVertex = LAM.removeVertex + induce = LAM.induce diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs index 25dd78a12..c13d25545 100644 --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -43,8 +43,8 @@ testsuite :: (Arbitrary g, GraphAPI g, Num g, Ord g, Show g, ToGraph g, ToVertex => String -> g -> Testsuite testsuite prefix g = Testsuite prefix (\f x -> f (x `asTypeOf` g)) -sizeLimit :: Testable prop => prop -> Property -sizeLimit = mapSize (min 10) +size10 :: Testable prop => prop -> Property +size10 = mapSize (min 10) testBasicPrimitives :: Testsuite -> IO () testBasicPrimitives = mconcat [ testOrd @@ -318,10 +318,10 @@ testOverlays (Testsuite prefix (%)) = do test "overlays [x,y] == overlay x y" $ \x y -> overlays [x,y] == id % overlay x y - test "overlays == foldr overlay empty" $ sizeLimit $ \xs -> + test "overlays == foldr overlay empty" $ size10 $ \xs -> overlays xs == id % foldr overlay empty xs - test "isEmpty . overlays == all isEmpty" $ sizeLimit $ \xs -> + test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> isEmpty % overlays xs == all isEmpty xs testConnects :: Testsuite -> IO () @@ -336,10 +336,10 @@ testConnects (Testsuite prefix (%)) = do test "connects [x,y] == connect x y" $ \x y -> connects [x,y] == id % connect x y - test "connects == foldr connect empty" $ sizeLimit $ \xs -> + test "connects == foldr connect empty" $ size10 $ \xs -> connects xs == id % foldr connect empty xs - test "isEmpty . connects == all isEmpty" $ sizeLimit $ \xs -> + test "isEmpty . connects == all isEmpty" $ size10 $ \xs -> isEmpty % connects xs == all isEmpty xs testStars :: Testsuite -> IO () @@ -984,7 +984,7 @@ testTranspose (Testsuite prefix (%)) = do test "transpose (edge x y) == edge y x" $ \x y -> transpose % edge x y == edge y x - test "transpose . transpose == id" $ sizeLimit $ \x -> + test "transpose . transpose == id" $ size10 $ \x -> (transpose . transpose) % x == x test "edgeList . transpose == sort . map swap . edgeList" $ \x -> @@ -1041,13 +1041,13 @@ testCompose (Testsuite prefix (%)) = do test "compose x (vertex y) == empty" $ \x y -> compose x % (vertex y) == empty - test "compose x (compose y z) == compose (compose x y) z" $ sizeLimit $ \x y z -> + test "compose x (compose y z) == compose (compose x y) z" $ size10 $ \x y z -> compose x % (compose y z) == compose (compose x y) z - test "compose x (overlay y z) == overlay (compose x y) (compose x z)" $ sizeLimit $ \x y z -> + test "compose x (overlay y z) == overlay (compose x y) (compose x z)" $ size10 $ \x y z -> compose x % (overlay y z) == overlay (compose x y) (compose x z) - test "compose (overlay x y) z == overlay (compose x z) (compose y z)" $ sizeLimit $ \x y z -> + test "compose (overlay x y) z == overlay (compose x z) (compose y z)" $ size10 $ \x y z -> compose (overlay x y) % z == overlay (compose x z) (compose y z) test "compose (edge x y) (edge y z) == edge x z" $ \x y z -> @@ -1077,16 +1077,16 @@ testClosure (Testsuite prefix (%)) = do test "closure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \xs -> closure % (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs) - test "closure == reflexiveClosure . transitiveClosure" $ sizeLimit $ \x -> + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> closure % x == (reflexiveClosure . transitiveClosure) x - test "closure == transitiveClosure . reflexiveClosure" $ sizeLimit $ \x -> + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> closure % x == (transitiveClosure . reflexiveClosure) x - test "closure . closure == closure" $ sizeLimit $ \x -> + test "closure . closure == closure" $ size10 $ \x -> (closure . closure) % x == closure x - test "postSet x (closure y) == Set.fromList (reachable x y)" $ sizeLimit $ \x y -> + test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \x y -> postSet x % (closure y) == Set.fromList (reachable x y) testReflexiveClosure :: Testsuite -> IO () @@ -1140,7 +1140,7 @@ testTransitiveClosure (Testsuite prefix (%)) = do test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \xs -> transitiveClosure % (path $ nubOrd xs) == clique (nubOrd xs) - test "transitiveClosure . transitiveClosure == transitiveClosure" $ sizeLimit $ \x -> + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> (transitiveClosure . transitiveClosure) x == transitiveClosure % x testSplitVertex :: Testsuite -> IO () @@ -1170,7 +1170,7 @@ testBind (Testsuite prefix (%)) = do test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> bind (edge x y) f == connect (f x) % f y - test "bind (vertices xs) f == overlays (map f xs)" $ sizeLimit $ \xs (apply -> f) -> + test "bind (vertices xs) f == overlays (map f xs)" $ size10 $ \xs (apply -> f) -> bind (vertices xs) f == id % overlays (map f xs) test "bind x (const empty) == empty" $ \x -> @@ -1179,7 +1179,7 @@ testBind (Testsuite prefix (%)) = do test "bind x vertex == x" $ \x -> bind x vertex == id % x - test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ sizeLimit $ \x (apply -> f) (apply -> g) -> + test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ size10 $ \x (apply -> f) (apply -> g) -> bind (bind x f) g == bind (id % x) (\y -> bind (f y) g) testSimplify :: Testsuite -> IO () diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs index 0adb2b9a7..eab175f16 100644 --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Labelled.AdjacencyMap @@ -20,83 +21,107 @@ import Algebra.Graph.Labelled.AdjacencyMap import Algebra.Graph.Labelled.AdjacencyMap.Internal import Algebra.Graph.Test import Algebra.Graph.Test.Generic +import Algebra.Graph.ToGraph (reachable) -import qualified Data.Set as Set +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Data.Map as Map +import qualified Data.Set as Set t :: Testsuite t = testsuite "Labelled.AdjacencyMap." (empty :: LAI) +type S = Sum Int +type D = Distance Int + type LAI = AdjacencyMap Any Int -type LAS = AdjacencyMap (Sum Int) Int -type LAD = AdjacencyMap (Distance Int) Int +type LAS = AdjacencyMap S Int +type LAD = AdjacencyMap D Int testLabelledAdjacencyMap :: IO () testLabelledAdjacencyMap = do - putStrLn "\n============ Labelled.AdjacencyMap ============" - test "Consistency of arbitraryLabelledAdjacencyMap" $ \(m :: LAI) -> - consistent m - - test "Consistency of fromAdjacencyMaps" $ \xs -> - consistent (fromAdjacencyMaps xs :: LAI) + putStrLn "\n============ Labelled.AdjacencyMap.Internal.consistent ============" + test "arbitraryLabelledAdjacencyMap" $ \x -> consistent (x :: LAS) + test "empty" $ consistent (empty :: LAS) + test "vertex" $ \x -> consistent (vertex x :: LAS) + test "edge" $ \e x y -> consistent (edge e x y :: LAS) + test "overlay" $ \x y -> consistent (overlay x y :: LAS) + test "connect" $ size10 $ \e x y -> consistent (connect e x y :: LAS) + test "vertices" $ \xs -> consistent (vertices xs :: LAS) + test "edges" $ \es -> consistent (edges es :: LAS) + test "overlays" $ size10 $ \xs -> consistent (overlays xs :: LAS) + test "fromAdjacencyMaps" $ \xs -> consistent (fromAdjacencyMaps xs :: LAS) + test "removeVertex" $ \x y -> consistent (removeVertex x y :: LAS) + test "removeEdge" $ \x y z -> consistent (removeEdge x y z :: LAS) + test "replaceVertex" $ \x y z -> consistent (replaceVertex x y z :: LAS) + test "replaceEdge" $ \e x y z -> consistent (replaceEdge e x y z :: LAS) + test "transpose" $ \x -> consistent (transpose x :: LAS) + test "gmap" $ \(apply -> f) x -> consistent (gmap f (x :: LAS) :: LAS) + test "emap" $ \(apply -> f) x -> consistent (emap (fmap f::S->S) x:: LAS) + test "induce" $ \(apply -> p) x -> consistent (induce p x :: LAS) + + test "closure" $ size10 $ \x -> consistent (closure x :: LAD) + test "reflexiveClosure" $ size10 $ \x -> consistent (reflexiveClosure x :: LAD) + test "symmetricClosure" $ size10 $ \x -> consistent (symmetricClosure x :: LAD) + test "transitiveClosure" $ size10 $ \x -> consistent (transitiveClosure x :: LAD) testEmpty t testVertex t putStrLn "\n============ Labelled.AdjacencyMap.edge ============" - test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: Sum Int) (x :: Int) y -> + test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: S) (x :: Int) y -> edge e x y == connect e (vertex x) (vertex y) test "edge zero x y == vertices [x,y]" $ \(x :: Int) y -> - edge (zero :: Sum Int) x y == vertices [x,y] + edge (zero :: S) x y == vertices [x,y] - test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: Sum Int) (x :: Int) y -> + test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: S) (x :: Int) y -> hasEdge x y (edge e x y) == (e /= mempty) - test "edgeLabel x y (edge e x y) == e" $ \(e :: Sum Int) (x :: Int) y -> + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> edgeLabel x y (edge e x y) == e - test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: Sum Int) (x :: Int) y -> + test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: S) (x :: Int) y -> edgeCount (edge e x y) == if e == mempty then 0 else 1 - test "vertexCount (edge e 1 1) == 1" $ \(e :: Sum Int) -> + test "vertexCount (edge e 1 1) == 1" $ \(e :: S) -> vertexCount (edge e 1 (1 :: Int)) == 1 - test "vertexCount (edge e 1 2) == 2" $ \(e :: Sum Int) -> + test "vertexCount (edge e 1 2) == 2" $ \(e :: S) -> vertexCount (edge e 1 (2 :: Int)) == 2 - test "x -- y == edge e x y" $ \(e :: Sum Int) (x :: Int) y -> + test "x -- y == edge e x y" $ \(e :: S) (x :: Int) y -> x -- y == edge e x y testOverlay t putStrLn "" - test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: Sum Int) (x :: Int) y -> + test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: S) (x :: Int) y -> edgeLabel x y (overlay (edge e x y) (edge zero x y)) == e - test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: Sum Int) f (x :: Int) y -> + test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: S) f (x :: Int) y -> edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f putStrLn "" - test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: Distance Int) -> + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e - test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: Distance Int) f -> + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f putStrLn "\n============ Labelled.AdjacencyMap.connect ============" - test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ size10 $ \(e :: S) (x :: LAS) y -> isEmpty (connect e x y) ==(isEmpty x && isEmpty y) - test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y z -> + test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ size10 $ \(e :: S) (x :: LAS) y z -> hasVertex z (connect e x y) ==(hasVertex z x || hasVertex z y) - test "vertexCount (connect e x y) >= vertexCount x" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + test "vertexCount (connect e x y) >= vertexCount x" $ size10 $ \(e :: S) (x :: LAS) y -> vertexCount (connect e x y) >= vertexCount x - test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ size10 $ \(e :: S) (x :: LAS) y -> vertexCount (connect e x y) <= vertexCount x + vertexCount y - test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ sizeLimit $ \(e :: Sum Int) (x :: LAS) y -> + test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ size10 $ \(e :: S) (x :: LAS) y -> edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y test "vertexCount (connect e 1 2) == 2" $ \(e :: Any) -> @@ -111,14 +136,27 @@ testLabelledAdjacencyMap = do test "edges [] == empty" $ edges [] == (empty :: LAS) - test "edges [(e,x,y)] == edge e x y" $ \(e :: Sum Int) (x :: Int) y -> + test "edges [(e,x,y)] == edge e x y" $ \(e :: S) (x :: Int) y -> edges [(e,x,y)] == edge e x y - test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(Sum Int, Int, Int)]) -> + test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(S, Int, Int)]) -> edges es ==(overlays . map (\(e, x, y) -> edge e x y)) es testOverlays t + putStrLn "\n============ Labelled.AdjacencyMap.fromAdjacencyMaps ============" + test "fromAdjacencyMaps [] == empty" $ + fromAdjacencyMaps [] == (empty :: LAS) + + test "fromAdjacencyMaps [(x, Map.empty)] == vertex x" $ \(x :: Int) -> + fromAdjacencyMaps [(x, Map.empty)] == (vertex x :: LAS) + + test "fromAdjacencyMaps [(x, Map.singleton y e)] == if e == zero then vertices [x,y] else edge e x y" $ \(e :: S) (x :: Int) y -> + fromAdjacencyMaps [(x, Map.singleton y e)] == if e == zero then vertices [x,y] else edge e x y + + test "overlay (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == (fromAdjacencyMaps (xs ++ ys) :: LAS) + putStrLn "\n============ Labelled.AdjacencyMap.isSubgraphOf ============" test "isSubgraphOf empty x == True" $ \(x :: LAS) -> isSubgraphOf empty x == True @@ -143,7 +181,7 @@ testLabelledAdjacencyMap = do test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> isEmpty (removeVertex x $ vertex x) == True - test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: Sum Int) (x :: Int) y -> + test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> isEmpty (removeEdge x y $ edge e x y) == False testHasVertex t @@ -155,7 +193,7 @@ testLabelledAdjacencyMap = do test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> hasEdge x y (vertex z) == False - test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: Sum Int) (x :: Int) y -> + test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: S) (x :: Int) y -> hasEdge x y (edge e x y) == (e /= zero) test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> @@ -167,12 +205,12 @@ testLabelledAdjacencyMap = do putStrLn "\n============ Labelled.AdjacencyMap.edgeLabel ============" test "edgeLabel x y empty == zero" $ \(x :: Int) y -> - edgeLabel x y empty == (zero :: Sum Int) + edgeLabel x y empty == (zero :: S) test "edgeLabel x y (vertex z) == zero" $ \(x :: Int) y z -> - edgeLabel x y (vertex z) == (zero :: Sum Int) + edgeLabel x y (vertex z) == (zero :: S) - test "edgeLabel x y (edge e x y) == e" $ \(e :: Sum Int) (x :: Int) y -> + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> edgeLabel x y (edge e x y) == e test "edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y" $ \(x :: LAS) y -> do @@ -190,7 +228,7 @@ testLabelledAdjacencyMap = do test "edgeCount (vertex x) == 0" $ \(x :: Int) -> edgeCount (vertex x) == 0 - test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: Sum Int) (x :: Int) y -> + test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: S) (x :: Int) y -> edgeCount (edge e x y) == if e == zero then 0 else 1 test "edgeCount == length . edgeList" $ \(x :: LAS) -> @@ -205,7 +243,7 @@ testLabelledAdjacencyMap = do test "edgeList (vertex x) == []" $ \(x :: Int) -> edgeList (vertex x :: LAS) == [] - test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: Sum Int) (x :: Int) y -> + test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: S) (x :: Int) y -> edgeList (edge e x y) == if e == zero then [] else [(e,x,y)] testVertexSet t @@ -217,7 +255,7 @@ testLabelledAdjacencyMap = do test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> edgeSet (vertex x :: LAS) == Set.empty - test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: Sum Int) (x :: Int) y -> + test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: S) (x :: Int) y -> edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) putStrLn "\n============ Labelled.AdjacencyMap.preSet ============" @@ -230,7 +268,7 @@ testLabelledAdjacencyMap = do test "preSet 1 (edge e 1 2) == Set.empty" $ \e -> preSet 1 (edge e 1 2 :: LAS) == Set.empty - test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: Sum Int) (x :: Int) y -> + test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: S) (x :: Int) y -> preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x] putStrLn "\n============ Labelled.AdjacencyMap.postSet ============" @@ -240,18 +278,198 @@ testLabelledAdjacencyMap = do test "postSet x (vertex x) == Set.empty" $ \x -> postSet x (vertex x :: LAS) == Set.empty - test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: Sum Int) (x :: Int) y -> + test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: S) (x :: Int) y -> postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y] test "postSet 2 (edge e 1 2) == Set.empty" $ \e -> postSet 2 (edge e 1 2 :: LAS) == Set.empty + putStrLn "\n============ Labelled.AdjacencyMap.skeleton ============" + test "hasEdge x y == hasEdge x y . skeleton" $ \x y (z :: LAS) -> + hasEdge x y z == (AM.hasEdge x y . skeleton) z + + putStrLn "\n============ Labelled.AdjacencyMap.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == (empty :: LAS) + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == (vertex 2 :: LAS) + + test "removeVertex x (edge e x x) == empty" $ \(e :: S) (x :: Int) -> + removeVertex x (edge e x x) == empty + + test "removeVertex 1 (edge e 1 2) == vertex 2" $ \(e :: S) -> + removeVertex 1 (edge e 1 2) == vertex (2 :: Int) + + test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: LAS) -> + (removeVertex x . removeVertex x) y == removeVertex x y + + putStrLn "\n============ Labelled.AdjacencyMap.removeEdge ============" + test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> + removeEdge x y (edge e x y) == vertices [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == (y :: LAS) + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == (vertex y :: LAS) + + test "replaceVertex x y == gmap (\\v -> if v == x then y else v)" $ \x y (z :: LAS) -> + replaceVertex x y z == gmap (\v -> if v == x then y else v) z + putStrLn "\n============ Labelled.AdjacencyMap.replaceEdge ============" - test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: Sum Int) (x :: Int) y z -> + test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) - test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: Sum Int) f (x :: Int) y -> + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> replaceEdge e x y (edge f x y) == edge e x y - test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: Sum Int) (x :: Int) y z -> + test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> edgeLabel x y (replaceEdge e x y z) == e + + putStrLn "\n============ Labelled.AdjacencyMap.transpose ============" + test "transpose empty == empty" $ + transpose empty == (empty :: LAS) + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == (vertex x :: LAS) + + test "transpose (edge e x y) == edge e y x" $ \e x y -> + transpose (edge e x y) == (edge e y x :: LAS) + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == (x :: LAS) + + putStrLn "\n============ Labelled.AdjacencyMap.gmap ============" + test "gmap f empty == empty" $ \(apply -> f) -> + gmap f (empty :: LAS) == (empty :: LAS) + + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + gmap f (vertex x :: LAS) == (vertex (f x) :: LAS) + + test "gmap f (edge e x y) == edge e (f x) (f y)" $ \(apply -> f) e x y -> + gmap f (edge e x y :: LAS) == (edge e (f x) (f y) :: LAS) + + test "gmap id == id" $ \x -> + gmap id x == (x :: LAS) + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> + ((gmap f :: LAS -> LAS) . gmap g) (x :: LAS) == gmap (f . g) x + + -- TODO: We only test homomorphisms @h@ on @Sum Int@, which all happen to be + -- just linear transformations: @h = (k*)@ for some @k :: Int@. These tests + -- are therefore rather weak and do not cover the ruch space of possible + -- monoid homomorphisms. How can we improve this? + putStrLn "\n============ Labelled.AdjacencyMap.emap ============" + test "emap h empty == empty" $ \(k :: S) -> + let h = (k*) + in emap h empty == (empty :: LAS) + + test "emap h (vertex x) == vertex x" $ \(k :: S) x -> + let h = (k*) + in emap h (vertex x) == (vertex x :: LAS) + + test "emap h (edge e x y) == edge (h e) x y" $ \(k :: S) e x y -> + let h = (k*) + in emap h (edge e x y) == (edge (h e) x y :: LAS) + + test "emap h (overlay x y) == overlay (emap h x) (emap h y)" $ \(k :: S) x y -> + let h = (k*) + in emap h (overlay x y) == (overlay (emap h x) (emap h y) :: LAS) + + test "emap h (connect e x y) == connect (h e) (emap h x) (emap h y)" $ \(k :: S) (e :: S) x y -> + let h = (k*) + in emap h (connect e x y) == (connect (h e) (emap h x) (emap h y) :: LAS) + + test "emap id == id" $ \x -> + emap id x == (id x :: LAS) + + test "emap g . emap h == emap (g . h)" $ \(k :: S) (l :: S) x -> + let h = (k*) + g = (l*) + in (emap g . emap h) x == (emap (g . h) x :: LAS) + + testInduce t + + putStrLn "\n============ Labelled.AdjacencyMap.closure ============" + test "closure empty == empty" $ + closure empty == (empty :: LAD) + + test "closure (vertex x) == edge one x x" $ \x -> + closure (vertex x) == (edge one x x :: LAD) + + test "closure (edge e x x) == edge one x x" $ \e x -> + closure (edge e x x) == (edge one x x :: LAD) + + test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure (x :: LAD) + + test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> + postSet x (closure y) == Set.fromList (reachable x y) + + putStrLn "\n============ Labelled.AdjacencyMap.reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == (empty :: LAD) + + test "reflexiveClosure (vertex x) == edge one x x" $ \x -> + reflexiveClosure (vertex x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> + reflexiveClosure (edge e x x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == (empty :: LAD) + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == (vertex x :: LAD) + + test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> + symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == (overlay x (transpose x) :: LAD) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: LAD) + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == (vertex x :: LAD) + + test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> + transitiveClosure (edge e x y) == (edge e x y :: LAD) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs index ff4605dad..90cab6667 100644 --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -33,7 +33,7 @@ type RI = Relation Int testRelation :: IO () testRelation = do putStrLn "\n============ Relation ============" - test "Axioms of graphs" $ sizeLimit (axioms :: GraphTestsuite RI) + test "Axioms of graphs" $ size10 (axioms :: GraphTestsuite RI) test "Consistency of arbitraryRelation" $ \(m :: RI) -> consistent m @@ -47,11 +47,11 @@ testRelation = do testRelational t putStrLn "\n============ ReflexiveRelation ============" - test "Axioms of reflexive graphs" $ sizeLimit + test "Axioms of reflexive graphs" $ size10 (reflexiveAxioms :: GraphTestsuite (ReflexiveRelation Int)) putStrLn "\n============ SymmetricRelation ============" - test "Axioms of undirected graphs" $ sizeLimit + test "Axioms of undirected graphs" $ size10 (undirectedAxioms :: GraphTestsuite (SymmetricRelation Int)) putStrLn "\n============ SymmetricRelation.neighbours ============" @@ -68,15 +68,15 @@ testRelation = do neighbours y (C.edge x y) == Set.fromList [x] putStrLn "\n============ TransitiveRelation ============" - test "Axioms of transitive graphs" $ sizeLimit + test "Axioms of transitive graphs" $ size10 (transitiveAxioms :: GraphTestsuite (TransitiveRelation Int)) - test "path xs == (clique xs :: TransitiveRelation Int)" $ sizeLimit $ \xs -> + test "path xs == (clique xs :: TransitiveRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: TransitiveRelation Int) putStrLn "\n============ PreorderRelation ============" - test "Axioms of preorder graphs" $ sizeLimit + test "Axioms of preorder graphs" $ size10 (preorderAxioms :: GraphTestsuite (PreorderRelation Int)) - test "path xs == (clique xs :: PreorderRelation Int)" $ sizeLimit $ \xs -> + test "path xs == (clique xs :: PreorderRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: PreorderRelation Int) From eaa530b471f3726c173572c3e2dca8ebb595ac26 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 02:50:43 +0000 Subject: [PATCH 09/17] Add docs and tests to Algebra.Graph.Labelled --- algebraic-graphs.cabal | 3 +- src/Algebra/Graph.hs | 4 +- src/Algebra/Graph/Class.hs | 8 + src/Algebra/Graph/Labelled.hs | 261 ++++++++-- src/Algebra/Graph/Labelled/AdjacencyMap.hs | 6 +- .../Graph/Labelled/AdjacencyMap/Internal.hs | 5 + .../Graph/Labelled/Example/Automaton.hs | 9 +- src/Algebra/Graph/ToGraph.hs | 6 + test/Algebra/Graph/Test/API.hs | 8 + test/Algebra/Graph/Test/Arbitrary.hs | 38 +- .../Graph/Test/Labelled/AdjacencyMap.hs | 2 +- test/Algebra/Graph/Test/Labelled/Graph.hs | 446 ++++++++++++++++++ test/Main.hs | 2 + 13 files changed, 745 insertions(+), 53 deletions(-) create mode 100644 test/Algebra/Graph/Test/Labelled/Graph.hs diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal index 90572f21e..0b3a3a524 100644 --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -141,9 +141,10 @@ test-suite test-alga Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, Algebra.Graph.Test.Internal, + Algebra.Graph.Test.Labelled.AdjacencyMap, + Algebra.Graph.Test.Labelled.Graph, Algebra.Graph.Test.NonEmpty.AdjacencyMap, Algebra.Graph.Test.NonEmpty.Graph, - Algebra.Graph.Test.Labelled.AdjacencyMap, Algebra.Graph.Test.Relation, Data.Graph.Test.Typed if impl(ghc >= 8.0.2) diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs index 8a43a3e31..074550142 100644 --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -686,11 +686,11 @@ adjacencyList = AM.adjacencyList . 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'. +-- 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 @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'. +-- 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 diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs index 75d5db9e6..6559726aa 100644 --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -56,6 +56,7 @@ import Algebra.Graph.Label (Dioid, one) import qualified Algebra.Graph as G import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Labelled as LG import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM import qualified Algebra.Graph.Fold as F import qualified Algebra.Graph.AdjacencyIntMap as AIM @@ -148,6 +149,13 @@ instance Graph AIM.AdjacencyIntMap where overlay = AIM.overlay connect = AIM.connect +instance Dioid e => Graph (LG.Graph e a) where + type Vertex (LG.Graph e a) = a + empty = LG.empty + vertex = LG.vertex + overlay = LG.overlay + connect = LG.connect one + instance (Dioid e, Eq e, Ord a) => Graph (LAM.AdjacencyMap e a) where type Vertex (LAM.AdjacencyMap e a) = a empty = LAM.empty diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index 149a65005..d89e2d860 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -16,14 +16,24 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Labelled ( -- * Algebraic data type for edge-labeleld graphs - Graph (..), empty, vertex, edge, overlay, connect, edges, overlays, - (-<), (>-), + Graph (..), empty, vertex, edge, (-<), (>-), overlay, connect, vertices, + edges, overlays, + + -- * Graph folding + foldg, -- * Relations on graphs isSubgraphOf, - -- * Operations - edgeLabel, emap, + -- * Graph properties + isEmpty, size, hasVertex, hasEdge, edgeLabel, edgeList, edgeSet, + + -- * Graph transformation + removeVertex, replaceVertex, + -- removeEdge, replaceEdge, + transpose, + -- gmap, + emap, induce, -- * Types of edge-labelled graphs UnlabelledGraph, Automaton, Network @@ -35,12 +45,11 @@ import Prelude.Compat import Data.Monoid (Any (..)) import Algebra.Graph.Label -import qualified Algebra.Graph.Class as C import qualified Algebra.Graph.Labelled.AdjacencyMap as AM -import qualified Algebra.Graph.ToGraph as U +import qualified Data.Set as Set -- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. --- For example, @Graph Bool a@ is isomorphic to unlabelled graphs defined in +-- 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 @@ -48,24 +57,42 @@ data Graph e a = Empty | Connect e (Graph e a) (Graph e a) deriving (Functor, Show) -instance (Ord a, Eq e, Monoid e) => Eq (Graph e a) where +instance (Eq e, Monoid e, Ord a) => Eq (Graph e a) where x == y = toAdjacencyMap x == toAdjacencyMap y --- | Extract the adjacency map of a graph. -toAdjacencyMap :: (Eq e, Monoid e, Ord a) => Graph e a -> AM.AdjacencyMap e a -toAdjacencyMap = foldg AM.empty AM.vertex AM.connect +instance (Eq e, Monoid e, Ord a, Ord e) => Ord (Graph e a) where + compare x y = compare (toAdjacencyMap x) (toAdjacencyMap y) -instance Dioid e => C.Graph (Graph e a) where - type Vertex (Graph e a) = a - empty = Empty - vertex = Vertex - overlay = overlay - connect = connect one +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' +-- for more details. +instance (Ord a, Num a, Dioid e) => Num (Graph e a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect one + signum = const empty + abs = id + negate = id -instance U.ToGraph (Graph Bool a) where - type ToVertex (Graph Bool a) = a - foldg e v o c = foldg e v (\x -> if x then c else o) +-- TODO: This is a very inefficient implementation. Find a way to construct an +-- adjacency map directly, without building intermediate representations for all +-- subgraphs. +-- Extract the adjacency map of a graph. +toAdjacencyMap :: (Eq e, Monoid e, Ord a) => Graph e a -> AM.AdjacencyMap e a +toAdjacencyMap = foldg AM.empty AM.vertex AM.connect +-- | 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 and connect. +-- Complexity: /O(s)/ applications of given functions. As an example, the +-- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- +-- @ +-- foldg 'empty' 'vertex' 'connect' == 'id' +-- foldg 'empty' 'vertex' ('fmap' 'flip' 'connect') == 'transpose' +-- foldg 1 ('const' 1) ('const' (+)) == 'size' +-- foldg True ('const' False) ('const' (&&)) == 'isEmpty' +-- foldg False (== x) ('const' (||)) == 'hasVertex' x +-- @ foldg :: b -> (a -> b) -> (e -> b -> b -> b) -> Graph e a -> b foldg e v c = go where @@ -90,20 +117,65 @@ isSubgraphOf x y = overlay x y == y -- | Construct the /empty graph/. An alias for the constructor 'Empty'. -- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ 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. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ vertex :: a -> Graph e a vertex = Vertex -- | Construct the graph comprising /a single labelled edge/. -- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- edge e x y == 'connect' e ('vertex' x) ('vertex' y) +-- edge 'zero' x y == 'vertices' [x,y] +-- 'hasEdge' x y (edge e x y) == (e /= 'zero') +-- 'edgeLabel' x y (edge e x y) == e +-- 'edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 +-- 'vertexCount' (edge e 1 1) == 1 +-- 'vertexCount' (edge e 1 2) == 2 +-- @ edge :: e -> a -> a -> Graph e a edge e x y = connect e (vertex x) (vertex y) +-- | The left-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(-<) :: a -> e -> (a, e) +g -< e = (g, e) + +-- | The right-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(>-) :: (a, e) -> a -> Graph e a +(x, e) >- y = edge e x y + +infixl 5 -< +infixl 5 >- + -- | Construct the graph from a list of labelled edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. @@ -129,26 +201,72 @@ overlays = foldr overlay empty connect :: e -> Graph e a -> Graph e a -> Graph e a connect = Connect --- | The left-hand part of a convenient ternary-ish operator @x -\- y@ for --- creating labelled edges. For example: +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. -- -- @ --- z = x -\<2\>- y +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' -- @ -(-<) :: a -> e -> (a, e) -x -< e = (x, e) +vertices :: Monoid e => [a] -> Graph e a +vertices = overlays . map vertex --- | The right-hand part of a convenient ternary-ish operator @x -\- y@ for --- creating labelled edges. For example: +-- | Check if a graph is empty. A convenient alias for 'null'. +-- Complexity: /O(s)/ time. -- -- @ --- z = x -\<2\>- y +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' e x y) == False -- @ -(>-) :: (a, e) -> a -> Graph e a -(x, e) >- y = edge e x y +isEmpty :: Graph e a -> Bool +isEmpty = foldg True (const False) (const (&&)) -infixl 5 -< -infixl 5 >- +-- | The /size/ of a graph, i.e. the number of leaves of the expression +-- including 'empty' leaves. +-- Complexity: /O(s)/ time. +-- +-- @ +-- size 'empty' == 1 +-- size ('vertex' x) == 1 +-- size ('overlay' x y) == size x + size y +-- size ('connect' x y) == size x + size y +-- size x >= 1 +-- size x >= 'vertexCount' x +-- @ +size :: Graph e a -> Int +size = foldg 1 (const 1) (const (+)) + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Eq a => a -> Graph e a -> Bool +hasVertex x = foldg False (==x) (const (||)) + +-- | Check if a graph contains a given edge. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' e x y) == (e /= 'zero') +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList' +-- @ +hasEdge :: (Eq e, Monoid e, Ord a) => a -> a -> Graph e a -> Bool +hasEdge x y = (/= zero) . edgeLabel x y -- | Extract the label of a specified edge from a graph. edgeLabel :: (Eq a, Monoid e) => a -> a -> Graph e a -> e @@ -159,11 +277,90 @@ edgeLabel s t g = let (res, _, _) = foldg e v c g in res c l (l1, s1, t1) (l2, s2, t2) | s1 && t2 = (mconcat [l1, l, l2], s1 || s2, t1 || t2) | otherwise = (mconcat [l1, l2], s1 || s2, t1 || t2) +-- | The list of edges of a graph, sorted lexicographically with respect to +-- pairs of connected vertices (i.e. edge-labels are ignored when sorting). +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)] +-- @ +edgeList :: (Eq e, Monoid e, Ord a) => Graph e a -> [(e, a, a)] +edgeList = AM.edgeList . toAdjacencyMap + +-- | The set of edges of a given graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y) +-- @ +edgeSet :: (Eq e, Monoid e, Ord a) => Graph e a -> Set.Set (e, a, a) +edgeSet = Set.fromAscList . edgeList + +-- | Remove a vertex from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' e x x) == 'empty' +-- removeVertex 1 ('edge' e 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Eq a => a -> Graph e a -> Graph e a +removeVertex x = induce (/= x) + +-- | 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. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'fmap' (\\v -> if v == x then y else v) +-- @ +replaceVertex :: Eq a => a -> a -> Graph e a -> Graph e a +replaceVertex u v = fmap $ \w -> if w == u then v else w + +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' e x y) == 'edge' e y x +-- transpose . transpose == id +-- @ +transpose :: Graph e a -> Graph e a +transpose = foldg empty vertex (fmap flip connect) + -- | Transform a graph by applying a function to each of its edge labels. -- Complexity: /O((n + m) * log(n))/ time. emap :: (e -> f) -> Graph e a -> Graph f a emap f = foldg Empty Vertex (Connect . f) +-- | 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 :: (a -> Bool) -> Graph e a -> Graph e a +induce p = foldg Empty (\x -> if p x then Vertex x else Empty) c + where + c _ x Empty = x -- Constant folding to get rid of Empty leaves + c _ Empty y = y + c e x y = Connect e x y + -- | A type synonym for /unlabelled graphs/. type UnlabelledGraph a = Graph Any a diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs index 148f5d507..1a4f58d93 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -359,8 +359,8 @@ edgeList (AM m) = vertexSet :: AdjacencyMap e a -> Set a vertexSet = Map.keysSet . adjacencyMap --- | The set of vertices of a given graph. --- Complexity: /O(n)/ time and memory. +-- | The set of edges of a given graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. -- -- @ -- edgeSet 'empty' == Set.'Set.empty' @@ -489,7 +489,7 @@ transpose (AM m) = AM $ Map.foldrWithKey combine vs m -- gmap f . gmap g == gmap (f . g) -- @ gmap :: (Eq e, Monoid e, Ord a, Ord b) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b -gmap f = AM . trimZeroes . Map.map (Map.mapKeysWith (<+>) f) . +gmap f = AM . trimZeroes . Map.map (Map.mapKeysWith mappend f) . Map.mapKeysWith (Map.unionWith mappend) f . adjacencyMap -- | Transform a graph by applying a function @h@ to each of its edge labels. diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs index bdd3171e2..4ba94555b 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs @@ -28,6 +28,11 @@ import qualified Data.Set as Set import Algebra.Graph.Label +-- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. +-- For example, 'AdjacencyMap' @Bool@ @a@ is isomorphic to unlabelled graphs +-- defined in the top-level module "Algebra.Graph.AdjacencyMap", where @False@ +-- and @True@ denote the lack of and the existence of an unlabelled edge, +-- respectively. newtype AdjacencyMap e a = AM { -- | The /adjacency map/ of an edge-labelled graph: each vertex is -- associated with a map from its direct successors to the corresponding diff --git a/src/Algebra/Graph/Labelled/Example/Automaton.hs b/src/Algebra/Graph/Labelled/Example/Automaton.hs index d3e5b34f0..802422ec6 100644 --- a/src/Algebra/Graph/Labelled/Example/Automaton.hs +++ b/src/Algebra/Graph/Labelled/Example/Automaton.hs @@ -16,13 +16,15 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Labelled.Example.Automaton where -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map (Map) +import Data.Monoid (Any (..)) import Algebra.Graph.Label import Algebra.Graph.Labelled import Algebra.Graph.ToGraph +import qualified Data.Map as Map + #if !MIN_VERSION_base(4,8,0) import Data.Set (Set) import qualified Data.Set as Set @@ -78,4 +80,5 @@ coffeeTeaAutomaton = overlays [ Choice -<[Coffee, Tea]>- Payment reachability :: Map State [State] reachability = Map.fromList $ map (\s -> (s, reachable s skeleton)) [Choice ..] where - skeleton = emap (not . isZero) coffeeTeaAutomaton + skeleton :: Graph Any State + skeleton = emap (Any . not . isZero) coffeeTeaAutomaton diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs index a9f7be3de..b4bc7a91b 100644 --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -55,6 +55,7 @@ import qualified Algebra.Graph as G import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM import qualified Algebra.Graph.AdjacencyMap.Internal as AM +import qualified Algebra.Graph.Labelled as LG import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM import qualified Algebra.Graph.NonEmpty.AdjacencyMap.Internal as NAM @@ -458,6 +459,11 @@ instance ToGraph AIM.AdjacencyIntMap where isDfsForestOf = AIM.isDfsForestOf isTopSortOf = AIM.isTopSortOf +-- | See "Algebra.Graph.Labelled". +instance (Eq e, Monoid e, Ord a) => ToGraph (LG.Graph e a) where + type ToVertex (LG.Graph e a) = a + foldg e v o c = LG.foldg e v (\e -> if e == mempty then o else c) + -- | See "Algebra.Graph.Labelled.AdjacencyMap". instance (Eq e, Monoid e, Ord a) => ToGraph (LAM.AdjacencyMap e a) where type ToVertex (LAM.AdjacencyMap e a) = a diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs index d7e692805..53d7485c7 100644 --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -21,6 +21,7 @@ import Algebra.Graph.Class (Graph (..)) import qualified Algebra.Graph as Graph import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Labelled as LG import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM import qualified Algebra.Graph.Fold as Fold import qualified Algebra.Graph.HigherKinded.Class as HClass @@ -253,6 +254,13 @@ instance Ord a => GraphAPI (R.Relation a) where symmetricClosure = R.symmetricClosure transitiveClosure = R.transitiveClosure +instance Ord a => GraphAPI (LG.Graph Any a) where + vertices = LG.vertices + overlays = LG.overlays + isSubgraphOf = LG.isSubgraphOf + removeVertex = LG.removeVertex + induce = LG.induce + instance Ord a => GraphAPI (LAM.AdjacencyMap Any a) where vertices = LAM.vertices overlays = LAM.overlays diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs index 497c9c0c3..2b05d75f0 100644 --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -31,13 +31,14 @@ import Algebra.Graph.Label import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.InternalDerived -import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap -import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap -import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.Labelled.AdjacencyMap as Labelled -import qualified Algebra.Graph.NonEmpty as NonEmpty -import qualified Algebra.Graph.Relation as Relation +import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Algebra.Graph.Relation as Relation -- | Generate an arbitrary 'C.Graph' value of a specified size. arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g @@ -139,15 +140,30 @@ arbitraryAdjacencyIntMap = AdjacencyIntMap.stars <$> arbitrary instance Arbitrary AdjacencyIntMap where arbitrary = arbitraryAdjacencyIntMap --- | Generate an arbitrary labelled 'Labelled.AdjacencyMap'. It is guaranteed +-- | Generate an arbitrary labelled 'LAM.AdjacencyMap'. It is guaranteed -- that the resulting adjacency map is 'consistent'. -arbitraryLabelledAdjacencyMap :: (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Gen (Labelled.AdjacencyMap e a) -arbitraryLabelledAdjacencyMap = Labelled.fromAdjacencyMaps <$> arbitrary +arbitraryLabelledAdjacencyMap :: (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Gen (LAM.AdjacencyMap e a) +arbitraryLabelledAdjacencyMap = LAM.fromAdjacencyMaps <$> arbitrary -- TODO: Implement a custom shrink method. -instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (Labelled.AdjacencyMap e a) where +instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.AdjacencyMap e a) where arbitrary = arbitraryLabelledAdjacencyMap +-- TODO: Implement a custom shrink method. +-- | Generate an arbitrary labelled 'LAM.Graph' value of a specified size. +arbitraryLabelledGraph :: (Arbitrary a, Arbitrary e) => Gen (LG.Graph e a) +arbitraryLabelledGraph = sized expr + where + expr 0 = return LG.empty + expr 1 = LG.vertex <$> arbitrary + expr n = do + label <- arbitrary + left <- choose (0, n) + LG.connect label <$> expr left <*> expr (n - left) + +instance (Arbitrary a, Arbitrary e) => Arbitrary (LG.Graph e a) where + arbitrary = arbitraryLabelledGraph + -- TODO: Implement a custom shrink method. instance Arbitrary a => Arbitrary (Tree a) where arbitrary = sized go diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs index eab175f16..7168d0fb8 100644 --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -188,7 +188,7 @@ testLabelledAdjacencyMap = do putStrLn "\n============ Labelled.AdjacencyMap.hasEdge ============" test "hasEdge x y empty == False" $ \(x :: Int) y -> - hasEdge x y empty == False + hasEdge x y empty == False test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> hasEdge x y (vertex z) == False diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs new file mode 100644 index 000000000..38dadff9b --- /dev/null +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Labelled.Graph +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Labelled.Graph". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Labelled.Graph ( + -- * Testsuite + testLabelledGraph + ) where + +import Data.Monoid + +import Algebra.Graph.Label +import Algebra.Graph.Labelled +import Algebra.Graph.Test +import Algebra.Graph.Test.Generic + +import qualified Algebra.Graph.ToGraph as T +import qualified Data.Set as Set + +t :: Testsuite +t = testsuite "Labelled.Graph." (empty :: LAI) + +type S = Sum Int +type D = Distance Int + +type LAI = Graph Any Int +type LAS = Graph S Int +type LAD = Graph D Int + +testLabelledGraph :: IO () +testLabelledGraph = do + putStrLn "\n============ Labelled.Graph.foldg ============" + test "foldg empty vertex connect == id" $ \(x :: LAS) -> + foldg empty vertex connect x == id x + + test "foldg empty vertex (fmap flip connect) == transpose" $ \(x :: LAS) -> + foldg empty vertex (fmap flip connect) x == transpose x + + test "foldg 1 (const 1) (const (+)) == size" $ \(x :: LAS) -> + foldg 1 (const 1) (const (+)) x == size x + + test "foldg True (const False) (const (&&)) == isEmpty" $ \(x :: LAS) -> + foldg True (const False) (const (&&)) x == isEmpty x + + test "foldg False (== x) (const (||)) == hasVertex x" $ \x (y :: LAS) -> + foldg False (== x) (const (||)) y == hasVertex x y + + testEmpty t + testVertex t + + putStrLn "\n============ Labelled.Graph.edge ============" + test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: S) (x :: Int) y -> + edge e x y == connect e (vertex x) (vertex y) + + test "edge zero x y == vertices [x,y]" $ \(x :: Int) y -> + edge (zero :: S) x y == vertices [x,y] + + test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= mempty) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: S) (x :: Int) y -> + T.edgeCount (edge e x y) == if e == mempty then 0 else 1 + + test "vertexCount (edge e 1 1) == 1" $ \(e :: S) -> + T.vertexCount (edge e 1 (1 :: Int)) == 1 + + test "vertexCount (edge e 1 2) == 2" $ \(e :: S) -> + T.vertexCount (edge e 1 (2 :: Int)) == 2 + + test "x -- y == edge e x y" $ \(e :: S) (x :: Int) y -> + x -- y == edge e x y + + testOverlay t + + putStrLn "" + test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge zero x y)) == e + + test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: S) f (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f + + -- putStrLn "" + -- test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> + -- edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e + + -- test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> + -- edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f + + putStrLn "\n============ Labelled.Graph.connect ============" + test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ size10 $ \(e :: S) (x :: LAS) y -> + isEmpty (connect e x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ size10 $ \(e :: S) (x :: LAS) y z -> + hasVertex z (connect e x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect e x y) >= vertexCount x" $ size10 $ \(e :: S) (x :: LAS) y -> + T.vertexCount (connect e x y) >= T.vertexCount x + + test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + T.vertexCount (connect e x y) <= T.vertexCount x + T.vertexCount y + + test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + T.edgeCount (connect e x y) <= T.vertexCount x * T.vertexCount y + T.edgeCount x + T.edgeCount y + + test "vertexCount (connect e 1 2) == 2" $ \(e :: Any) -> + T.vertexCount (connect e 1 (2 :: LAI)) == 2 + + test "edgeCount (connect e 1 2) == if e == zero then 0 else 1" $ \(e :: Any) -> + T.edgeCount (connect e 1 (2 :: LAI)) == if e == zero then 0 else 1 + + testVertices t + + putStrLn "\n============ Labelled.Graph.edges ============" + test "edges [] == empty" $ + edges [] == (empty :: LAS) + + test "edges [(e,x,y)] == edge e x y" $ \(e :: S) (x :: Int) y -> + edges [(e,x,y)] == edge e x y + + test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(S, Int, Int)]) -> + edges es ==(overlays . map (\(e, x, y) -> edge e x y)) es + + testOverlays t + + putStrLn "\n============ Labelled.Graph.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: LAS) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x)(empty :: LAS)== False + + test "isSubgraphOf x y ==> x <= y" $ \(x :: LAD) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Labelled.Graph.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty :: LAS) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + -- test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> + -- isEmpty (removeEdge x y $ edge e x y) == False + + testHasVertex t + + putStrLn "\n============ Labelled.Graph.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y (empty :: LAS) == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z :: LAS) == False + + test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= zero) + + -- test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> + -- (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == not . null . filter (\\(_,ex,ey) -> ex == x && ey == y) . edgeList" $ \x y (z :: LAS) -> do + (_, u, v) <- elements ((zero, x, y) : edgeList z) + return $ hasEdge u v z == (not . null . filter (\(_,ex,ey) -> ex == u && ey == v) . edgeList) z + + putStrLn "\n============ Labelled.Graph.edgeLabel ============" + test "edgeLabel x y empty == zero" $ \(x :: Int) y -> + edgeLabel x y empty == (zero :: S) + + test "edgeLabel x y (vertex z) == zero" $ \(x :: Int) y z -> + edgeLabel x y (vertex z) == (zero :: S) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y" $ \(x :: LAS) y -> do + z <- arbitrary + s <- elements ([z] ++ T.vertexList x ++ T.vertexList y) + t <- elements ([z] ++ T.vertexList x ++ T.vertexList y) + return $ edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y + + testVertexCount t + + putStrLn "\n============ Labelled.Graph.edgeCount ============" + test "edgeCount empty == 0" $ + T.edgeCount (empty :: LAS) == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + T.edgeCount (vertex x :: LAS) == 0 + + test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: S) (x :: Int) y -> + T.edgeCount (edge e x y) == if e == zero then 0 else 1 + + -- test "edgeCount == length . edgeList" $ \(x :: LAS) -> + -- T.edgeCount x == (length . edgeList) x + + testVertexList t + + putStrLn "\n============ Labelled.Graph.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: LAS) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x :: LAS) == [] + + test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: S) (x :: Int) y -> + edgeList (edge e x y) == if e == zero then [] else [(e,x,y)] + + testVertexSet t + + putStrLn "\n============ Labelled.Graph.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: LAS) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x :: LAS) == Set.empty + + test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: S) (x :: Int) y -> + edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) + + putStrLn "\n============ Labelled.Graph.preSet ============" + test "preSet x empty == Set.empty" $ \x -> + T.preSet x (empty :: LAS) == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + T.preSet x (vertex x :: LAS) == Set.empty + + test "preSet 1 (edge e 1 2) == Set.empty" $ \e -> + T.preSet 1 (edge e 1 2 :: LAS) == Set.empty + + test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: S) (x :: Int) y -> + T.preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x] + + putStrLn "\n============ Labelled.Graph.postSet ============" + test "postSet x empty == Set.empty" $ \x -> + T.postSet x (empty :: LAS) == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + T.postSet x (vertex x :: LAS) == Set.empty + + test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: S) (x :: Int) y -> + T.postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y] + + test "postSet 2 (edge e 1 2) == Set.empty" $ \e -> + T.postSet 2 (edge e 1 2 :: LAS) == Set.empty + + putStrLn "\n============ Labelled.Graph.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == (empty :: LAS) + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == (vertex 2 :: LAS) + + test "removeVertex x (edge e x x) == empty" $ \(e :: S) (x :: Int) -> + removeVertex x (edge e x x) == empty + + test "removeVertex 1 (edge e 1 2) == vertex 2" $ \(e :: S) -> + removeVertex 1 (edge e 1 2) == vertex (2 :: Int) + + test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: LAS) -> + (removeVertex x . removeVertex x) y == removeVertex x y + + -- putStrLn "\n============ Labelled.Graph.removeEdge ============" + -- test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> + -- removeEdge x y (edge e x y) == vertices [x,y] + + -- test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> + -- (removeEdge x y . removeEdge x y) z == removeEdge x y z + + -- test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> + -- (removeEdge x y . removeVertex x) z == removeVertex x z + + -- test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + -- removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) + + -- test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + -- removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) + + putStrLn "\n============ Labelled.Graph.replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == (y :: LAS) + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == (vertex y :: LAS) + + test "replaceVertex x y == fmap (\\v -> if v == x then y else v)" $ \x y (z :: LAS) -> + replaceVertex x y z == fmap (\v -> if v == x then y else v) z + + -- putStrLn "\n============ Labelled.Graph.replaceEdge ============" + -- test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> + -- replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) + + -- test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> + -- replaceEdge e x y (edge f x y) == edge e x y + + -- test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> + -- edgeLabel x y (replaceEdge e x y z) == e + + putStrLn "\n============ Labelled.Graph.transpose ============" + test "transpose empty == empty" $ + transpose empty == (empty :: LAS) + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == (vertex x :: LAS) + + test "transpose (edge e x y) == edge e y x" $ \e x y -> + transpose (edge e x y) == (edge e y x :: LAS) + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == (x :: LAS) + + putStrLn "\n============ Labelled.Graph.fmap ============" + test "fmap f empty == empty" $ \(apply -> f) -> + fmap f (empty :: LAS) == (empty :: LAS) + + test "fmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + fmap f (vertex x :: LAS) == (vertex (f x) :: LAS) + + test "fmap f (edge e x y) == edge e (f x) (f y)" $ \(apply -> f) e x y -> + fmap f (edge e x y :: LAS) == (edge e (f x) (f y) :: LAS) + + test "fmap id == id" $ \x -> + fmap id x == (x :: LAS) + + test "fmap f . fmap g == fmap (f . g)" $ \(apply -> f) (apply -> g) x -> + ((fmap f :: LAS -> LAS) . fmap g) (x :: LAS) == fmap (f . g) x + + -- TODO: We only test homomorphisms @h@ on @Sum Int@, which all happen to be + -- just linear transformations: @h = (k*)@ for some @k :: Int@. These tests + -- are therefore rather weak and do not cover the ruch space of possible + -- monoid homomorphisms. How can we improve this? + putStrLn "\n============ Labelled.Graph.emap ============" + test "emap h empty == empty" $ \(k :: S) -> + let h = (k*) + in emap h empty == (empty :: LAS) + + test "emap h (vertex x) == vertex x" $ \(k :: S) x -> + let h = (k*) + in emap h (vertex x) == (vertex x :: LAS) + + test "emap h (edge e x y) == edge (h e) x y" $ \(k :: S) e x y -> + let h = (k*) + in emap h (edge e x y) == (edge (h e) x y :: LAS) + + test "emap h (overlay x y) == overlay (emap h x) (emap h y)" $ \(k :: S) x y -> + let h = (k*) + in emap h (overlay x y) == (overlay (emap h x) (emap h y) :: LAS) + + test "emap h (connect e x y) == connect (h e) (emap h x) (emap h y)" $ \(k :: S) (e :: S) x y -> + let h = (k*) + in emap h (connect e x y) == (connect (h e) (emap h x) (emap h y) :: LAS) + + test "emap id == id" $ \x -> + emap id x == (id x :: LAS) + + test "emap g . emap h == emap (g . h)" $ \(k :: S) (l :: S) x -> + let h = (k*) + g = (l*) + in (emap g . emap h) x == (emap (g . h) x :: LAS) + + testInduce t + + -- putStrLn "\n============ Labelled.Graph.closure ============" + -- test "closure empty == empty" $ + -- closure empty == (empty :: LAD) + + -- test "closure (vertex x) == edge one x x" $ \x -> + -- closure (vertex x) == (edge one x x :: LAD) + + -- test "closure (edge e x x) == edge one x x" $ \e x -> + -- closure (edge e x x) == (edge one x x :: LAD) + + -- test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + -- closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + -- test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + -- closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x + + -- test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + -- closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x + + -- test "closure . closure == closure" $ size10 $ \x -> + -- (closure . closure) x == closure (x :: LAD) + + -- test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> + -- postSet x (closure y) == Set.fromList (reachable x y) + + -- putStrLn "\n============ Labelled.Graph.reflexiveClosure ============" + -- test "reflexiveClosure empty == empty" $ + -- reflexiveClosure empty == (empty :: LAD) + + -- test "reflexiveClosure (vertex x) == edge one x x" $ \x -> + -- reflexiveClosure (vertex x) == (edge one x x :: LAD) + + -- test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> + -- reflexiveClosure (edge e x x) == (edge one x x :: LAD) + + -- test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + -- reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + -- test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> + -- (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) + + -- putStrLn "\n============ Labelled.Graph.symmetricClosure ============" + -- test "symmetricClosure empty == empty" $ + -- symmetricClosure empty == (empty :: LAD) + + -- test "symmetricClosure (vertex x) == vertex x" $ \x -> + -- symmetricClosure (vertex x) == (vertex x :: LAD) + + -- test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> + -- symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) + + -- test "symmetricClosure x == overlay x (transpose x)" $ \x -> + -- symmetricClosure x == (overlay x (transpose x) :: LAD) + + -- test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> + -- (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) + + -- putStrLn "\n============ Labelled.Graph.transitiveClosure ============" + -- test "transitiveClosure empty == empty" $ + -- transitiveClosure empty == (empty :: LAD) + + -- test "transitiveClosure (vertex x) == vertex x" $ \x -> + -- transitiveClosure (vertex x) == (vertex x :: LAD) + + -- test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> + -- transitiveClosure (edge e x y) == (edge e x y :: LAD) + + -- test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + -- (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) diff --git a/test/Main.hs b/test/Main.hs index 480cd6e1e..0c736efac 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ import Algebra.Graph.Test.Graph import Algebra.Graph.Test.NonEmpty.Graph import Algebra.Graph.Test.Internal import Algebra.Graph.Test.Labelled.AdjacencyMap +import Algebra.Graph.Test.Labelled.Graph import Algebra.Graph.Test.Relation import Data.Graph.Test.Typed @@ -19,6 +20,7 @@ main = do testGraph testInternal testLabelledAdjacencyMap + testLabelledGraph testNonEmptyAdjacencyMap testNonEmptyGraph testRelation From 0402f12fc940ebf9e65ce5d7bc40410f69dfa62c Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 02:52:52 +0000 Subject: [PATCH 10/17] Clean up comments --- src/Algebra/Graph/Labelled.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index d89e2d860..15d8ab7a0 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -29,11 +29,7 @@ module Algebra.Graph.Labelled ( isEmpty, size, hasVertex, hasEdge, edgeLabel, edgeList, edgeSet, -- * Graph transformation - removeVertex, replaceVertex, - -- removeEdge, replaceEdge, - transpose, - -- gmap, - emap, induce, + removeVertex, replaceVertex, transpose, emap, induce, -- * Types of edge-labelled graphs UnlabelledGraph, Automaton, Network From 45fbc47d6e51090c3af44ddab70426fef0fea460 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 03:08:24 +0000 Subject: [PATCH 11/17] More comments --- src/Algebra/Graph/Labelled.hs | 127 ++++++++++++++---- .../Graph/Labelled/Example/Automaton.hs | 2 +- 2 files changed, 102 insertions(+), 27 deletions(-) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index 15d8ab7a0..9bc2c1bbe 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -117,8 +117,8 @@ isSubgraphOf x y = overlay x y == y -- @ -- 'isEmpty' empty == True -- 'hasVertex' x empty == False --- 'vertexCount' empty == 0 --- 'edgeCount' empty == 0 +-- 'Algebra.Graph.ToGraph.vertexCount' empty == 0 +-- 'Algebra.Graph.ToGraph.edgeCount' empty == 0 -- @ empty :: Graph e a empty = Empty @@ -130,8 +130,8 @@ empty = Empty -- @ -- 'isEmpty' (vertex x) == False -- 'hasVertex' x (vertex x) == True --- 'vertexCount' (vertex x) == 1 --- 'edgeCount' (vertex x) == 0 +-- 'Algebra.Graph.ToGraph.vertexCount' (vertex x) == 1 +-- 'Algebra.Graph.ToGraph.edgeCount' (vertex x) == 0 -- @ vertex :: a -> Graph e a vertex = Vertex @@ -144,9 +144,9 @@ vertex = Vertex -- edge 'zero' x y == 'vertices' [x,y] -- 'hasEdge' x y (edge e x y) == (e /= 'zero') -- 'edgeLabel' x y (edge e x y) == e --- 'edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 --- 'vertexCount' (edge e 1 1) == 1 --- 'vertexCount' (edge e 1 2) == 2 +-- 'Algebra.Graph.ToGraph.edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 +-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 1) == 1 +-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 2) == 2 -- @ edge :: e -> a -> a -> Graph e a edge e x y = connect e (vertex x) (vertex y) @@ -172,28 +172,48 @@ g -< e = (g, e) infixl 5 -< infixl 5 >- --- | Construct the graph from a list of labelled edges. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. -edges :: Monoid e => [(e, a, a)] -> Graph e a -edges = overlays . map (\(e, x, y) -> edge e x y) - -- | /Overlay/ two graphs. An alias for 'Connect' 'zero'. -- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) >= 'Algebra.Graph.ToGraph.vertexCount' x +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) >= 'Algebra.Graph.ToGraph.edgeCount' x +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) <= 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay 1 2) == 2 +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay 1 2) == 0 +-- @ +-- +-- Note: 'overlay' composes edges in parallel using the operator '<+>' with +-- 'zero' acting as the identity: +-- +-- @ +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<+>' f +-- @ +-- +-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in +-- sequence using the operator '<.>' with 'one' acting as the identity. overlay :: Monoid e => Graph e a -> Graph e a -> Graph e a overlay = connect zero --- | Overlay a given list of graphs. --- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length --- of the given list, and /S/ is the sum of sizes of the graphs in the list. -overlays :: Monoid e => [Graph e a] -> Graph e a -overlays = foldr overlay empty - -- | /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)/. +-- +-- @ +-- 'isEmpty' (connect e x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) >= 'Algebra.Graph.ToGraph.vertexCount' x +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y +-- 'Algebra.Graph.ToGraph.edgeCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x * 'Algebra.Graph.ToGraph.vertexCount' y + 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e 1 2) == 2 +-- 'Algebra.Graph.ToGraph.edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1 +-- @ connect :: e -> Graph e a -> Graph e a -> Graph e a connect = Connect @@ -205,12 +225,38 @@ connect = Connect -- vertices [] == 'empty' -- vertices [x] == 'vertex' x -- 'hasVertex' x . vertices == 'elem' x --- 'vertexCount' . vertices == 'length' . 'Data.List.nub' --- 'vertexSet' . vertices == Set.'Set.fromList' +-- 'Algebra.Graph.ToGraph.vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'Algebra.Graph.ToGraph.vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: Monoid e => [a] -> Graph e a vertices = overlays . map vertex +-- | Construct the graph from a list of labelled edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- edges [] == 'empty' +-- edges [(e,x,y)] == 'edge' e x y +-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) +-- @ +edges :: Monoid e => [(e, a, a)] -> Graph e a +edges = overlays . map (\(e, x, y) -> edge e x y) + +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: Monoid e => [Graph e a] -> Graph e a +overlays = foldr overlay empty + -- | Check if a graph is empty. A convenient alias for 'null'. -- Complexity: /O(s)/ time. -- @@ -234,7 +280,7 @@ isEmpty = foldg True (const False) (const (&&)) -- size ('overlay' x y) == size x + size y -- size ('connect' x y) == size x + size y -- size x >= 1 --- size x >= 'vertexCount' x +-- size x >= 'Algebra.Graph.ToGraph.vertexCount' x -- @ size :: Graph e a -> Int size = foldg 1 (const 1) (const (+)) @@ -322,7 +368,7 @@ replaceVertex :: Eq a => a -> a -> Graph e a -> Graph e a replaceVertex u v = fmap $ \w -> if w == u then v else w -- | Transpose a given graph. --- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- Complexity: /O(s)/ time, memory and size. -- -- @ -- transpose 'empty' == 'empty' @@ -334,14 +380,43 @@ transpose :: Graph e a -> Graph e a transpose = foldg empty vertex (fmap flip connect) -- | Transform a graph by applying a function to each of its edge labels. --- Complexity: /O((n + m) * log(n))/ time. +-- Complexity: /O(s)/ time, memory and size. +-- +-- The function @h@ is required to be a /homomorphism/ on the underlying type of +-- labels @e@. At the very least it must preserve 'zero' and '<+>': +-- +-- @ +-- h 'zero' == 'zero' +-- h x '<+>' h y == h (x '<+>' y) +-- @ +-- +-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative +-- structure: +-- +-- @ +-- h 'one' == 'one' +-- h x '<.>' h y == h (x '<.>' y) +-- @ +-- +-- If the above requirements hold, then the implementation provides the +-- following guarantees. +-- +-- @ +-- emap h 'empty' == 'empty' +-- emap h ('vertex' x) == 'vertex' x +-- emap h ('edge' e x y) == 'edge' (h e) x y +-- emap h ('overlay' x y) == 'overlay' (emap h x) (emap h y) +-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y) +-- emap 'id' == 'id' +-- emap g . emap h == emap (g . h) +-- @ emap :: (e -> f) -> Graph e a -> Graph f a emap f = foldg Empty Vertex (Connect . f) -- | 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. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. -- -- @ -- induce ('const' True ) x == x diff --git a/src/Algebra/Graph/Labelled/Example/Automaton.hs b/src/Algebra/Graph/Labelled/Example/Automaton.hs index 802422ec6..db4bf1d2d 100644 --- a/src/Algebra/Graph/Labelled/Example/Automaton.hs +++ b/src/Algebra/Graph/Labelled/Example/Automaton.hs @@ -28,7 +28,7 @@ import qualified Data.Map as Map #if !MIN_VERSION_base(4,8,0) import Data.Set (Set) import qualified Data.Set as Set -import GHC.Exts +import GHC.Exts hiding (Any) instance Ord a => IsList (Set a) where type Item (Set a) = a From 0d1f9e22d9fd00e87c8783227c9b0871adb0a1d4 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 19:53:26 +0000 Subject: [PATCH 12/17] Add missing functions --- src/Algebra/Graph.hs | 40 ++--- src/Algebra/Graph/Fold.hs | 6 +- src/Algebra/Graph/Labelled.hs | 199 +++++++++++++++++++++- src/Algebra/Graph/ToGraph.hs | 10 +- test/Algebra/Graph/Test/Arbitrary.hs | 8 +- test/Algebra/Graph/Test/Labelled/Graph.hs | 181 ++++++++++---------- 6 files changed, 320 insertions(+), 124 deletions(-) diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs index 074550142..19e77d2d4 100644 --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -48,8 +48,7 @@ module Algebra.Graph ( -- * Context Context (..), context - - ) where + ) where import Prelude () import Prelude.Compat hiding ((<>)) @@ -915,12 +914,12 @@ removeEdge s t = filterContext s (/=s) (/=t) {-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} -- TODO: Export --- | Filter vertices in a subgraph context. +-- Filter vertices in a subgraph context. 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) = induce (/=s) g `overlay` transpose (star s (filter i is)) - `overlay` star s (filter o os) + `overlay` star s (filter o os) {-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a @@ -1097,22 +1096,6 @@ box x y = overlays $ xs ++ ys toListGr :: Graph a -> List a toListGr = foldg mempty pure (<>) (<>) --- | '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 @@ -1213,3 +1196,20 @@ matchR e v p = \x -> if p x then v x else e "graph/induce" [1] forall f. foldg Empty (matchR Empty Vertex f) Overlay Connect = induce f #-} + +-- '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] } + deriving Show + +-- | Extract the context of a subgraph specified by a given predicate. Returns +-- @Nothing@ if the specified subgraph is empty. +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 diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs index 722c6485c..0eac9c3b5 100644 --- a/src/Algebra/Graph/Fold.hs +++ b/src/Algebra/Graph/Fold.hs @@ -40,7 +40,7 @@ module Algebra.Graph.Fold ( -- * Graph transformation removeVertex, removeEdge, transpose, induce, simplify, - ) where + ) where import Prelude () import Prelude.Compat @@ -653,12 +653,12 @@ removeEdge :: Eq a => a -> a -> Fold a -> Fold a removeEdge s t = filterContext s (/=s) (/=t) -- TODO: Export --- | Filter vertices in a subgraph context. +-- Filter vertices in a subgraph context. 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 (G.Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is)) - `overlay` star s (filter o os) + `overlay` star s (filter o os) -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index 9bc2c1bbe..acbdfdfae 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -26,13 +26,21 @@ module Algebra.Graph.Labelled ( isSubgraphOf, -- * Graph properties - isEmpty, size, hasVertex, hasEdge, edgeLabel, edgeList, edgeSet, + isEmpty, size, hasVertex, hasEdge, edgeLabel, vertexList, edgeList, + vertexSet, edgeSet, -- * Graph transformation - removeVertex, replaceVertex, transpose, emap, induce, + removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, emap, + induce, + + -- * Relational operations + closure, reflexiveClosure, symmetricClosure, transitiveClosure, -- * Types of edge-labelled graphs - UnlabelledGraph, Automaton, Network + UnlabelledGraph, Automaton, Network, + + -- * Context + Context (..), context ) where import Prelude () @@ -40,9 +48,13 @@ import Prelude.Compat import Data.Monoid (Any (..)) +import Algebra.Graph.Internal (List (..)) import Algebra.Graph.Label + import qualified Algebra.Graph.Labelled.AdjacencyMap as AM import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified GHC.Exts as Exts -- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. -- For example, 'Graph' @Bool@ @a@ is isomorphic to unlabelled graphs defined in @@ -76,6 +88,12 @@ instance (Ord a, Num a, Dioid e) => Num (Graph e a) where toAdjacencyMap :: (Eq e, Monoid e, Ord a) => Graph e a -> AM.AdjacencyMap e a toAdjacencyMap = foldg AM.empty AM.vertex AM.connect +-- Convert the adjacency map to a graph. +fromAdjacencyMap :: Monoid e => AM.AdjacencyMap e a -> Graph e a +fromAdjacencyMap = overlays . map go . Map.toList . AM.adjacencyMap + where + go (u, m) = overlay (vertex u) (edges [ (e, u, v) | (v, e) <- Map.toList m]) + -- | 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 and connect. @@ -83,11 +101,12 @@ toAdjacencyMap = foldg AM.empty AM.vertex AM.connect -- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. -- -- @ --- foldg 'empty' 'vertex' 'connect' == 'id' --- foldg 'empty' 'vertex' ('fmap' 'flip' 'connect') == 'transpose' --- foldg 1 ('const' 1) ('const' (+)) == 'size' --- foldg True ('const' False) ('const' (&&)) == 'isEmpty' --- foldg False (== x) ('const' (||)) == 'hasVertex' x +-- foldg 'empty' 'vertex' 'connect' == 'id' +-- foldg 'empty' 'vertex' ('fmap' 'flip' 'connect') == 'transpose' +-- foldg 1 ('const' 1) ('const' (+)) == 'size' +-- foldg True ('const' False) ('const' (&&)) == 'isEmpty' +-- foldg False (== x) ('const' (||)) == 'hasVertex' x +-- foldg Set.'Set.empty' Set.'Set.singleton' ('const' Set.'Set.union') == 'vertexSet' -- @ foldg :: b -> (a -> b) -> (e -> b -> b -> b) -> Graph e a -> b foldg e v c = go @@ -195,7 +214,12 @@ infixl 5 >- -- @ -- -- Furthermore, when applied to transitive graphs, 'overlay' composes edges in --- sequence using the operator '<.>' with 'one' acting as the identity. +-- sequence using the operator '<.>' with 'one' acting as the identity: +-- +-- @ +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f y z)) == e '<.>' f +-- @ overlay :: Monoid e => Graph e a -> Graph e a -> Graph e a overlay = connect zero @@ -319,6 +343,17 @@ edgeLabel s t g = let (res, _, _) = foldg e v c g in res c l (l1, s1, t1) (l2, s2, t2) | s1 && t2 = (mconcat [l1, l, l2], s1 || s2, t1 || t2) | otherwise = (mconcat [l1, l2], s1 || s2, t1 || t2) +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: Ord a => Graph e a -> [a] +vertexList = Set.toAscList . vertexSet + -- | The list of edges of a graph, sorted lexicographically with respect to -- pairs of connected vertices (i.e. edge-labels are ignored when sorting). -- Complexity: /O(n + m)/ time and /O(m)/ memory. @@ -331,6 +366,17 @@ edgeLabel s t g = let (res, _, _) = foldg e v c g in res edgeList :: (Eq e, Monoid e, Ord a) => Graph e a -> [(e, a, a)] edgeList = AM.edgeList . toAdjacencyMap +-- | The set of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: Ord a => Graph e a -> Set.Set a +vertexSet = foldg Set.empty Set.singleton (const Set.union) + -- | The set of edges of a given graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory. -- @@ -355,6 +401,19 @@ edgeSet = Set.fromAscList . edgeList removeVertex :: Eq a => a -> Graph e a -> Graph e a removeVertex x = induce (/= x) +-- | Remove an edge from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x y ('edge' e 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 :: (Eq a, Eq e, Monoid e) => a -> a -> Graph e a -> Graph e a +removeEdge s t = filterContext s (/=s) (/=t) + -- | 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. -- Complexity: /O(s)/ time, memory and size. @@ -367,6 +426,17 @@ removeVertex x = induce (/= x) replaceVertex :: Eq a => a -> a -> Graph e a -> Graph e a replaceVertex u v = fmap $ \w -> if w == u then v else w +-- | Replace an edge from a given graph. If it doesn't exist, it will be created. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- replaceEdge e x y z == 'overlay' (removeEdge x y z) ('edge' e x y) +-- replaceEdge e x y ('edge' f x y) == 'edge' e x y +-- 'edgeLabel' x y (replaceEdge e x y z) == e +-- @ +replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> Graph e a -> Graph e a +replaceEdge e x y = overlay (edge e x y) . removeEdge x y + -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. -- @@ -432,6 +502,63 @@ induce p = foldg Empty (\x -> if p x then Vertex x else Empty) c c _ Empty y = y c e x y = Connect e x y +-- | Compute the /reflexive and transitive closure/ of a graph over the +-- underlying star semiring using the Warshall-Floyd-Kleene algorithm. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' 'one' x x +-- closure ('edge' e x x) == 'edge' 'one' x x +-- closure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'Algebra.Graph.ToGraph.postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- @ +closure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a +closure = fromAdjacencyMap . AM.closure . toAdjacencyMap + +-- | Compute the /reflexive closure/ of a graph over the underlying semiring by +-- adding a self-loop of weight 'one' to every vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ +reflexiveClosure :: (Ord a, Semiring e) => Graph e a -> Graph e a +reflexiveClosure x = overlay x $ edges [ (one, v, v) | v <- vertexList x ] + +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' e x y) == 'edges' [(e,x,y), (e,y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ +symmetricClosure :: Monoid e => Graph e a -> Graph e a +symmetricClosure m = overlay m (transpose m) + +-- | Compute the /transitive closure/ of a graph over the underlying star +-- semiring using a modified version of the Warshall-Floyd-Kleene algorithm, +-- which omits the reflexivity step. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' e x y) == 'edge' e x y +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a +transitiveClosure = fromAdjacencyMap . AM.transitiveClosure . toAdjacencyMap + -- | A type synonym for /unlabelled graphs/. type UnlabelledGraph a = Graph Any a @@ -440,3 +567,57 @@ type Automaton a s = Graph (RegularExpression a) s -- | A /network/ is a graph whose edges are labelled with distances. type Network e a = Graph (Distance e) a + +-- Filter vertices in a subgraph context. +filterContext :: (Eq a, Eq e, Monoid e) => a -> (a -> Bool) -> (a -> Bool) -> Graph e a -> Graph e a +filterContext s i o g = maybe g go $ context (==s) g + where + go (Context is os) = overlays [ vertex s + , induce (/=s) g + , edges [ (e, v, s) | (e, v) <- is, i v ] + , edges [ (e, s, v) | (e, v) <- os, o v ] ] + +-- 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 'removeEdge' for a use-case example. +data Focus e a = Focus + { ok :: Bool -- ^ True if focus on the specified subgraph is obtained. + , is :: List (e, a) -- ^ Inputs into the focused subgraph. + , os :: List (e, a) -- ^ Outputs out of the focused subgraph. + , vs :: List a } -- ^ All vertices (leaves) of the graph expression. + +-- Focus on the 'empty' graph. +emptyFocus :: Focus e a +emptyFocus = Focus False mempty mempty mempty + +-- | Focus on the graph with a single vertex, given a predicate indicating +-- whether the vertex is of interest. +vertexFocus :: (a -> Bool) -> a -> Focus e a +vertexFocus f x = Focus (f x) mempty mempty (pure x) + +-- | Connect two foci. +connectFoci :: (Eq e, Monoid e) => e -> Focus e a -> Focus e a -> Focus e a +connectFoci e x y + | e == mempty = Focus (ok x || ok y) (is x <> is y) (os x <> os y) (vs x <> vs y) + | otherwise = Focus (ok x || ok y) (xs <> is y) (os x <> ys ) (vs x <> vs y) + where + xs = if ok y then fmap (e,) (vs x) else is x + ys = if ok x then fmap (e,) (vs y) else os y + +-- | 'Focus' on a specified subgraph. +focus :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Focus e a +focus f = foldg emptyFocus (vertexFocus f) connectFoci + +-- | The /context/ of a subgraph comprises the input and output vertices outside +-- the subgraph that are connected to the vertices inside the subgraph (along +-- with the corresponding edge labels). +data Context e a = Context { inputs :: [(e, a)], outputs :: [(e, a)] } + deriving Show + +-- | Extract the context of a subgraph specified by a given predicate. Returns +-- @Nothing@ if the specified subgraph is empty. +context :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Maybe (Context e a) +context p g | ok f = Just $ Context (Exts.toList $ is f) (Exts.toList $ os f) + | otherwise = Nothing + where + f = focus p g diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs index b4bc7a91b..f4d6e395d 100644 --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -462,7 +462,15 @@ instance ToGraph AIM.AdjacencyIntMap where -- | See "Algebra.Graph.Labelled". instance (Eq e, Monoid e, Ord a) => ToGraph (LG.Graph e a) where type ToVertex (LG.Graph e a) = a - foldg e v o c = LG.foldg e v (\e -> if e == mempty then o else c) + foldg e v o c = LG.foldg e v (\e -> if e == mempty then o else c) + vertexList = LG.vertexList + vertexSet = LG.vertexSet + toAdjacencyMap = LAM.skeleton + . LG.foldg LAM.empty LAM.vertex LAM.connect + toAdjacencyMapTranspose = LAM.skeleton + . LG.foldg LAM.empty LAM.vertex (fmap flip LAM.connect) + toAdjacencyIntMap = toAdjacencyIntMap . toAdjacencyMap + toAdjacencyIntMapTranspose = toAdjacencyIntMapTranspose . toAdjacencyMapTranspose -- | See "Algebra.Graph.Labelled.AdjacencyMap". instance (Eq e, Monoid e, Ord a) => ToGraph (LAM.AdjacencyMap e a) where diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs index 2b05d75f0..4a016b823 100644 --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -149,7 +149,6 @@ arbitraryLabelledAdjacencyMap = LAM.fromAdjacencyMaps <$> arbitrary instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.AdjacencyMap e a) where arbitrary = arbitraryLabelledAdjacencyMap --- TODO: Implement a custom shrink method. -- | Generate an arbitrary labelled 'LAM.Graph' value of a specified size. arbitraryLabelledGraph :: (Arbitrary a, Arbitrary e) => Gen (LG.Graph e a) arbitraryLabelledGraph = sized expr @@ -161,9 +160,14 @@ arbitraryLabelledGraph = sized expr left <- choose (0, n) LG.connect label <$> expr left <*> expr (n - left) -instance (Arbitrary a, Arbitrary e) => Arbitrary (LG.Graph e a) where +instance (Arbitrary a, Arbitrary e, Monoid e) => Arbitrary (LG.Graph e a) where arbitrary = arbitraryLabelledGraph + shrink LG.Empty = [] + shrink (LG.Vertex _) = [LG.Empty] + shrink (LG.Connect e x y) = [LG.Empty, x, y, LG.Connect mempty x y] + ++ [LG.Connect e x' y' | (x', y') <- shrink (x, y) ] + -- TODO: Implement a custom shrink method. instance Arbitrary a => Arbitrary (Tree a) where arbitrary = sized go diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs index 38dadff9b..ee34b0ad9 100644 --- a/test/Algebra/Graph/Test/Labelled/Graph.hs +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -21,8 +21,8 @@ import Algebra.Graph.Labelled import Algebra.Graph.Test import Algebra.Graph.Test.Generic -import qualified Algebra.Graph.ToGraph as T -import qualified Data.Set as Set +import qualified Algebra.Graph.ToGraph as T +import qualified Data.Set as Set t :: Testsuite t = testsuite "Labelled.Graph." (empty :: LAI) @@ -37,20 +37,23 @@ type LAD = Graph D Int testLabelledGraph :: IO () testLabelledGraph = do putStrLn "\n============ Labelled.Graph.foldg ============" - test "foldg empty vertex connect == id" $ \(x :: LAS) -> - foldg empty vertex connect x == id x + test "foldg empty vertex connect == id" $ \(x :: LAS) -> + foldg empty vertex connect x == id x - test "foldg empty vertex (fmap flip connect) == transpose" $ \(x :: LAS) -> - foldg empty vertex (fmap flip connect) x == transpose x + test "foldg empty vertex (fmap flip connect) == transpose" $ \(x :: LAS) -> + foldg empty vertex (fmap flip connect) x == transpose x - test "foldg 1 (const 1) (const (+)) == size" $ \(x :: LAS) -> - foldg 1 (const 1) (const (+)) x == size x + test "foldg 1 (const 1) (const (+)) == size" $ \(x :: LAS) -> + foldg 1 (const 1) (const (+)) x == size x - test "foldg True (const False) (const (&&)) == isEmpty" $ \(x :: LAS) -> - foldg True (const False) (const (&&)) x == isEmpty x + test "foldg True (const False) (const (&&)) == isEmpty" $ \(x :: LAS) -> + foldg True (const False) (const (&&)) x == isEmpty x - test "foldg False (== x) (const (||)) == hasVertex x" $ \x (y :: LAS) -> - foldg False (== x) (const (||)) y == hasVertex x y + test "foldg False (== x) (const (||)) == hasVertex x" $ \x (y :: LAS) -> + foldg False (== x) (const (||)) y == hasVertex x y + + test "foldg Set.empty Set.singleton (const Set.union) == vertexSet" $ \(x :: LAS) -> + foldg Set.empty Set.singleton (const Set.union) x == vertexSet x testEmpty t testVertex t @@ -89,12 +92,12 @@ testLabelledGraph = do test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: S) f (x :: Int) y -> edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f - -- putStrLn "" - -- test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> - -- edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e + putStrLn "" + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e - -- test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> - -- edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f putStrLn "\n============ Labelled.Graph.connect ============" test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ size10 $ \(e :: S) (x :: LAS) y -> @@ -156,8 +159,8 @@ testLabelledGraph = do test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> isEmpty (removeVertex x $ vertex x) == True - -- test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> - -- isEmpty (removeEdge x y $ edge e x y) == False + test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> + isEmpty (removeEdge x y $ edge e x y) == False testHasVertex t @@ -171,8 +174,8 @@ testLabelledGraph = do test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: S) (x :: Int) y -> hasEdge x y (edge e x y) == (e /= zero) - -- test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> - -- (hasEdge x y . removeEdge x y) z == const False z + test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> + (hasEdge x y . removeEdge x y) z == const False z test "hasEdge x y == not . null . filter (\\(_,ex,ey) -> ex == x && ey == y) . edgeList" $ \x y (z :: LAS) -> do (_, u, v) <- elements ((zero, x, y) : edgeList z) @@ -206,8 +209,8 @@ testLabelledGraph = do test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: S) (x :: Int) y -> T.edgeCount (edge e x y) == if e == zero then 0 else 1 - -- test "edgeCount == length . edgeList" $ \(x :: LAS) -> - -- T.edgeCount x == (length . edgeList) x + test "edgeCount == length . edgeList" $ \(x :: LAS) -> + T.edgeCount x == (length . edgeList) x testVertexList t @@ -275,21 +278,21 @@ testLabelledGraph = do test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: LAS) -> (removeVertex x . removeVertex x) y == removeVertex x y - -- putStrLn "\n============ Labelled.Graph.removeEdge ============" - -- test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> - -- removeEdge x y (edge e x y) == vertices [x,y] + putStrLn "\n============ Labelled.Graph.removeEdge ============" + test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> + removeEdge x y (edge e x y) == vertices [x,y] - -- test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> - -- (removeEdge x y . removeEdge x y) z == removeEdge x y z + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z - -- test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> - -- (removeEdge x y . removeVertex x) z == removeVertex x z + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> + (removeEdge x y . removeVertex x) z == removeVertex x z - -- test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - -- removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) - -- test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ - -- removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) putStrLn "\n============ Labelled.Graph.replaceVertex ============" test "replaceVertex x x == id" $ \x y -> @@ -301,15 +304,15 @@ testLabelledGraph = do test "replaceVertex x y == fmap (\\v -> if v == x then y else v)" $ \x y (z :: LAS) -> replaceVertex x y z == fmap (\v -> if v == x then y else v) z - -- putStrLn "\n============ Labelled.Graph.replaceEdge ============" - -- test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> - -- replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) + putStrLn "\n============ Labelled.Graph.replaceEdge ============" + test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> + replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) - -- test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> - -- replaceEdge e x y (edge f x y) == edge e x y + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> + replaceEdge e x y (edge f x y) == edge e x y - -- test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> - -- edgeLabel x y (replaceEdge e x y z) == e + test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> + edgeLabel x y (replaceEdge e x y z) == e putStrLn "\n============ Labelled.Graph.transpose ============" test "transpose empty == empty" $ @@ -375,72 +378,72 @@ testLabelledGraph = do testInduce t - -- putStrLn "\n============ Labelled.Graph.closure ============" - -- test "closure empty == empty" $ - -- closure empty == (empty :: LAD) + putStrLn "\n============ Labelled.Graph.closure ============" + test "closure empty == empty" $ + closure empty == (empty :: LAD) - -- test "closure (vertex x) == edge one x x" $ \x -> - -- closure (vertex x) == (edge one x x :: LAD) + test "closure (vertex x) == edge one x x" $ \x -> + closure (vertex x) == (edge one x x :: LAD) - -- test "closure (edge e x x) == edge one x x" $ \e x -> - -- closure (edge e x x) == (edge one x x :: LAD) + test "closure (edge e x x) == edge one x x" $ \e x -> + closure (edge e x x) == (edge one x x :: LAD) - -- test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> - -- closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) - -- test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> - -- closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x - -- test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> - -- closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x - -- test "closure . closure == closure" $ size10 $ \x -> - -- (closure . closure) x == closure (x :: LAD) + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure (x :: LAD) - -- test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> - -- postSet x (closure y) == Set.fromList (reachable x y) + test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> + T.postSet x (closure y) == Set.fromList (T.reachable x y) - -- putStrLn "\n============ Labelled.Graph.reflexiveClosure ============" - -- test "reflexiveClosure empty == empty" $ - -- reflexiveClosure empty == (empty :: LAD) + putStrLn "\n============ Labelled.Graph.reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == (empty :: LAD) - -- test "reflexiveClosure (vertex x) == edge one x x" $ \x -> - -- reflexiveClosure (vertex x) == (edge one x x :: LAD) + test "reflexiveClosure (vertex x) == edge one x x" $ \x -> + reflexiveClosure (vertex x) == (edge one x x :: LAD) - -- test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> - -- reflexiveClosure (edge e x x) == (edge one x x :: LAD) + test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> + reflexiveClosure (edge e x x) == (edge one x x :: LAD) - -- test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> - -- reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) - -- test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> - -- (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) - -- putStrLn "\n============ Labelled.Graph.symmetricClosure ============" - -- test "symmetricClosure empty == empty" $ - -- symmetricClosure empty == (empty :: LAD) + putStrLn "\n============ Labelled.Graph.symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == (empty :: LAD) - -- test "symmetricClosure (vertex x) == vertex x" $ \x -> - -- symmetricClosure (vertex x) == (vertex x :: LAD) + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == (vertex x :: LAD) - -- test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> - -- symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) + test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> + symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) - -- test "symmetricClosure x == overlay x (transpose x)" $ \x -> - -- symmetricClosure x == (overlay x (transpose x) :: LAD) + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == (overlay x (transpose x) :: LAD) - -- test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> - -- (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) + test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) - -- putStrLn "\n============ Labelled.Graph.transitiveClosure ============" - -- test "transitiveClosure empty == empty" $ - -- transitiveClosure empty == (empty :: LAD) + putStrLn "\n============ Labelled.Graph.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: LAD) - -- test "transitiveClosure (vertex x) == vertex x" $ \x -> - -- transitiveClosure (vertex x) == (vertex x :: LAD) + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == (vertex x :: LAD) - -- test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> - -- transitiveClosure (edge e x y) == (edge e x y :: LAD) + test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> + transitiveClosure (edge e x y) == (edge e x y :: LAD) - -- test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> - -- (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) From 2dfdabdcb4138cd0d004e4995f1d26da258b76c9 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 20:09:37 +0000 Subject: [PATCH 13/17] Work on context --- src/Algebra/Graph.hs | 13 ++++++++++--- src/Algebra/Graph/Labelled.hs | 15 +++++++++++---- test/Algebra/Graph/Test/Labelled/Graph.hs | 13 +++++++++++++ 3 files changed, 34 insertions(+), 7 deletions(-) diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs index 19e77d2d4..94fef2d3e 100644 --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -1201,13 +1201,20 @@ matchR e v p = \x -> if p x then v x else e 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. +-- | The /context/ of a subgraph comprises the input and output vertices that +-- are connected to the vertices inside the subgraph. data Context a = Context { inputs :: [a], outputs :: [a] } - deriving Show + deriving (Eq, Show) -- | Extract the context of a subgraph specified by a given predicate. Returns -- @Nothing@ if the specified subgraph is empty. +-- +-- @ +-- context ('const' False) x == Nothing +-- context (== 1) ('edge' 1 2) == Just ('Context' [] [2] ) +-- context (== 2) ('edge' 1 2) == Just ('Context' [1] [] ) +-- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [3,1] [1,5]) +-- @ context :: (a -> Bool) -> Graph a -> Maybe (Context a) context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) | otherwise = Nothing diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index acbdfdfae..2a98b1348 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -608,14 +608,21 @@ connectFoci e x y focus :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Focus e a focus f = foldg emptyFocus (vertexFocus f) connectFoci --- | The /context/ of a subgraph comprises the input and output vertices outside --- the subgraph that are connected to the vertices inside the subgraph (along --- with the corresponding edge labels). +-- | The /context/ of a subgraph comprises the input and output vertices that +-- are connected to the vertices inside the subgraph (along with the +-- corresponding edge labels). data Context e a = Context { inputs :: [(e, a)], outputs :: [(e, a)] } - deriving Show + deriving (Eq, Show) -- | Extract the context of a subgraph specified by a given predicate. Returns -- @Nothing@ if the specified subgraph is empty. +-- +-- @ +-- context ('const' False) x == Nothing +-- context (== 1) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [] [(e,2)]) +-- context (== 2) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [] ) +-- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [('one',3), ('one',1)] [('one',1), ('one',5)]) +-- @ context :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Maybe (Context e a) context p g | ok f = Just $ Context (Exts.toList $ is f) (Exts.toList $ os f) | otherwise = Nothing diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs index ee34b0ad9..c3bce980b 100644 --- a/test/Algebra/Graph/Test/Labelled/Graph.hs +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -447,3 +447,16 @@ testLabelledGraph = do test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.Graph.context ============" + test "context (const False) x == Nothing" $ \x -> + context (const False) (x :: LAS) == Nothing + + test "context (== 1) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [] [(e,2)])" $ \e -> + context (== 1) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [] [(e,2)]) + + test "context (== 2) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] )" $ \e -> + context (== 2) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] ) + + test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)])" $ + context (== 4) (3 * 1 * 4 * 1 * 5 :: LAD) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)]) From 02cd4b28417226b53118fe69768b3a90a77a42c7 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 20:36:01 +0000 Subject: [PATCH 14/17] Fix GHC 7.* --- src/Algebra/Graph/Labelled.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index 2a98b1348..b6a676283 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -47,6 +47,7 @@ import Prelude () import Prelude.Compat import Data.Monoid (Any (..)) +import Data.Semigroup ((<>)) import Algebra.Graph.Internal (List (..)) import Algebra.Graph.Label From 0aa03573c3bcb8e43618cd929ee2d0ba22611a8a Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 20:59:11 +0000 Subject: [PATCH 15/17] Final touches --- src/Algebra/Graph.hs | 14 +++++++++----- src/Algebra/Graph/Labelled.hs | 15 +++++++++------ test/Algebra/Graph/Test/Graph.hs | 16 ++++++++++++++++ test/Algebra/Graph/Test/Labelled/Graph.hs | 3 +++ 4 files changed, 37 insertions(+), 11 deletions(-) diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs index 94fef2d3e..f626a3fa2 100644 --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -1201,18 +1201,22 @@ matchR e v p = \x -> if p x then v x else e 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 that --- are connected to the vertices inside the subgraph. +-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all +-- the vertices that are connected to the subgraph's vertices. Note that inputs +-- and outputs can belong to the subgraph itself. In general, there are no +-- guarantees on the order of vertices in 'inputs' and 'outputs'; furthermore, +-- there may be repetitions. data Context a = Context { inputs :: [a], outputs :: [a] } deriving (Eq, Show) --- | Extract the context of a subgraph specified by a given predicate. Returns +-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns -- @Nothing@ if the specified subgraph is empty. -- -- @ -- context ('const' False) x == Nothing --- context (== 1) ('edge' 1 2) == Just ('Context' [] [2] ) --- context (== 2) ('edge' 1 2) == Just ('Context' [1] [] ) +-- context (== 1) ('edge' 1 2) == Just ('Context' [ ] [2 ]) +-- context (== 2) ('edge' 1 2) == Just ('Context' [1 ] [ ]) +-- context ('const' True ) ('edge' 1 2) == Just ('Context' [1 ] [2 ]) -- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [3,1] [1,5]) -- @ context :: (a -> Bool) -> Graph a -> Maybe (Context a) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs index b6a676283..0c96ecde9 100644 --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -609,19 +609,22 @@ connectFoci e x y focus :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Focus e a focus f = foldg emptyFocus (vertexFocus f) connectFoci --- | The /context/ of a subgraph comprises the input and output vertices that --- are connected to the vertices inside the subgraph (along with the --- corresponding edge labels). +-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all +-- the vertices that are connected to the subgraph's vertices (along with the +-- corresponding edge labels). Note that inputs and outputs can belong to the +-- subgraph itself. In general, there are no guarantees on the order of vertices +-- in 'inputs' and 'outputs'; furthermore, there may be repetitions. data Context e a = Context { inputs :: [(e, a)], outputs :: [(e, a)] } deriving (Eq, Show) --- | Extract the context of a subgraph specified by a given predicate. Returns +-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns -- @Nothing@ if the specified subgraph is empty. -- -- @ -- context ('const' False) x == Nothing --- context (== 1) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [] [(e,2)]) --- context (== 2) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [] ) +-- context (== 1) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [ ] [(e,2)]) +-- context (== 2) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [ ]) +-- context ('const' True ) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [(e,2)]) -- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [('one',3), ('one',1)] [('one',1), ('one',5)]) -- @ context :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Maybe (Context e a) diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs index a8861cd21..94b354e33 100644 --- a/test/Algebra/Graph/Test/Graph.hs +++ b/test/Algebra/Graph/Test/Graph.hs @@ -172,3 +172,19 @@ testGraph = do test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> size (sparsify x) <= 3 * size x + + putStrLn "\n============ Labelled.Graph.context ============" + test "context (const False) x == Nothing" $ \x -> + context (const False) (x :: G) == Nothing + + test "context (== 1) (edge 1 2) == Just (Context [ ] [2 ])" $ + context (== 1) (edge 1 2 :: G) == Just (Context [ ] [2 ]) + + test "context (== 2) (edge 1 2) == Just (Context [1 ] [ ])" $ + context (== 2) (edge 1 2 :: G) == Just (Context [1 ] [ ]) + + test "context (const True ) (edge 1 2) == Just (Context [1 ] [2 ])" $ + context (const True ) (edge 1 2 :: G) == Just (Context [1 ] [2 ]) + + test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [3,1] [1,5])" $ + context (== 4) (3 * 1 * 4 * 1 * 5 :: G) == Just (Context [3,1] [1,5]) diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs index c3bce980b..393b476fc 100644 --- a/test/Algebra/Graph/Test/Labelled/Graph.hs +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -458,5 +458,8 @@ testLabelledGraph = do test "context (== 2) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] )" $ \e -> context (== 2) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] ) + test "context (const True ) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [(e,2)])" $ \e -> + context (const True ) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [(e,2)]) + test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)])" $ context (== 4) (3 * 1 * 4 * 1 * 5 :: LAD) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)]) From 0723b3a5bb464e239e9e708709edce2713b1f3a0 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 21:01:25 +0000 Subject: [PATCH 16/17] Update change log --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index a9cf07e60..2ae402410 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -19,7 +19,7 @@ remove `Algebra.Graph.adjacencyMap` and `Algebra.Graph.adjacencyIntMap`. This functionality is still available from the type class `ToGraph`. * #126, #131: Implement custom `Ord` instance. -* #122, #125: Further work on labelled algebraic graphs. +* #17, #122, #125, #149: Add labelled algebraic graphs. * #121: Drop `Foldable` and `Traversable` instances. * #113: Add `Labelled.AdjacencyMap`. From d83452fa91f248207e79a38ed6f14891138914ab Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 29 Nov 2018 23:08:12 +0000 Subject: [PATCH 17/17] Fix Ord instance --- .../Graph/Labelled/AdjacencyMap/Internal.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs index 4ba94555b..24d8495f1 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs @@ -66,19 +66,26 @@ instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where , compare (vSet x) (vSet y) , compare (eNum x) (eNum y) , compare (eSet x) (eSet y) - , compare x y ] + , cmp ] where vNum = Map.size vSet = Map.keysSet eNum = getSum . foldMap (Sum . Map.size) eSet m = [ (x, y) | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ] + cmp | x == y = EQ + | overlays [x, y] == y = LT + | otherwise = compare x y + +-- Overlay a list of adjacency maps. +overlays :: (Eq e, Monoid e, Ord a) => [Map a (Map a e)] -> Map a (Map a e) +overlays = Map.unionsWith (\x -> Map.filter (/= zero) . Map.unionWith mappend x) -- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' -- for more details. -instance (Ord a, Num a, Dioid e) => Num (AdjacencyMap e a) where +instance (Eq e, Dioid e, Num a, Ord a) => Num (AdjacencyMap e a) where fromInteger x = AM $ Map.singleton (fromInteger x) Map.empty - AM x + AM y = AM $ Map.unionWith (Map.unionWith (<+>)) x y - AM x * AM y = AM $ Map.unionsWith (Map.unionWith (<+>)) $ x : y : + AM x + AM y = AM $ overlays [x, y] + AM x * AM y = AM $ overlays $ x : y : [ Map.fromSet (const targets) (Map.keysSet x) ] where targets = Map.fromSet (const one) (Map.keysSet y)