algebraic-graphs 0.2 → 0.3

raw patch · 47 files changed

+7626/−2450 lines, 47 filesdep +inspection-testingdep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: inspection-testing

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• CHANGES.md +23/−0
• README.md +17/−0
• algebraic-graphs.cabal +47/−18
• src/Algebra/Graph.hs +348/−169
• src/Algebra/Graph/AdjacencyIntMap.hs +183/−179
• src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs +198/−0
• src/Algebra/Graph/AdjacencyIntMap/Internal.hs +73/−101
• src/Algebra/Graph/AdjacencyMap.hs +189/−220
• src/Algebra/Graph/AdjacencyMap/Algorithm.hs +235/−0
• src/Algebra/Graph/AdjacencyMap/Internal.hs +84/−111
• src/Algebra/Graph/Class.hs +26/−23
• src/Algebra/Graph/Export.hs +41/−14
• src/Algebra/Graph/Export/Dot.hs +10/−10
• src/Algebra/Graph/Fold.hs +74/−61
• src/Algebra/Graph/HigherKinded/Class.hs +44/−134
• src/Algebra/Graph/Internal.hs +36/−10
• src/Algebra/Graph/Label.hs +414/−66
• src/Algebra/Graph/Labelled.hs +569/−57
• src/Algebra/Graph/Labelled/AdjacencyMap.hs +612/−0
• src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +113/−0
• src/Algebra/Graph/Labelled/Example/Automaton.hs +84/−0
• src/Algebra/Graph/Labelled/Example/Network.hs +64/−0
• src/Algebra/Graph/NonEmpty.hs +274/−232
• src/Algebra/Graph/NonEmpty/AdjacencyMap.hs +568/−0
• src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs +163/−0
• src/Algebra/Graph/Relation.hs +74/−67
• src/Algebra/Graph/Relation/Internal.hs +62/−17
• src/Algebra/Graph/Relation/InternalDerived.hs +3/−3
• src/Algebra/Graph/Relation/Preorder.hs +1/−1
• src/Algebra/Graph/ToGraph.hs +123/−20
• src/Data/Graph/Typed.hs +2/−2
• test/Algebra/Graph/Test.hs +2/−6
• test/Algebra/Graph/Test/API.hs +119/−79
• test/Algebra/Graph/Test/AdjacencyIntMap.hs +1/−0
• test/Algebra/Graph/Test/AdjacencyMap.hs +25/−12
• test/Algebra/Graph/Test/Arbitrary.hs +89/−31
• test/Algebra/Graph/Test/Export.hs +21/−9
• test/Algebra/Graph/Test/Generic.hs +234/−63
• test/Algebra/Graph/Test/Graph.hs +23/−0
• test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +475/−0
• test/Algebra/Graph/Test/Labelled/Graph.hs +465/−0
• test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs +613/−0
• test/Algebra/Graph/Test/NonEmpty/Graph.hs +690/−0
• test/Algebra/Graph/Test/NonEmptyGraph.hs +0/−665
• test/Algebra/Graph/Test/Relation.hs +8/−67
• test/Algebra/Graph/Test/RewriteRules.hs +98/−0
• test/Main.hs +9/−3

@@ -1,5 +1,28 @@ # Change log
 
+## 0.3
+
+* #129: Add a testsuite for rewrite rules based on the `inspection-testing` library.
+* #63, #148: Add relational composition of algebraic graphs.
+* #139, #146: Add relational operations to adjacency maps.
+* #146: Rename `preorderClosure` to `closure`.
+* #146: Switch to left-to-right composition in `Relation.compose`.
+* #143: Allow newer QuickCheck.
+* #140, #142: Fix `Show` instances.
+* #128, #130: Modify the SCC algorithm to return non-empty graph components.
+* #130: Move adjacency map algorithms to separate modules.
+* #130: Export `fromAdjacencySets` and `fromAdjacencyIntSets`.
+* #138: Do not require `Eq` instance on the string type when exporting graphs.
+* #136: Rename `Algebra.Graph.NonEmpty.NonEmptyGraph` to `Algebra.Graph.NonEmpty.Graph`.
+* #136: Add `Algebra.Graph.NonEmpty.AdjacencyMap`.
+* #136: Remove `vertexIntSet` from the API of basic graph data types. Also
+        remove `Algebra.Graph.adjacencyMap` and `Algebra.Graph.adjacencyIntMap`.
+        This functionality is still available from the type class `ToGraph`.
+* #126, #131: Implement custom `Ord` instance.
+* #17, #122, #125, #149: Add labelled algebraic graphs.
+* #121: Drop `Foldable` and `Traversable` instances.
+* #113: Add `Labelled.AdjacencyMap`.
+
 ## 0.2
 
 * #117: Add `sparsify`.

@@ -54,6 +54,18 @@ To represent *non-empty graphs*, we can drop the `Empty` constructor -- see module [Algebra.Graph.NonEmpty](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty.html). +To represent *edge-labelled graphs*, we can switch to the following data type, as+explained in my [Haskell eXchange 2018 talk](https://skillsmatter.com/skillscasts/12361-labelled-algebraic-graphs):++```haskell+data Graph e a = Empty+               | Vertex a+               | Connect e (Graph e a) (Graph e a)+```++Here `e` is the type of edge labels. If `e` is a monoid `(<+>, zero)` then graph overlay can be recovered+as `Connect zero`, and `<+>` corresponds to *parallel composition* of edge labels.+ ## How fast is the library?  Alga can handle graphs comprising millions of vertices and billions of edges in a matter of seconds, which is fast@@ -69,3 +81,8 @@ * A few different flavours of the algebra: https://blogs.ncl.ac.uk/andreymokhov/graphs-a-la-carte/ * Graphs in disguise or How to plan you holiday using Haskell: https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ * Old graphs from new types: https://blogs.ncl.ac.uk/andreymokhov/old-graphs-from-new-types/++## Algebraic graphs in other languages++See draft implementations in [Agda](http://github.com/algebraic-graphs/agda)+and [Scala](http://github.com/algebraic-graphs/scala).

@@ -1,5 +1,5 @@ name:          algebraic-graphs-version:       0.2+version:       0.3 synopsis:      A library for algebraic graph construction and transformation license:       MIT license-file:  LICENSE@@ -25,24 +25,34 @@     .     The top-level module     <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph.html Algebra.Graph>-    defines the core data type+    defines the main data type for /algebraic graphs/     <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph.html#t:Graph Graph>,-    which is a deep embedding of four graph construction primitives /empty/,-    /vertex/, /overlay/ and /connect/. To represent non-empty graphs, see+    as well as associated algorithms. For type-safe representation and+    manipulation of /non-empty algebraic graphs/, see     <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty.html Algebra.Graph.NonEmpty>.-    More conventional graph representations can be found in+    Furthermore, /algebraic graphs with edge labels/ are implemented in+    <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Labelled.html Algebra.Graph.Labelled>.+    .+    The library also provides conventional graph data structures, such as     <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-AdjacencyMap.html Algebra.Graph.AdjacencyMap>-    and-    <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Relation.html Algebra.Graph.Relation>.+    along with its various flavours: adjacency maps specialised to graphs with+    vertices of type 'Int'+    (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-AdjacencyIntMap.html Algebra.Graph.AdjacencyIntMap>),+    non-empty adjacency maps+    (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty-AdjacencyMap.html Algebra.Graph.NonEmpty.AdjacencyMap>),+    and adjacency maps with edge labels+    (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Labelled-AdjacencyMap.html Algebra.Graph.Labelled.AdjacencyMap>).+    A large part of the API of algebraic graphs and adjacency maps is available+    through the 'Foldable'-like type class+    <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-ToGraph.html Algebra.Graph.ToGraph>.     .     The type classes defined in     <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Class.html Algebra.Graph.Class>     and     <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-HigherKinded-Class.html Algebra.Graph.HigherKinded.Class>-    can be used for polymorphic graph construction and manipulation. Also see+    can be used for polymorphic construction and manipulation of graphs. Also see     <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Fold.html Algebra.Graph.Fold>-    that defines the Boehm-Berarducci encoding of algebraic graphs and provides additional-    flexibility for polymorphic graph manipulation.+    that defines the Boehm-Berarducci encoding of algebraic graphs.     .     This is an experimental library and the API is expected to remain unstable until version 1.0.0.     Please consider contributing to the on-going@@ -59,19 +69,27 @@ library     hs-source-dirs:     src     exposed-modules:    Algebra.Graph,+                        Algebra.Graph.AdjacencyIntMap,+                        Algebra.Graph.AdjacencyIntMap.Algorithm,+                        Algebra.Graph.AdjacencyIntMap.Internal,                         Algebra.Graph.AdjacencyMap,+                        Algebra.Graph.AdjacencyMap.Algorithm,                         Algebra.Graph.AdjacencyMap.Internal,                         Algebra.Graph.Class,                         Algebra.Graph.Export,                         Algebra.Graph.Export.Dot,                         Algebra.Graph.Fold,                         Algebra.Graph.HigherKinded.Class,-                        Algebra.Graph.AdjacencyIntMap,-                        Algebra.Graph.AdjacencyIntMap.Internal,                         Algebra.Graph.Internal,                         Algebra.Graph.Label,                         Algebra.Graph.Labelled,+                        Algebra.Graph.Labelled.AdjacencyMap,+                        Algebra.Graph.Labelled.AdjacencyMap.Internal,+                        Algebra.Graph.Labelled.Example.Automaton,+                        Algebra.Graph.Labelled.Example.Network,                         Algebra.Graph.NonEmpty,+                        Algebra.Graph.NonEmpty.AdjacencyMap,+                        Algebra.Graph.NonEmpty.AdjacencyMap.Internal,                         Algebra.Graph.Relation,                         Algebra.Graph.Relation.Internal,                         Algebra.Graph.Relation.InternalDerived,@@ -91,18 +109,18 @@         build-depends:  semigroups  >= 0.18.3  && < 0.18.4     default-language:   Haskell2010     default-extensions: FlexibleContexts+                        FlexibleInstances                         GeneralizedNewtypeDeriving                         ScopedTypeVariables                         TupleSections                         TypeFamilies     other-extensions:   CPP-                        DeriveFoldable                         DeriveFunctor-                        DeriveTraversable                         OverloadedStrings                         RecordWildCards     GHC-options:        -Wall                         -fno-warn-name-shadowing+                        -fspec-constr     if impl(ghc >= 8.0)         GHC-options:    -Wcompat                         -Wincomplete-record-updates@@ -115,17 +133,22 @@     main-is:            Main.hs     other-modules:      Algebra.Graph.Test,                         Algebra.Graph.Test.API,+                        Algebra.Graph.Test.AdjacencyIntMap,                         Algebra.Graph.Test.AdjacencyMap,                         Algebra.Graph.Test.Arbitrary,                         Algebra.Graph.Test.Export,                         Algebra.Graph.Test.Fold,                         Algebra.Graph.Test.Generic,                         Algebra.Graph.Test.Graph,-                        Algebra.Graph.Test.AdjacencyIntMap,                         Algebra.Graph.Test.Internal,-                        Algebra.Graph.Test.NonEmptyGraph,+                        Algebra.Graph.Test.Labelled.AdjacencyMap,+                        Algebra.Graph.Test.Labelled.Graph,+                        Algebra.Graph.Test.NonEmpty.AdjacencyMap,+                        Algebra.Graph.Test.NonEmpty.Graph,                         Algebra.Graph.Test.Relation,                         Data.Graph.Test.Typed+    if impl(ghc >= 8.0.2)+        other-modules:  Algebra.Graph.Test.RewriteRules     build-depends:      algebraic-graphs,                         array        >= 0.4     && < 0.6,                         base         >= 4.7     && < 5,@@ -133,21 +156,27 @@                         base-orphans >= 0.5.4   && < 0.9,                         containers   >= 0.5.5.1 && < 0.8,                         extra        >= 1.5     && < 2,-                        QuickCheck   >= 2.9     && < 2.12+                        QuickCheck   >= 2.9     && < 2.13     if !impl(ghc >= 8.0)         build-depends:  semigroups   >= 0.18.3  && < 0.18.4+    if impl(ghc >= 8.0.2)+        build-depends:  inspection-testing >= 0.4 && < 0.5+     default-language:   Haskell2010     GHC-options:        -Wall                         -fno-warn-name-shadowing+                        -fspec-constr     if impl(ghc >= 8.0)         GHC-options:    -Wcompat                         -Wincomplete-record-updates                         -Wincomplete-uni-patterns                         -Wredundant-constraints     default-extensions: FlexibleContexts+                        FlexibleInstances                         GeneralizedNewtypeDeriving-                        TypeFamilies                         ScopedTypeVariables+                        TupleSections+                        TypeFamilies     other-extensions:   ConstrainedClassMethods                         ConstraintKinds                         RankNTypes

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph@@ -33,8 +33,7 @@      -- * Graph properties     isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList,-    edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList, adjacencyMap,-    adjacencyIntMap,+    edgeList, vertexSet, edgeSet, adjacencyList,      -- * Standard families of graphs     path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus,@@ -45,14 +44,14 @@     transpose, induce, simplify, sparsify,      -- * Graph composition-    box,+    compose, box,      -- * Context     Context (..), context-  ) where+    ) where  import Prelude ()-import Prelude.Compat+import Prelude.Compat hiding ((<>))  import Control.Applicative (Alternative) import Control.DeepSeq (NFData (..))@@ -60,15 +59,11 @@ import Control.Monad.State (runState, get, put) import Data.Foldable (toList) import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import Data.Tree  import Algebra.Graph.Internal -import Data.IntMap (IntMap)-import Data.IntSet (IntSet)-import Data.Map    (Map)-import Data.Set    (Set)- import qualified Algebra.Graph.AdjacencyMap    as AM import qualified Algebra.Graph.AdjacencyIntMap as AIM import qualified Control.Applicative           as Ap@@ -86,6 +81,14 @@     > 1 + 2 * 3   == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3))     > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num',+which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as+additive and multiplicative identities, and 'negate' as additive inverse.+Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when+working with algebraic graphs; we hope that in future Haskell's Prelude will+provide a more fine-grained class hierarchy for algebraic structures, which we+would be able to utilise without violating any laws.+ The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the /canonical graph representation/ and satisfies all axioms of algebraic graphs: @@ -132,37 +135,96 @@ m == 'edgeCount' g s == 'size' g@ -Note that 'size' is slightly different from the 'length' method of the-'Foldable' type class, as the latter does not count 'empty' leaves of the-expression:--@'length' 'empty'           == 0-'size'   'empty'           == 1-'length' ('vertex' x)      == 1-'size'   ('vertex' x)      == 1-'length' ('empty' + 'empty') == 0-'size'   ('empty' + 'empty') == 2@+Note that 'size' counts all leaves of the expression: -The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@-corresponds to the number of occurrences of 'empty' in an expression @g@.+@'vertexCount' 'empty'           == 0+'size'        'empty'           == 1+'vertexCount' ('vertex' x)      == 1+'size'        ('vertex' x)      == 1+'vertexCount' ('empty' + 'empty') == 0+'size'        ('empty' + 'empty') == 2@  Converting a 'Graph' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/-time and /O(s + m)/ memory. This is also the complexity of the graph equality test,-because it is currently implemented by converting graph expressions to canonical-representations based on adjacency maps.+time and /O(s + m)/ memory. This is also the complexity of the graph equality+test, because it is currently implemented by converting graph expressions to+canonical representations based on adjacency maps.++The total order on graphs is defined using /size-lexicographic/ comparison:++* Compare the number of vertices. In case of a tie, continue.+* Compare the sets of vertices. In case of a tie, continue.+* Compare the number of edges. In case of a tie, continue.+* Compare the sets of edges.++Here are a few examples:++@'vertex' 1 < 'vertex' 2+'vertex' 3 < 'edge' 1 2+'vertex' 1 < 'edge' 1 1+'edge' 1 1 < 'edge' 1 2+'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2+'edge' 1 2 < 'edge' 1 3@++Note that the resulting order refines the 'isSubgraphOf' relation and is+compatible with 'overlay' and 'connect' operations:++@'isSubgraphOf' x y ==> x <= y@++@'empty' <= x+x     <= x + y+x + y <= x * y@ -} data Graph a = Empty              | Vertex a              | Overlay (Graph a) (Graph a)              | Connect (Graph a) (Graph a)-             deriving (Foldable, Functor, Show, Traversable)+             deriving (Show) +{- Note [Functions for rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This module contains several functions whose only purpose is to guide GHC+rewrite rules. The names of all such functions are suffixed with "R" so that it+is easier to distinguish them from others.++Why do we need them?++These functions are annotated with carefully chosen GHC pragmas that control+inlining, which would be impossible or unreliable if we used standard functions+instead. For example, the function 'eqR' has the following annotations:++    NOINLINE [1] eqR+    RULES "eqIntR" eqR = eqIntR++This tells GHC to rewrite 'eqR' to faster 'eqIntR' if possible (if the types+match), and -- importantly -- not to inline 'eqR' too early, before the rewrite+rule had a chance to fire.++We could have written the following rule instead:++    RULES "eqIntR" (==) = eqIntR++But that would have to rely on appropriate inlining behaviour of (==) which is+not under our control. We therefore choose the safe and more explicit path of+creating our own intermediate functions for guiding rewrite rules when needed.+-}++instance Functor Graph where+    fmap = fmapR++-- This is a usual implementation of 'fmap', but with custom rewrite rules.+fmapR :: (a -> b) -> Graph a -> Graph b+fmapR f = foldg empty (vertex . f) overlay connect+{-# INLINE [0] fmapR #-}+ instance NFData a => NFData (Graph a) where     rnf Empty         = ()     rnf (Vertex  x  ) = rnf x     rnf (Overlay x y) = rnf x `seq` rnf y     rnf (Connect x y) = rnf x `seq` rnf y +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more+-- details. instance Num a => Num (Graph a) where     fromInteger = Vertex . fromInteger     (+)         = Overlay@@ -172,19 +234,33 @@     negate      = id  instance Ord a => Eq (Graph a) where-    (==) = equals+    (==) = eqR +instance Ord a => Ord (Graph a) where+    compare = ordR+ -- TODO: Find a more efficient equality check.--- | Compare two graphs by converting them to their adjacency maps.-{-# NOINLINE [1] equals #-}-{-# RULES "equalsInt" equals = equalsInt #-}-equals :: Ord a => Graph a -> Graph a -> Bool-equals x y = adjacencyMap x == adjacencyMap y+-- Check if two graphs are equal by converting them to their adjacency maps.+eqR :: Ord a => Graph a -> Graph a -> Bool+eqR x y = toAdjacencyMap x == toAdjacencyMap y+{-# NOINLINE [1] eqR #-}+{-# RULES "eqR/Int" eqR = eqIntR #-} --- | Like @equals@ but specialised for graphs with vertices of type 'Int'.-equalsInt :: Graph Int -> Graph Int -> Bool-equalsInt x y = adjacencyIntMap x == adjacencyIntMap y+-- Like 'eqR' but specialised for graphs with vertices of type 'Int'.+eqIntR :: Graph Int -> Graph Int -> Bool+eqIntR x y = toAdjacencyIntMap x == toAdjacencyIntMap y +-- TODO: Find a more efficient comparison.+-- Compare two graphs by converting them to their adjacency maps.+ordR :: Ord a => Graph a -> Graph a -> Ordering+ordR x y = compare (toAdjacencyMap x) (toAdjacencyMap y)+{-# NOINLINE [1] ordR #-}+{-# RULES "ordR/Int" ordR = ordIntR #-}++-- Like 'ordR' but specialised for graphs with vertices of type 'Int'.+ordIntR :: Graph Int -> Graph Int -> Ordering+ordIntR x y = compare (toAdjacencyIntMap x) (toAdjacencyIntMap y)+ instance Applicative Graph where     pure  = Vertex     (<*>) = ap@@ -299,7 +375,7 @@ -- @ vertices :: [a] -> Graph a vertices = overlays . map vertex-{-# NOINLINE [1] vertices #-}+{-# INLINE vertices #-}  -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the@@ -325,8 +401,8 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [Graph a] -> Graph a-overlays = concatg overlay-{-# INLINE [2] overlays #-}+overlays = fromMaybe empty . foldr1Safe overlay+{-# INLINE [1] overlays #-}  -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length@@ -340,12 +416,8 @@ -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: [Graph a] -> Graph a-connects = concatg connect-{-# INLINE [2] connects #-}---- | Auxiliary function, similar to 'mconcat'.-concatg :: (Graph a -> Graph a -> Graph a) -> [Graph a] -> Graph a-concatg combine = fromMaybe empty . foldr1Safe combine+connects = fromMaybe empty . foldr1Safe connect+{-# INLINE [1] connects #-}  -- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying -- the provided functions to the leaves and internal nodes of the expression.@@ -355,11 +427,10 @@ -- -- @ -- foldg 'empty' 'vertex'        'overlay' 'connect'        == id--- foldg 'empty' 'vertex'        'overlay' (flip 'connect') == 'transpose'--- foldg []    return        (++)    (++)           == 'Data.Foldable.toList'--- foldg 0     (const 1)     (+)     (+)            == 'Data.Foldable.length'--- foldg 1     (const 1)     (+)     (+)            == 'size'--- foldg True  (const False) (&&)    (&&)           == 'isEmpty'+-- foldg 'empty' 'vertex'        'overlay' ('flip' 'connect') == 'transpose'+-- foldg 1     ('const' 1)     (+)     (+)            == 'size'+-- foldg True  ('const' False) (&&)    (&&)           == 'isEmpty'+-- foldg False (== x)        (||)    (||)           == 'hasVertex' x -- @ foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b foldg e v o c = go@@ -368,22 +439,40 @@     go (Vertex  x  ) = v x     go (Overlay x y) = o (go x) (go y)     go (Connect x y) = c (go x) (go y)+{-# INLINE [0] foldg #-} +{-# RULES+"foldg/Empty"   forall e v o c.+    foldg e v o c Empty = e+"foldg/Vertex"  forall e v o c x.+    foldg e v o c (Vertex x) = v x+"foldg/Overlay" forall e v o c x y.+    foldg e v o c (Overlay x y) = o (foldg e v o c x) (foldg e v o c y)+"foldg/Connect" forall e v o c x y.+    foldg e v o c (Connect x y) = c (foldg e v o c x) (foldg e v o c y)++"foldg/overlays" forall e v o c xs.+    foldg e v o c (overlays xs) = fromMaybe e (foldr (maybeF o . foldg e v o c) Nothing xs)+"foldg/connects" forall e v o c xs.+    foldg e v o c (connects xs) = fromMaybe e (foldr (maybeF c . foldg e v o c) Nothing xs)+ #-}+ -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a -- graph can be quadratic with respect to the expression size /s/. -- -- @--- isSubgraphOf 'empty'         x             == True--- isSubgraphOf ('vertex' x)    'empty'         == False--- isSubgraphOf x             ('overlay' x y) == True--- isSubgraphOf ('overlay' x y) ('connect' x y) == True--- isSubgraphOf ('path' xs)     ('circuit' xs)  == True+-- isSubgraphOf 'empty'         x             ==  True+-- isSubgraphOf ('vertex' x)    'empty'         ==  False+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf ('path' xs)     ('circuit' xs)  ==  True+-- isSubgraphOf x y                         ==> x <= y -- @-{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool isSubgraphOf x y = overlay x y == y+{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-}  -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time.@@ -395,13 +484,13 @@ -- 1 + 2 === 2 + 1     == False -- x + y === x * y     == False -- @-{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} (===) :: Eq a => Graph a -> Graph a -> Bool Empty           === Empty           = True (Vertex  x1   ) === (Vertex  x2   ) = x1 ==  x2 (Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2 (Connect x1 y1) === (Connect x2 y2) = x1 === x2 && y1 === y2 _               === _               = False+{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-}  infix 4 === @@ -433,18 +522,18 @@ size :: Graph a -> Int size = foldg 1 (const 1) (+) (+) --- | Check if a graph contains a given vertex. A convenient alias for `elem`.+-- | 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 x . 'removeVertex' x == 'const' False -- @-{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} hasVertex :: Eq a => a -> Graph a -> Bool hasVertex x = foldg False (==x) (||) (||)+{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-}  -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time.@@ -453,10 +542,9 @@ -- hasEdge x y 'empty'            == False -- hasEdge x y ('vertex' z)       == False -- hasEdge x y ('edge' x y)       == True--- hasEdge x y . 'removeEdge' x y == const False+-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @-{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} hasEdge :: Eq a => a -> a -> Graph a -> Bool hasEdge s t g = hit g == Edge   where@@ -470,23 +558,25 @@         Miss -> hit y         Tail -> if hasVertex t y then Edge else Tail         Edge -> Edge+{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-}  -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. -- -- @--- vertexCount 'empty'      == 0--- vertexCount ('vertex' x) == 1--- vertexCount            == 'length' . 'vertexList'+-- vertexCount 'empty'             ==  0+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y -- @-{-# INLINE [1] vertexCount #-}-{-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} vertexCount :: Ord a => Graph a -> Int vertexCount = Set.size . vertexSet+{-# INLINE [1] vertexCount #-}+{-# RULES "vertexCount/Int" vertexCount = vertexIntCountR #-} --- | Like 'vertexCount' but specialised for graphs with vertices of type 'Int'.-vertexIntCount :: Graph Int -> Int-vertexIntCount = IntSet.size . vertexIntSet+-- Like 'vertexCount' but specialised for graphs with vertices of type 'Int'.+vertexIntCountR :: Graph Int -> Int+vertexIntCountR = IntSet.size . vertexIntSetR  -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a@@ -498,14 +588,14 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount            == 'length' . 'edgeList' -- @-{-# INLINE [1] edgeCount #-}-{-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-} edgeCount :: Ord a => Graph a -> Int edgeCount = AM.edgeCount . toAdjacencyMap+{-# INLINE [1] edgeCount #-}+{-# RULES "edgeCount/Int" edgeCount = edgeCountIntR #-} --- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'.-edgeCountInt :: Graph Int -> Int-edgeCountInt = AIM.edgeCount . toAdjacencyIntMap+-- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'.+edgeCountIntR :: Graph Int -> Int+edgeCountIntR = AIM.edgeCount . toAdjacencyIntMap  -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory.@@ -515,14 +605,14 @@ -- vertexList ('vertex' x) == [x] -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @-{-# INLINE [1] vertexList #-}-{-# RULES "vertexList/Int" vertexList = vertexIntList #-} vertexList :: Ord a => Graph a -> [a] vertexList = Set.toAscList . vertexSet+{-# INLINE [1] vertexList #-}+{-# RULES "vertexList/Int" vertexList = vertexIntListR #-} --- | Like 'vertexList' but specialised for graphs with vertices of type 'Int'.-vertexIntList :: Graph Int -> [Int]-vertexIntList = IntSet.toList . vertexIntSet+-- Like 'vertexList' but specialised for graphs with vertices of type 'Int'.+vertexIntListR :: Graph Int -> [Int]+vertexIntListR = IntSet.toList . vertexIntSetR  -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of@@ -534,16 +624,16 @@ -- edgeList ('edge' x y)     == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges'        == 'Data.List.nub' . 'Data.List.sort'--- edgeList . 'transpose'    == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList+-- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @-{-# INLINE [1] edgeList #-}-{-# RULES "edgeList/Int" edgeList = edgeIntList #-} edgeList :: Ord a => Graph a -> [(a, a)] edgeList = AM.edgeList . toAdjacencyMap+{-# INLINE [1] edgeList #-}+{-# RULES "edgeList/Int" edgeList = edgeIntListR #-} --- | Like 'edgeList' but specialised for graphs with vertices of type 'Int'.-edgeIntList :: Graph Int -> [(Int, Int)]-edgeIntList = AIM.edgeList . toAdjacencyIntMap+-- Like 'edgeList' but specialised for graphs with vertices of type 'Int'.+edgeIntListR :: Graph Int -> [(Int, Int)]+edgeIntListR = AIM.edgeList . toAdjacencyIntMap  -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory.@@ -552,23 +642,13 @@ -- 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 --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for--- graphs with vertices of type 'Int'.--- Complexity: /O(s * log(n))/ time and /O(n)/ memory.------ @--- vertexIntSet 'empty'      == IntSet.'IntSet.empty'--- vertexIntSet . 'vertex'   == IntSet.'IntSet.singleton'--- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'--- vertexIntSet . 'clique'   == IntSet.'IntSet.fromList'--- @-vertexIntSet :: Graph Int -> IntSet.IntSet-vertexIntSet = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union+-- Like 'vertexSet' but specialised for graphs with vertices of type 'Int'.+vertexIntSetR :: Graph Int -> IntSet.IntSet+vertexIntSetR = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union  -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory.@@ -582,11 +662,11 @@ edgeSet :: Ord a => Graph a -> Set.Set (a, a) edgeSet = AM.edgeSet . toAdjacencyMap {-# INLINE [1] edgeSet #-}-{-# RULES "edgeSet/Int" edgeSet = edgeIntSet #-}+{-# RULES "edgeSet/Int" edgeSet = edgeIntSetR #-} --- | Like 'edgeSet' but specialised for graphs with vertices of type 'Int'.-edgeIntSet :: Graph Int -> Set.Set (Int,Int)-edgeIntSet = AIM.edgeSet . toAdjacencyIntMap+-- Like 'edgeSet' but specialised for graphs with vertices of type 'Int'.+edgeIntSetR :: Graph Int -> Set.Set (Int,Int)+edgeIntSetR = AIM.edgeSet . toAdjacencyIntMap  -- | The sorted /adjacency list/ of a graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory.@@ -598,29 +678,18 @@ -- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] -- 'stars' . adjacencyList        == id -- @-{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} adjacencyList :: Ord a => Graph a -> [(a, [a])] adjacencyList = AM.adjacencyList . toAdjacencyMap---- | The /adjacency map/ of a graph: each vertex is associated with a set of its--- direct successors.--- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a--- graph can be quadratic with respect to the expression size /s/.-adjacencyMap :: Ord a => Graph a -> Map a (Set a)-adjacencyMap = AM.adjacencyMap . toAdjacencyMap+{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-}  -- 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 'adjacencyMap' but specialised for graphs with vertices of type 'Int'.-adjacencyIntMap :: Graph Int -> IntMap IntSet-adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap---- | Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'.+-- 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 @@ -667,7 +736,7 @@ -- @ clique :: [a] -> Graph a clique = connects . map vertex-{-# NOINLINE [1] clique #-}+{-# INLINE [1] clique #-}  -- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the@@ -710,7 +779,7 @@ -- stars [(x, [])]               == 'vertex' x -- stars [(x, [y])]              == 'edge' x y -- stars [(x, ys)]               == 'star' x ys--- stars                         == 'overlays' . map (uncurry 'star')+-- stars                         == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList'         == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @@@ -741,7 +810,7 @@ -- forest []                                                  == 'empty' -- forest [x]                                                 == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)]--- forest                                                     == 'overlays' . map 'tree'+-- forest                                                     == 'overlays' . 'map' 'tree' -- @ forest :: Tree.Forest a -> Graph a forest = overlays . map tree@@ -825,9 +894,9 @@ -- removeVertex 1 ('edge' 1 2)       == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @-{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} removeVertex :: Eq a => a -> Graph a -> Graph a removeVertex v = induce (/= v)+{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-}  -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size.@@ -840,19 +909,18 @@ -- removeEdge 1 2 (1 * 1 * 2 * 2)  == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z)         <= 3 * 'size' z -- @-{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} removeEdge :: Eq a => a -> a -> Graph a -> Graph a removeEdge s t = filterContext s (/=s) (/=t)-+{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-}  -- TODO: Export--- | Filter vertices in a subgraph context.-{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-}+-- 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 -- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged.@@ -863,20 +931,19 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y            == 'mergeVertices' (== x) y -- @-{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex u v = fmap $ \w -> if w == u then v else w-+{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-}  -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes -- /O(1)/ to be evaluated. -- -- @--- mergeVertices (const False) x    == id+-- mergeVertices ('const' False) x    == id -- mergeVertices (== x) y           == 'replaceVertex' x y--- mergeVertices even 1 (0 * 2)     == 1 * 1--- mergeVertices odd  1 (3 + 4 * 5) == 4 * 1+-- mergeVertices 'even' 1 (0 * 2)     == 1 * 1+-- mergeVertices 'odd'  1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a mergeVertices p v = fmap $ \w -> if p w then v else w@@ -892,9 +959,9 @@ -- splitVertex x [y]                 == 'replaceVertex' x y -- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @-{-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-} splitVertex :: Eq a => a -> [a] -> Graph a -> Graph a splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w+{-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-}  -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size.@@ -905,24 +972,11 @@ -- transpose ('edge' x y)  == 'edge' y x -- transpose . transpose == id -- transpose ('box' x y)   == 'box' (transpose x) (transpose y)--- 'edgeList' . transpose  == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList'+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Graph a -> Graph a transpose = foldg Empty Vertex Overlay (flip Connect)-{-# NOINLINE [1] transpose #-}--{-# RULES-"transpose/Empty"    transpose Empty = Empty-"transpose/Vertex"   forall x. transpose (Vertex x) = Vertex x-"transpose/Overlay"  forall g1 g2. transpose (Overlay g1 g2) = Overlay (transpose g1) (transpose g2)-"transpose/Connect"  forall g1 g2. transpose (Connect g1 g2) = Connect (transpose g2) (transpose g1)--"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs)-"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs))--"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs-"transpose/clique"   forall xs. transpose (clique xs)   = clique (reverse xs)- #-}+{-# INLINE transpose #-}  -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate.@@ -930,8 +984,8 @@ -- /O(1)/ to be evaluated. -- -- @--- induce (const True ) x      == x--- induce (const False) x      == 'empty'+-- 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@@ -942,6 +996,7 @@     k _ x     Empty = x -- Constant folding to get rid of Empty leaves     k _ Empty y     = y     k f x     y     = f x y+{-# INLINE [1] induce #-}  -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra.@@ -959,11 +1014,10 @@ -- simplify (1 + 2 + 1) '===' 1 + 2 -- simplify (1 * 1 * 1) '===' 1 * 1 -- @-{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} simplify :: Ord a => Graph a -> Graph a simplify = foldg Empty Vertex (simple Overlay) (simple Connect)+{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} -{-# SPECIALISE simple :: (Int -> Int -> Int) -> Int -> Int -> Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y     | x == z    = x@@ -971,7 +1025,44 @@     | otherwise = z   where     z = op x y+{-# SPECIALISE simple :: (Int -> Int -> Int) -> Int -> Int -> Int #-} +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are+-- connected in the resulting graph if there is a vertex @y@, such that @x@ is+-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the+-- second graph. There are no isolated vertices in the result. This operation is+-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/,+-- and distributes over 'overlay'.+-- Complexity: /O(n * m * log(n))/ time, /O(n + m)/ memory, and /O(m1 + m2)/+-- size, where /n/ and /m/ stand for the number of vertices and edges in the+-- resulting graph, while /m1/ and /m2/ are the number of edges in the original+-- graphs. Note that the number of edges in the resulting graph may be+-- quadratic, i.e. /m = O(m1 * m2)/, but the algebraic representation requires+-- only /O(m1 + m2)/ operations to list them.+--+-- @+-- compose 'empty'            x                == 'empty'+-- compose x                'empty'            == 'empty'+-- compose ('vertex' x)       y                == 'empty'+-- compose x                ('vertex' y)       == 'empty'+-- compose x                (compose y z)    == compose (compose x y) z+-- compose x                ('overlay' y z)    == 'overlay' (compose x y) (compose x z)+-- compose ('overlay' x y)    z                == 'overlay' (compose x z) (compose y z)+-- compose ('edge' x y)       ('edge' y z)       == 'edge' x z+-- compose ('path'    [1..5]) ('path'    [1..5]) == 'edges' [(1,3), (2,4), (3,5)]+-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4]+-- 'size' (compose x y)                        <= 'edgeCount' x + 'edgeCount' y + 1+-- @+compose :: Ord a => Graph a -> Graph a -> Graph a+compose x y = overlays+    [ biclique xs ys+    | v <- Set.toList (AM.vertexSet mx `Set.union` AM.vertexSet my)+    , let xs = Set.toList (AM.postSet v mx), not (null xs)+    , let ys = Set.toList (AM.postSet v my), not (null ys) ]+  where+    mx = toAdjacencyMap (transpose x)+    my = toAdjacencyMap y+ -- | Compute the /Cartesian product/ of graphs. -- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the -- sizes of the given graphs.@@ -1000,24 +1091,10 @@ box :: Graph a -> Graph b -> Graph (a, b) box x y = overlays $ xs ++ ys   where-    xs = map (\b -> fmap (,b) x) $ toList y-    ys = map (\a -> fmap (a,) y) $ toList x---- | 'Focus' on a specified subgraph.-focus :: (a -> Bool) -> Graph a -> Focus a-focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci---- | The context of a subgraph comprises the input and output vertices outside--- the subgraph that are connected to the vertices inside the subgraph.-data Context a = Context { inputs :: [a], outputs :: [a] }---- | Extract the context from a graph 'Focus'. Returns @Nothing@ if the focus--- could not be obtained.-context :: (a -> Bool) -> Graph a -> Maybe (Context a)-context p g | ok f      = Just $ Context (toList $ is f) (toList $ os f)-            | otherwise = Nothing-  where-    f = focus p g+    xs = map (\b -> fmap (,b) x) $ toList $ toListGr y+    ys = map (\a -> fmap (a,) y) $ toList $ toListGr x+    toListGr :: Graph a -> List a+    toListGr = foldg mempty pure (<>) (<>)  -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the -- original vertices (wrapping the latter in 'Right') such that the resulting@@ -1045,3 +1122,105 @@         m <- get         put (m + 1)         overlay <$> s `x` m <*> m `y` t++{- Note [The rules of foldg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The rules for foldg work very similarly to GHC's mapFB rules; see a note below+this line: http://hackage.haskell.org/package/base/docs/src/GHC.Base.html#mapFB.++* Up to (but not including) phase 1, we use the "buildR/f" rule to rewrite all+  saturated applications of f into its buildR/foldg form, hoping for fusion to+  happen (through the "foldg/buildR" rule).++  In phases 1 and 0, we switch off these rules, inline buildR, and switch on the+  "graph/f" rule, which rewrites "foldg/f" back into plain functions if needed.++  It's important that these two rules aren't both active at once (along with+  build's unfolding) else we'd get an infinite loop in the rules. Hence the+  activation control below.++* composeR and matchR are here to remember the original function after applying+  a "buildR/f" rule. These functions are higher-order functions and therefore+  benefit from inlining in the final phase.++* The "fmapR/fmapR" rule optimises compositions of multiple fmapR's.+-}++type Foldg a = forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b++buildR :: Foldg a -> Graph a+buildR g = g Empty Vertex Overlay Connect+{-# INLINE [1] buildR #-}++composeR :: (b -> c) -> (a -> b) -> a -> c+composeR = (.)+{-# INLINE [0] composeR #-}++matchR :: b -> (a -> b) -> (a -> Bool) -> a -> b+matchR e v p = \x -> if p x then v x else e+{-# INLINE [0] matchR #-}++-- These rules transform functions into their buildR equivalents.+{-# RULES+"buildR/fmapR" forall f g.+    fmapR f g = buildR (\e v o c -> foldg e (composeR v f) o c g)++"buildR/induce" [~1] forall p g.+    induce p g = buildR (\e v o c -> foldg e (matchR e v p) o c g)++"buildR/foldg(fc)" [~1] forall (f :: forall b. (b -> b -> b) -> (b -> b -> b)) g.+    foldg Empty Vertex Overlay (f Connect) g = buildR (\e v o c -> foldg e v o (f c) g)++"buildR/foldg(fo)" [~1] forall (f :: forall b. (b -> b -> b) -> (b -> b -> b)) g.+    foldg Empty Vertex (f Overlay) Connect g = buildR (\e v o c -> foldg e v (f o) c g)++"buildR/foldg(fo)(hc)" [~1] forall (f :: forall b. (b -> b -> b) -> (b -> b -> b)) (h :: forall b. (b -> b -> b) -> (b -> b -> b)) g.+    foldg Empty Vertex (f Overlay) (h Connect) g = buildR (\e v o c -> foldg e v (f o) (h c) g)+ #-}++-- Rewrite rules for fusion.+{-# RULES+-- Fuse a foldg followed by a buildR+"foldg/buildR" forall e v o c (g :: Foldg a).+    foldg e v o c (buildR g) = g e v o c++-- Fuse composeR's. This occurs when two adjacent 'fmapR' were rewritted into+-- their buildR form.+"fmapR/fmapR" forall c f g.+    composeR (composeR c f) g = composeR c (f.g)+ #-}++-- Eliminate remaining rewrite-only functions.+{-# RULES+"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 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+-- @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 ('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)+context p g | ok f      = Just $ Context (toList $ is f) (toList $ os f)+            | otherwise = Nothing+  where+    f = focus p g

@@ -10,11 +10,11 @@ -- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the -- motivation behind the library, the underlying theory, and implementation details. ----- This module defines the 'AdjacencyIntMap' data type, as well as associated--- operations and algorithms. 'AdjacencyIntMap' is an instance of the 'C.Graph'--- type class, which can be used for polymorphic graph construction--- and manipulation. See "Algebra.Graph.AdjacencyMap" for graphs with--- non-@Int@ vertices.+-- This module defines the 'AdjacencyIntMap' data type and associated functions.+-- See "Algebra.Graph.AdjacencyIntMap.Algorithm" for implementations of basic+-- graph algorithms. 'AdjacencyIntMap' is an instance of the 'C.Graph' type+-- class, which can be used for polymorphic graph construction and manipulation.+-- See "Algebra.Graph.AdjacencyMap" for graphs with non-@Int@ vertices. ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyIntMap (     -- * Data structure@@ -31,34 +31,55 @@     adjacencyList, vertexIntSet, edgeSet, preIntSet, postIntSet,      -- * Standard families of graphs-    path, circuit, clique, biclique, star, stars, tree, forest,+    path, circuit, clique, biclique, star, stars, fromAdjacencyIntSets, tree,+    forest,      -- * Graph transformation     removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,     induce, -    -- * Algorithms-    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic,--    -- * Correctness properties-    isDfsForestOf, isTopSortOf-  ) where+    -- * Relational operations+    compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure+    ) where -import Control.Monad import Data.Foldable (foldMap) import Data.IntSet (IntSet)-import Data.Maybe import Data.Monoid import Data.Set (Set) import Data.Tree  import Algebra.Graph.AdjacencyIntMap.Internal -import qualified Data.Graph.Typed   as Typed import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet        as IntSet import qualified Data.Set           as Set +-- | Construct the /empty graph/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'isEmpty'     empty == True+-- 'hasVertex' x empty == False+-- 'vertexCount' empty == 0+-- 'edgeCount'   empty == 0+-- @+empty :: AdjacencyIntMap+empty = AM IntMap.empty+{-# NOINLINE [1] empty #-}++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'isEmpty'     (vertex x) == False+-- 'hasVertex' x (vertex x) == True+-- 'vertexCount' (vertex x) == 1+-- 'edgeCount'   (vertex x) == 0+-- @+vertex :: Int -> AdjacencyIntMap+vertex x = AM $ IntMap.singleton x IntSet.empty+{-# NOINLINE [1] vertex #-}+ -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. --@@ -73,6 +94,47 @@ edge x y | x == y    = AM $ IntMap.singleton x (IntSet.singleton y)          | otherwise = AM $ IntMap.fromList [(x, IntSet.singleton y), (y, IntSet.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.+--+-- @+-- 'isEmpty'     (overlay x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (overlay x y) >= 'vertexCount' x+-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (overlay x y) >= 'edgeCount' x+-- 'edgeCount'   (overlay x y) <= 'edgeCount' x   + 'edgeCount' y+-- 'vertexCount' (overlay 1 2) == 2+-- 'edgeCount'   (overlay 1 2) == 0+-- @+overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap+overlay x y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y)+{-# NOINLINE [1] overlay #-}++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'isEmpty'     (connect x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (connect x y) >= 'vertexCount' x+-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (connect x y) >= 'edgeCount' x+-- 'edgeCount'   (connect x y) >= 'edgeCount' y+-- 'edgeCount'   (connect x y) >= 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y+-- 'vertexCount' (connect 1 2) == 2+-- 'edgeCount'   (connect 1 2) == 1+-- @+connect :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap+connect x y = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y,+    IntMap.fromSet (const . IntMap.keysSet $ adjacencyIntMap y) (IntMap.keysSet $ adjacencyIntMap x) ]+{-# NOINLINE [1] connect #-}+ -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list.@@ -133,11 +195,12 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @--- isSubgraphOf 'empty'         x             == True--- isSubgraphOf ('vertex' x)    'empty'         == False--- isSubgraphOf x             ('overlay' x y) == True--- isSubgraphOf ('overlay' x y) ('connect' x y) == True--- isSubgraphOf ('path' xs)     ('circuit' xs)  == True+-- isSubgraphOf 'empty'         x             ==  True+-- isSubgraphOf ('vertex' x)    'empty'         ==  False+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf ('path' xs)     ('circuit' xs)  ==  True+-- isSubgraphOf x y                         ==> x <= y -- @ isSubgraphOf :: AdjacencyIntMap -> AdjacencyIntMap -> Bool isSubgraphOf x y = IntMap.isSubmapOfBy IntSet.isSubsetOf (adjacencyIntMap x) (adjacencyIntMap y)@@ -162,7 +225,7 @@ -- hasVertex x 'empty'            == False -- hasVertex x ('vertex' x)       == True -- hasVertex 1 ('vertex' 2)       == False--- hasVertex x . 'removeVertex' x == const False+-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Int -> AdjacencyIntMap -> Bool hasVertex x = IntMap.member x . adjacencyIntMap@@ -174,7 +237,7 @@ -- hasEdge x y 'empty'            == False -- hasEdge x y ('vertex' z)       == False -- hasEdge x y ('edge' x y)       == True--- hasEdge x y . 'removeEdge' x y == const False+-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Int -> Int -> AdjacencyIntMap -> Bool@@ -186,9 +249,10 @@ -- Complexity: /O(1)/ time. -- -- @--- vertexCount 'empty'      == 0--- vertexCount ('vertex' x) == 1--- vertexCount            == 'length' . 'vertexList'+-- vertexCount 'empty'             ==  0+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: AdjacencyIntMap -> Int vertexCount = IntMap.size . adjacencyIntMap@@ -225,7 +289,7 @@ -- edgeList ('edge' x y)     == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges'        == 'Data.List.nub' . 'Data.List.sort'--- edgeList . 'transpose'    == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList+-- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyIntMap -> [(Int, Int)] edgeList (AM m) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ]@@ -381,13 +445,29 @@ -- stars [(x, [])]               == 'vertex' x -- stars [(x, [y])]              == 'edge' x y -- stars [(x, ys)]               == 'star' x ys--- stars                         == 'overlays' . map (uncurry 'star')+-- stars                         == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList'         == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: [(Int, [Int])] -> AdjacencyIntMap stars = fromAdjacencyIntSets . map (fmap IntSet.fromList) +-- | Construct a graph from a list of adjacency sets; a variation of 'stars'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- fromAdjacencyIntSets []                                     == 'empty'+-- fromAdjacencyIntSets [(x, IntSet.'IntSet.empty')]                    == 'vertex' x+-- fromAdjacencyIntSets [(x, IntSet.'IntSet.singleton' y)]              == 'edge' x y+-- fromAdjacencyIntSets . 'map' ('fmap' IntSet.'IntSet.fromList')           == 'stars'+-- 'overlay' (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)+-- @+fromAdjacencyIntSets :: [(Int, IntSet)] -> AdjacencyIntMap+fromAdjacencyIntSets ss = AM $ IntMap.unionWith IntSet.union vs es+  where+    vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss+    es = IntMap.fromListWith IntSet.union ss+ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --@@ -409,7 +489,7 @@ -- forest []                                                  == 'empty' -- forest [x]                                                 == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)]--- forest                                                     == 'overlays' . map 'tree'+-- forest                                                     == 'overlays' . 'map' 'tree' -- @ forest :: Forest Int -> AdjacencyIntMap forest = overlays . map tree@@ -457,10 +537,10 @@ -- /O(1)/ to be evaluated. -- -- @--- mergeVertices (const False) x    == id+-- mergeVertices ('const' False) x    == id -- mergeVertices (== x) y           == 'replaceVertex' x y--- mergeVertices even 1 (0 * 2)     == 1 * 1--- mergeVertices odd  1 (3 + 4 * 5) == 4 * 1+-- mergeVertices 'even' 1 (0 * 2)     == 1 * 1+-- mergeVertices 'odd'  1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (Int -> Bool) -> Int -> AdjacencyIntMap -> AdjacencyIntMap mergeVertices p v = gmap $ \u -> if p u then v else u@@ -473,7 +553,7 @@ -- transpose ('vertex' x)  == 'vertex' x -- transpose ('edge' x y)  == 'edge' y x -- transpose . transpose == id--- 'edgeList' . transpose  == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList'+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: AdjacencyIntMap -> AdjacencyIntMap transpose (AM m) = AM $ IntMap.foldrWithKey combine vs m@@ -516,8 +596,8 @@ -- be evaluated. -- -- @--- induce (const True ) x      == x--- induce (const False) x      == 'empty'+-- 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@@ -525,168 +605,92 @@ induce :: (Int -> Bool) -> AdjacencyIntMap -> AdjacencyIntMap induce p = AM . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyIntMap --- | Compute the /depth-first search/ forest of a graph that corresponds to--- searching from each of the graph vertices in the 'Ord' @a@ order.------ @--- dfsForest 'empty'                       == []--- 'forest' (dfsForest $ 'edge' 1 1)         == 'vertex' 1--- 'forest' (dfsForest $ 'edge' 1 2)         == 'edge' 1 2--- 'forest' (dfsForest $ 'edge' 2 1)         == 'vertices' [1,2]--- 'isSubgraphOf' ('forest' $ dfsForest x) x == True--- 'isDfsForestOf' (dfsForest x) x         == True--- dfsForest . 'forest' . dfsForest        == dfsForest--- dfsForest ('vertices' vs)               == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs)--- 'dfsForestFrom' ('vertexList' x) x        == dfsForest x--- dfsForest $ 3 * (1 + 4) * (1 + 5)     == [ Node { rootLabel = 1---                                                 , subForest = [ Node { rootLabel = 5---                                                                      , subForest = [] }]}---                                          , Node { rootLabel = 3---                                                 , subForest = [ Node { rootLabel = 4---                                                                      , subForest = [] }]}]--- @-dfsForest :: AdjacencyIntMap -> Forest Int-dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap---- | Compute the /depth-first search/ forest of a graph, searching from each of--- the given vertices in order. Note that the resulting forest does not--- necessarily span the whole graph, as some vertices may be unreachable.------ @--- dfsForestFrom vs 'empty'                           == []--- 'forest' (dfsForestFrom [1]   $ 'edge' 1 1)          == 'vertex' 1--- 'forest' (dfsForestFrom [1]   $ 'edge' 1 2)          == 'edge' 1 2--- 'forest' (dfsForestFrom [2]   $ 'edge' 1 2)          == 'vertex' 2--- 'forest' (dfsForestFrom [3]   $ 'edge' 1 2)          == 'empty'--- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2)          == 'vertices' [1,2]--- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x     == True--- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True--- dfsForestFrom ('vertexList' x) x                   == 'dfsForest' x--- dfsForestFrom vs             ('vertices' vs)       == map (\\v -> Node v []) ('Data.List.nub' vs)--- dfsForestFrom []             x                   == []--- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5)      == [ Node { rootLabel = 1---                                                            , subForest = [ Node { rootLabel = 5---                                                                                 , subForest = [] }---                                                     , Node { rootLabel = 4---                                                            , subForest = [] }]--- @-dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int-dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap---- | Compute the list of vertices visited by the /depth-first search/ in a graph,--- when searching from each of the given vertices in order.------ @--- dfs vs    $ 'empty'                    == []--- dfs [1]   $ 'edge' 1 1                 == [1]--- dfs [1]   $ 'edge' 1 2                 == [1,2]--- dfs [2]   $ 'edge' 1 2                 == [2]--- dfs [3]   $ 'edge' 1 2                 == []--- dfs [1,2] $ 'edge' 1 2                 == [1,2]--- dfs [2,1] $ 'edge' 1 2                 == [2,1]--- dfs []    $ x                        == []--- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4]--- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True--- @-dfs :: [Int] -> AdjacencyIntMap -> [Int]-dfs vs = concatMap flatten . dfsForestFrom vs---- | Compute the list of vertices that are /reachable/ from a given source--- vertex in a graph. The vertices in the resulting list appear in the--- /depth-first order/.+-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are+-- connected in the resulting graph if there is a vertex @y@, such that @x@ is+-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the+-- second graph. There are no isolated vertices in the result. This operation is+-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/,+-- and distributes over 'overlay'.+-- Complexity: /O(n * m * log(n))/ time and /O(n + m)/ memory. -- -- @--- reachable x $ 'empty'                       == []--- reachable 1 $ 'vertex' 1                    == [1]--- reachable 1 $ 'vertex' 2                    == []--- reachable 1 $ 'edge' 1 1                    == [1]--- reachable 1 $ 'edge' 1 2                    == [1,2]--- reachable 4 $ 'path'    [1..8]              == [4..8]--- reachable 4 $ 'circuit' [1..8]              == [4..8] ++ [1..3]--- reachable 8 $ 'clique'  [8,7..1]            == [8] ++ [1..7]--- 'isSubgraphOf' ('vertices' $ reachable x y) y == True+-- compose 'empty'            x                == 'empty'+-- compose x                'empty'            == 'empty'+-- compose ('vertex' x)       y                == 'empty'+-- compose x                ('vertex' y)       == 'empty'+-- compose x                (compose y z)    == compose (compose x y) z+-- compose x                ('overlay' y z)    == 'overlay' (compose x y) (compose x z)+-- compose ('overlay' x y)    z                == 'overlay' (compose x z) (compose y z)+-- compose ('edge' x y)       ('edge' y z)       == 'edge' x z+-- compose ('path'    [1..5]) ('path'    [1..5]) == 'edges' [(1,3), (2,4), (3,5)]+-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @-reachable :: Int -> AdjacencyIntMap -> [Int]-reachable x = dfs [x]+compose :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap+compose x y = fromAdjacencyIntSets+    [ (t, ys) | v <- IntSet.toList vs, let ys = postIntSet v y+              , not (IntSet.null ys), t <- IntSet.toList (postIntSet v tx) ]+  where+    tx = transpose x+    vs = vertexIntSet x `IntSet.union` vertexIntSet y --- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph--- is cyclic.+-- | Compute the /reflexive and transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @--- topSort (1 * 2 + 3 * 1)               == Just [3,1,2]--- topSort (1 * 2 + 2 * 1)               == Nothing--- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False--- 'isJust' . topSort                      == 'isAcyclic'+-- closure 'empty'            == 'empty'+-- closure ('vertex' x)       == 'edge' x x+-- closure ('edge' x x)       == 'edge' x x+-- closure ('edge' x y)       == 'edges' [(x,x), (x,y), (y,y)]+-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs)+-- closure                  == 'reflexiveClosure' . 'transitiveClosure'+-- closure                  == 'transitiveClosure' . 'reflexiveClosure'+-- closure . closure        == closure+-- 'postIntSet' x (closure y) == IntSet.'IntSet.fromList' ('Algebra.Graph.ToGraph.reachable' x y) -- @-topSort :: AdjacencyIntMap -> Maybe [Int]-topSort m = if isTopSortOf result m then Just result else Nothing-  where-    result = Typed.topSort (Typed.fromAdjacencyIntMap m)+closure :: AdjacencyIntMap -> AdjacencyIntMap+closure = reflexiveClosure . transitiveClosure --- | Check if a given graph is /acyclic/.+-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every+-- vertex.+-- Complexity: /O(n * log(n))/ time. -- -- @--- isAcyclic (1 * 2 + 3 * 1) == True--- isAcyclic (1 * 2 + 2 * 1) == False--- isAcyclic . 'circuit'       == 'null'--- isAcyclic                 == 'isJust' . 'topSort'+-- reflexiveClosure 'empty'              == 'empty'+-- reflexiveClosure ('vertex' x)         == 'edge' x x+-- reflexiveClosure ('edge' x x)         == 'edge' x x+-- reflexiveClosure ('edge' x y)         == 'edges' [(x,x), (x,y), (y,y)]+-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @-isAcyclic :: AdjacencyIntMap -> Bool-isAcyclic = isJust . topSort+reflexiveClosure :: AdjacencyIntMap -> AdjacencyIntMap+reflexiveClosure (AM m) = AM $ IntMap.mapWithKey (\k -> IntSet.insert k) m --- | Check if a given forest is a correct /depth-first search/ forest of a graph.--- The implementation is based on the paper "Depth-First Search and Strong--- Connectivity in Coq" by François Pottier.+-- | Compute the /symmetric closure/ of a graph by overlaying it with its own+-- transpose.+-- Complexity: /O((n + m) * log(n))/ time. -- -- @--- isDfsForestOf []                              'empty'            == True--- isDfsForestOf []                              ('vertex' 1)       == False--- isDfsForestOf [Node 1 []]                     ('vertex' 1)       == True--- isDfsForestOf [Node 1 []]                     ('vertex' 2)       == False--- isDfsForestOf [Node 1 [], Node 1 []]          ('vertex' 1)       == False--- isDfsForestOf [Node 1 []]                     ('edge' 1 1)       == True--- isDfsForestOf [Node 1 []]                     ('edge' 1 2)       == False--- isDfsForestOf [Node 1 [], Node 2 []]          ('edge' 1 2)       == False--- isDfsForestOf [Node 2 [], Node 1 []]          ('edge' 1 2)       == True--- isDfsForestOf [Node 1 [Node 2 []]]            ('edge' 1 2)       == True--- isDfsForestOf [Node 1 [], Node 2 []]          ('vertices' [1,2]) == True--- isDfsForestOf [Node 2 [], Node 1 []]          ('vertices' [1,2]) == True--- isDfsForestOf [Node 1 [Node 2 []]]            ('vertices' [1,2]) == False--- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]]   ('path' [1,2,3])   == True--- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]]   ('path' [1,2,3])   == False--- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3])   == True--- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3])   == True--- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3])   == False+-- symmetricClosure 'empty'              == 'empty'+-- symmetricClosure ('vertex' x)         == 'vertex' x+-- symmetricClosure ('edge' x y)         == 'edges' [(x,y), (y,x)]+-- symmetricClosure x                  == 'overlay' x ('transpose' x)+-- symmetricClosure . symmetricClosure == symmetricClosure -- @-isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool-isDfsForestOf f am = case go IntSet.empty f of-    Just seen -> seen == vertexIntSet am-    Nothing   -> False-  where-    go seen []     = Just seen-    go seen (t:ts) = do-        let root = rootLabel t-        guard $ root `IntSet.notMember` seen-        guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ]-        newSeen <- go (IntSet.insert root seen) (subForest t)-        guard $ postIntSet root am `IntSet.isSubsetOf` newSeen-        go newSeen ts+symmetricClosure :: AdjacencyIntMap -> AdjacencyIntMap+symmetricClosure m = overlay m (transpose m) --- | Check if a given list of vertices is a correct /topological sort/ of a graph.+-- | Compute the /transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @--- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True--- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False--- isTopSortOf []      (1 * 2 + 3 * 1) == False--- isTopSortOf []      'empty'           == True--- isTopSortOf [x]     ('vertex' x)      == True--- isTopSortOf [x]     ('edge' x x)      == False+-- transitiveClosure 'empty'               == 'empty'+-- transitiveClosure ('vertex' x)          == 'vertex' x+-- transitiveClosure ('edge' x y)          == 'edge' x y+-- transitiveClosure ('path' $ 'Data.List.nub' xs)     == 'clique' ('Data.List.nub' xs)+-- transitiveClosure . transitiveClosure == transitiveClosure -- @-isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool-isTopSortOf xs m = go IntSet.empty xs+transitiveClosure :: AdjacencyIntMap -> AdjacencyIntMap+transitiveClosure old+    | old == new = old+    | otherwise  = transitiveClosure new   where-    go seen []     = seen == IntMap.keysSet (adjacencyIntMap m)-    go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty-                  && go newSeen vs-      where-        newSeen = IntSet.insert v seen+    new = overlay old (old `compose` old)

@@ -0,0 +1,198 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.AdjacencyIntMap.Algorithm+-- Copyright  : (c) Andrey Mokhov 2016-2018+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : unstable+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module provides basic graph algorithms, such as /depth-first search/,+-- implemented for the "Algebra.Graph.AdjacencyIntMap" data type.+-----------------------------------------------------------------------------+module Algebra.Graph.AdjacencyIntMap.Algorithm (+    -- * Algorithms+    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic,++    -- * Correctness properties+    isDfsForestOf, isTopSortOf+    ) where++import Control.Monad+import Data.Maybe+import Data.Tree++import Algebra.Graph.AdjacencyIntMap++import qualified Data.Graph.Typed   as Typed+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet        as IntSet++-- | Compute the /depth-first search/ forest of a graph that corresponds to+-- searching from each of the graph vertices in the 'Ord' @a@ order.+--+-- @+-- dfsForest 'empty'                       == []+-- 'forest' (dfsForest $ 'edge' 1 1)         == 'vertex' 1+-- 'forest' (dfsForest $ 'edge' 1 2)         == 'edge' 1 2+-- 'forest' (dfsForest $ 'edge' 2 1)         == 'vertices' [1,2]+-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True+-- 'isDfsForestOf' (dfsForest x) x         == True+-- dfsForest . 'forest' . dfsForest        == dfsForest+-- dfsForest ('vertices' vs)               == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs)+-- 'dfsForestFrom' ('vertexList' x) x        == dfsForest x+-- dfsForest $ 3 * (1 + 4) * (1 + 5)     == [ Node { rootLabel = 1+--                                                 , subForest = [ Node { rootLabel = 5+--                                                                      , subForest = [] }]}+--                                          , Node { rootLabel = 3+--                                                 , subForest = [ Node { rootLabel = 4+--                                                                      , subForest = [] }]}]+-- @+dfsForest :: AdjacencyIntMap -> Forest Int+dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap++-- | Compute the /depth-first search/ forest of a graph, searching from each of+-- the given vertices in order. Note that the resulting forest does not+-- necessarily span the whole graph, as some vertices may be unreachable.+--+-- @+-- dfsForestFrom vs 'empty'                           == []+-- 'forest' (dfsForestFrom [1]   $ 'edge' 1 1)          == 'vertex' 1+-- 'forest' (dfsForestFrom [1]   $ 'edge' 1 2)          == 'edge' 1 2+-- 'forest' (dfsForestFrom [2]   $ 'edge' 1 2)          == 'vertex' 2+-- 'forest' (dfsForestFrom [3]   $ 'edge' 1 2)          == 'empty'+-- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2)          == 'vertices' [1,2]+-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x     == True+-- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True+-- dfsForestFrom ('vertexList' x) x                   == 'dfsForest' x+-- dfsForestFrom vs             ('vertices' vs)       == 'map' (\\v -> Node v []) ('Data.List.nub' vs)+-- dfsForestFrom []             x                   == []+-- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5)      == [ Node { rootLabel = 1+--                                                            , subForest = [ Node { rootLabel = 5+--                                                                                 , subForest = [] }+--                                                     , Node { rootLabel = 4+--                                                            , subForest = [] }]+-- @+dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int+dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap++-- | Compute the list of vertices visited by the /depth-first search/ in a graph,+-- when searching from each of the given vertices in order.+--+-- @+-- dfs vs    $ 'empty'                    == []+-- dfs [1]   $ 'edge' 1 1                 == [1]+-- dfs [1]   $ 'edge' 1 2                 == [1,2]+-- dfs [2]   $ 'edge' 1 2                 == [2]+-- dfs [3]   $ 'edge' 1 2                 == []+-- dfs [1,2] $ 'edge' 1 2                 == [1,2]+-- dfs [2,1] $ 'edge' 1 2                 == [2,1]+-- dfs []    $ x                        == []+-- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4]+-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True+-- @+dfs :: [Int] -> AdjacencyIntMap -> [Int]+dfs vs = concatMap flatten . dfsForestFrom vs++-- | Compute the list of vertices that are /reachable/ from a given source+-- vertex in a graph. The vertices in the resulting list appear in the+-- /depth-first order/.+--+-- @+-- reachable x $ 'empty'                       == []+-- reachable 1 $ 'vertex' 1                    == [1]+-- reachable 1 $ 'vertex' 2                    == []+-- reachable 1 $ 'edge' 1 1                    == [1]+-- reachable 1 $ 'edge' 1 2                    == [1,2]+-- reachable 4 $ 'path'    [1..8]              == [4..8]+-- reachable 4 $ 'circuit' [1..8]              == [4..8] ++ [1..3]+-- reachable 8 $ 'clique'  [8,7..1]            == [8] ++ [1..7]+-- 'isSubgraphOf' ('vertices' $ reachable x y) y == True+-- @+reachable :: Int -> AdjacencyIntMap -> [Int]+reachable x = dfs [x]++-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph+-- is cyclic.+--+-- @+-- topSort (1 * 2 + 3 * 1)               == Just [3,1,2]+-- topSort (1 * 2 + 2 * 1)               == Nothing+-- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Just False+-- 'isJust' . topSort                      == 'isAcyclic'+-- @+topSort :: AdjacencyIntMap -> Maybe [Int]+topSort m = if isTopSortOf result m then Just result else Nothing+  where+    result = Typed.topSort (Typed.fromAdjacencyIntMap m)++-- | Check if a given graph is /acyclic/.+--+-- @+-- isAcyclic (1 * 2 + 3 * 1) == True+-- isAcyclic (1 * 2 + 2 * 1) == False+-- isAcyclic . 'circuit'       == 'null'+-- isAcyclic                 == 'isJust' . 'topSort'+-- @+isAcyclic :: AdjacencyIntMap -> Bool+isAcyclic = isJust . topSort++-- | Check if a given forest is a correct /depth-first search/ forest of a graph.+-- The implementation is based on the paper "Depth-First Search and Strong+-- Connectivity in Coq" by François Pottier.+--+-- @+-- isDfsForestOf []                              'empty'            == True+-- isDfsForestOf []                              ('vertex' 1)       == False+-- isDfsForestOf [Node 1 []]                     ('vertex' 1)       == True+-- isDfsForestOf [Node 1 []]                     ('vertex' 2)       == False+-- isDfsForestOf [Node 1 [], Node 1 []]          ('vertex' 1)       == False+-- isDfsForestOf [Node 1 []]                     ('edge' 1 1)       == True+-- isDfsForestOf [Node 1 []]                     ('edge' 1 2)       == False+-- isDfsForestOf [Node 1 [], Node 2 []]          ('edge' 1 2)       == False+-- isDfsForestOf [Node 2 [], Node 1 []]          ('edge' 1 2)       == True+-- isDfsForestOf [Node 1 [Node 2 []]]            ('edge' 1 2)       == True+-- isDfsForestOf [Node 1 [], Node 2 []]          ('vertices' [1,2]) == True+-- isDfsForestOf [Node 2 [], Node 1 []]          ('vertices' [1,2]) == True+-- isDfsForestOf [Node 1 [Node 2 []]]            ('vertices' [1,2]) == False+-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]]   ('path' [1,2,3])   == True+-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]]   ('path' [1,2,3])   == False+-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3])   == True+-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3])   == True+-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3])   == False+-- @+isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool+isDfsForestOf f am = case go IntSet.empty f of+    Just seen -> seen == vertexIntSet am+    Nothing   -> False+  where+    go seen []     = Just seen+    go seen (t:ts) = do+        let root = rootLabel t+        guard $ root `IntSet.notMember` seen+        guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ]+        newSeen <- go (IntSet.insert root seen) (subForest t)+        guard $ postIntSet root am `IntSet.isSubsetOf` newSeen+        go newSeen ts++-- | Check if a given list of vertices is a correct /topological sort/ of a graph.+--+-- @+-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True+-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False+-- isTopSortOf []      (1 * 2 + 3 * 1) == False+-- isTopSortOf []      'empty'           == True+-- isTopSortOf [x]     ('vertex' x)      == True+-- isTopSortOf [x]     ('edge' x x)      == False+-- @+isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool+isTopSortOf xs m = go IntSet.empty xs+  where+    go seen []     = seen == IntMap.keysSet (adjacencyIntMap m)+    go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty+                  && go newSeen vs+      where+        newSeen = IntSet.insert v seen

@@ -12,10 +12,14 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyIntMap.Internal (     -- * Adjacency map implementation-    AdjacencyIntMap (..), empty, vertex, overlay, connect, fromAdjacencyIntSets,-    consistent+    AdjacencyIntMap (..), consistent   ) where +import Prelude ()+import Prelude.Compat hiding (null)++import Data.Foldable (foldMap)+import Data.Monoid (getSum, Sum (..)) import Data.IntMap.Strict (IntMap, keysSet, fromSet) import Data.IntSet (IntSet) import Data.List@@ -35,6 +39,14 @@     > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))     > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num',+which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as+additive and multiplicative identities, and 'negate' as additive inverse.+Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when+working with algebraic graphs; we hope that in future Haskell's Prelude will+provide a more fine-grained class hierarchy for algebraic structures, which we+would be able to utilise without violating any laws.+ The 'Show' instance is defined using basic graph construction primitives:  @show (empty     :: AdjacencyIntMap Int) == "empty"@@ -84,10 +96,36 @@  When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively.++The total order on graphs is defined using /size-lexicographic/ comparison:++* Compare the number of vertices. In case of a tie, continue.+* Compare the sets of vertices. In case of a tie, continue.+* Compare the number of edges. In case of a tie, continue.+* Compare the sets of edges.++Here are a few examples:++@'Algebra.Graph.AdjacencyIntMap.vertex' 1 < 'Algebra.Graph.AdjacencyIntMap.vertex' 2+'Algebra.Graph.AdjacencyIntMap.vertex' 3 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 2+'Algebra.Graph.AdjacencyIntMap.vertex' 1 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 1+'Algebra.Graph.AdjacencyIntMap.edge' 1 1 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 2+'Algebra.Graph.AdjacencyIntMap.edge' 1 2 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 1 + 'Algebra.Graph.AdjacencyIntMap.edge' 2 2+'Algebra.Graph.AdjacencyIntMap.edge' 1 2 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 3@++Note that the resulting order refines the 'Algebra.Graph.AdjacencyIntMap.isSubgraphOf'+relation and is compatible with 'Algebra.Graph.AdjacencyIntMap.overlay' and+'Algebra.Graph.AdjacencyIntMap.connect' operations:++@'Algebra.Graph.AdjacencyIntMap.isSubgraphOf' x y ==> x <= y@++@'Algebra.Graph.AdjacencyIntMap.empty' <= x+x     <= x + y+x + y <= x * y@ -} newtype AdjacencyIntMap = AM {-    -- | The /adjacency map/ of the graph: each vertex is associated with a set-    -- of its direct successors. Complexity: /O(1)/ time and memory.+    -- | The /adjacency map/ of a graph: each vertex is associated with a set of+    -- its direct successors. Complexity: /O(1)/ time and memory.     --     -- @     -- adjacencyIntMap 'empty'      == IntMap.'IntMap.empty'@@ -98,113 +136,47 @@     adjacencyIntMap :: IntMap IntSet } deriving Eq  instance Show AdjacencyIntMap where-    show (AM m)-        | null vs    = "empty"-        | null es    = vshow vs-        | vs == used = eshow es-        | otherwise  = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")"+    showsPrec p (AM m)+        | null vs    = showString "empty"+        | null es    = showParen (p > 10) $ vshow vs+        | vs == used = showParen (p > 10) $ eshow es+        | otherwise  = showParen (p > 10) $+                           showString "overlay (" . vshow (vs \\ used) .+                           showString ") (" . eshow es . showString ")"       where         vs             = IntSet.toAscList (keysSet m)         es             = internalEdgeList m-        vshow [x]      = "vertex "   ++ show x-        vshow xs       = "vertices " ++ show xs-        eshow [(x, y)] = "edge "     ++ show x ++ " " ++ show y-        eshow xs       = "edges "    ++ show xs+        vshow [x]      = showString "vertex "   . showsPrec 11 x+        vshow xs       = showString "vertices " . showsPrec 11 xs+        eshow [(x, y)] = showString "edge "     . showsPrec 11 x .+                         showString " "         . showsPrec 11 y+        eshow xs       = showString "edges "    . showsPrec 11 xs         used           = IntSet.toAscList (referredToVertexSet m) --- | Construct the /empty graph/.--- Complexity: /O(1)/ time and memory.------ @--- 'Algebra.Graph.AdjacencyIntMap.isEmpty'     empty == True--- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x empty == False--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' empty == 0--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   empty == 0--- @-empty :: AdjacencyIntMap-empty = AM IntMap.empty-{-# NOINLINE [1] empty #-}---- | Construct the graph comprising /a single isolated vertex/.--- Complexity: /O(1)/ time and memory.------ @--- 'Algebra.Graph.AdjacencyIntMap.isEmpty'     (vertex x) == False--- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x (vertex x) == True--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (vertex x) == 1--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (vertex x) == 0--- @-vertex :: Int -> AdjacencyIntMap-vertex x = AM $ IntMap.singleton x IntSet.empty-{-# NOINLINE [1] vertex #-}---- | /Overlay/ two graphs. This is a commutative, associative and idempotent--- operation with the identity 'empty'.--- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.------ @--- 'Algebra.Graph.AdjacencyIntMap.isEmpty'     (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty'   x   && 'Algebra.Graph.AdjacencyIntMap.isEmpty'   y--- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x   + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay 1 2) == 2--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (overlay 1 2) == 0--- @-overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap-overlay x y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y)-{-# NOINLINE [1] overlay #-}---- | /Connect/ two graphs. This is an associative operation with the identity--- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.--- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the--- number of edges in the resulting graph is quadratic with respect to the number--- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.------ @--- 'Algebra.Graph.AdjacencyIntMap.isEmpty'     (connect x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty'   x   && 'Algebra.Graph.AdjacencyIntMap.isEmpty'   y--- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (connect x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' y--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y + 'Algebra.Graph.AdjacencyIntMap.edgeCount' x + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y--- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect 1 2) == 2--- 'Algebra.Graph.AdjacencyIntMap.edgeCount'   (connect 1 2) == 1--- @-connect :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap-connect x y = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y,-    fromSet (const . keysSet $ adjacencyIntMap y) (keysSet $ adjacencyIntMap x) ]-{-# NOINLINE [1] connect #-}+instance Ord AdjacencyIntMap where+    compare (AM x) (AM y) = mconcat+        [ compare (vNum x) (vNum y)+        , compare (vSet x) (vSet y)+        , compare (eNum x) (eNum y)+        , compare       x        y ]+      where+        vNum = IntMap.size+        vSet = IntMap.keysSet+        eNum = getSum . foldMap (Sum . IntSet.size) +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyIntMap'+-- for more details. instance Num AdjacencyIntMap where-    fromInteger = vertex . fromInteger-    (+)         = overlay-    (*)         = connect-    signum      = const empty-    abs         = id-    negate      = id+    fromInteger x = AM $ IntMap.singleton (fromInteger x) IntSet.empty+    x + y  = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y)+    x * y  = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y,+        fromSet (const . keysSet $ adjacencyIntMap y) (keysSet $ adjacencyIntMap x) ]+    signum = const (AM IntMap.empty)+    abs    = id+    negate = id  instance NFData AdjacencyIntMap where     rnf (AM a) = rnf a---- | Construct a graph from a list of adjacency sets.--- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.------ @--- fromAdjacencyIntSets []                                           == 'Algebra.Graph.AdjacencyIntMap.empty'--- fromAdjacencyIntSets [(x, IntSet.'IntSet.empty')]                          == 'Algebra.Graph.AdjacencyIntMap.vertex' x--- fromAdjacencyIntSets [(x, IntSet.'IntSet.singleton' y)]                    == 'Algebra.Graph.AdjacencyIntMap.edge' x y--- fromAdjacencyIntSets . map (fmap IntSet.'IntSet.fromList') . 'Algebra.Graph.AdjacencyIntMap.adjacencyList' == id--- 'Algebra.Graph.AdjacencyIntMap.overlay' (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys)       == fromAdjacencyIntSets (xs ++ ys)--- @-fromAdjacencyIntSets :: [(Int, IntSet)] -> AdjacencyIntMap-fromAdjacencyIntSets ss = AM $ IntMap.unionWith IntSet.union vs es-  where-    vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss-    es = IntMap.fromListWith IntSet.union ss  -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices. It should be impossible to create an

@@ -10,9 +10,10 @@ -- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the -- motivation behind the library, the underlying theory, and implementation details. ----- This module defines the 'AdjacencyMap' data type, as well as associated--- operations and algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type--- class, which can be used for polymorphic graph construction and manipulation.+-- This module defines the 'AdjacencyMap' data type and associated functions.+-- See "Algebra.Graph.AdjacencyMap.Algorithm" for implementations of basic graph+-- algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type class, which+-- can be used for polymorphic graph construction and manipulation. -- "Algebra.Graph.AdjacencyIntMap" defines adjacency maps specialised to graphs -- with @Int@ vertices. -----------------------------------------------------------------------------@@ -28,37 +29,56 @@      -- * Graph properties     isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList,-    adjacencyList, vertexSet, vertexIntSet, edgeSet, preSet, postSet,+    adjacencyList, vertexSet, edgeSet, preSet, postSet,      -- * Standard families of graphs-    path, circuit, clique, biclique, star, stars, tree, forest,+    path, circuit, clique, biclique, star, stars, fromAdjacencySets, tree,+    forest,      -- * Graph transformation     removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,     induce, -    -- * Algorithms-    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc,--    -- * Correctness properties-    isDfsForestOf, isTopSortOf-  ) where+    -- * Relational operations+    compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure+    ) where -import Control.Monad-import Data.Foldable (foldMap, toList)-import Data.Maybe+import Data.Foldable (foldMap) import Data.Monoid import Data.Set (Set) import Data.Tree  import Algebra.Graph.AdjacencyMap.Internal -import qualified Data.Graph.Typed as Typed-import qualified Data.Graph       as KL-import qualified Data.Map.Strict  as Map-import qualified Data.Set         as Set-import qualified Data.IntSet      as IntSet+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 a+empty = AM Map.empty+{-# NOINLINE [1] 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 a+vertex x = AM $ Map.singleton x Set.empty+{-# NOINLINE [1] vertex #-}+ -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. --@@ -73,6 +93,47 @@ edge x y | x == y    = AM $ Map.singleton x (Set.singleton y)          | otherwise = AM $ Map.fromList [(x, Set.singleton y), (y, Set.empty)] +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent+-- operation with the identity 'empty'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'isEmpty'     (overlay x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (overlay x y) >= 'vertexCount' x+-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (overlay x y) >= 'edgeCount' x+-- 'edgeCount'   (overlay x y) <= 'edgeCount' x   + 'edgeCount' y+-- 'vertexCount' (overlay 1 2) == 2+-- 'edgeCount'   (overlay 1 2) == 0+-- @+overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y)+{-# NOINLINE [1] overlay #-}++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'isEmpty'     (connect x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (connect x y) >= 'vertexCount' x+-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (connect x y) >= 'edgeCount' x+-- 'edgeCount'   (connect x y) >= 'edgeCount' y+-- 'edgeCount'   (connect x y) >= 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y+-- 'vertexCount' (connect 1 2) == 2+-- 'edgeCount'   (connect 1 2) == 1+-- @+connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+connect 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. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list.@@ -133,11 +194,12 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @--- isSubgraphOf 'empty'         x             == True--- isSubgraphOf ('vertex' x)    'empty'         == False--- isSubgraphOf x             ('overlay' x y) == True--- isSubgraphOf ('overlay' x y) ('connect' x y) == True--- isSubgraphOf ('path' xs)     ('circuit' xs)  == True+-- isSubgraphOf 'empty'         x             ==  True+-- isSubgraphOf ('vertex' x)    'empty'         ==  False+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf ('path' xs)     ('circuit' xs)  ==  True+-- isSubgraphOf x y                         ==> x <= y -- @ isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool isSubgraphOf x y = Map.isSubmapOfBy Set.isSubsetOf (adjacencyMap x) (adjacencyMap y)@@ -162,7 +224,7 @@ -- hasVertex x 'empty'            == False -- hasVertex x ('vertex' x)       == True -- hasVertex 1 ('vertex' 2)       == False--- hasVertex x . 'removeVertex' x == const False+-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool hasVertex x = Map.member x . adjacencyMap@@ -174,7 +236,7 @@ -- hasEdge x y 'empty'            == False -- hasEdge x y ('vertex' z)       == False -- hasEdge x y ('edge' x y)       == True--- hasEdge x y . 'removeEdge' x y == const False+-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool@@ -186,9 +248,10 @@ -- Complexity: /O(1)/ time. -- -- @--- vertexCount 'empty'      == 0--- vertexCount ('vertex' x) == 1--- vertexCount            == 'length' . 'vertexList'+-- vertexCount 'empty'             ==  0+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: AdjacencyMap a -> Int vertexCount = Map.size . adjacencyMap@@ -225,7 +288,7 @@ -- edgeList ('edge' x y)     == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges'        == 'Data.List.nub' . 'Data.List.sort'--- edgeList . 'transpose'    == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList+-- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyMap a -> [(a, a)] edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]@@ -237,24 +300,10 @@ -- 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 --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for--- graphs with vertices of type 'Int'.--- Complexity: /O(n)/ time and memory.------ @--- vertexIntSet 'empty'      == IntSet.'IntSet.empty'--- vertexIntSet . 'vertex'   == IntSet.'IntSet.singleton'--- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'--- vertexIntSet . 'clique'   == IntSet.'IntSet.fromList'--- @-vertexIntSet :: AdjacencyMap Int -> IntSet.IntSet-vertexIntSet = IntSet.fromAscList . Set.toAscList . vertexSet- -- | The set of edges of a given graph. -- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. --@@ -264,7 +313,7 @@ -- 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.@@ -341,7 +390,7 @@ -- 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@@ -393,13 +442,29 @@ -- stars [(x, [])]               == 'vertex' x -- stars [(x, [y])]              == 'edge' x y -- stars [(x, ys)]               == 'star' x ys--- stars                         == 'overlays' . map (uncurry 'star')+-- 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) +-- | Construct a graph from a list of adjacency sets; a variation of 'stars'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- fromAdjacencySets []                                  == 'empty'+-- 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)+-- @+fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a+fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es+  where+    vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss+    es = Map.fromListWith Set.union ss+ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --@@ -421,7 +486,7 @@ -- forest []                                                  == 'empty' -- forest [x]                                                 == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)]--- forest                                                     == 'overlays' . map 'tree'+-- forest                                                     == 'overlays' . 'map' 'tree' -- @ forest :: Ord a => Forest a -> AdjacencyMap a forest = overlays . map tree@@ -469,10 +534,10 @@ -- /O(1)/ to be evaluated. -- -- @--- mergeVertices (const False) x    == id+-- mergeVertices ('const' False) x    == id -- mergeVertices (== x) y           == 'replaceVertex' x y--- mergeVertices even 1 (0 * 2)     == 1 * 1--- mergeVertices odd  1 (3 + 4 * 5) == 4 * 1+-- mergeVertices 'even' 1 (0 * 2)     == 1 * 1+-- mergeVertices 'odd'  1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a mergeVertices p v = gmap $ \u -> if p u then v else u@@ -485,7 +550,7 @@ -- transpose ('vertex' x)  == 'vertex' x -- transpose ('edge' x y)  == 'edge' y x -- transpose . transpose == id--- 'edgeList' . transpose  == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList'+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a transpose (AM m) = AM $ Map.foldrWithKey combine vs m@@ -516,7 +581,7 @@ -- 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@@ -528,8 +593,8 @@ -- be evaluated. -- -- @--- induce (const True ) x      == x--- induce (const False) x      == 'empty'+-- 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@@ -537,188 +602,92 @@ induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a induce p = AM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap --- | Compute the /depth-first search/ forest of a graph that corresponds to--- searching from each of the graph vertices in the 'Ord' @a@ order.------ @--- dfsForest 'empty'                       == []--- 'forest' (dfsForest $ 'edge' 1 1)         == 'vertex' 1--- 'forest' (dfsForest $ 'edge' 1 2)         == 'edge' 1 2--- 'forest' (dfsForest $ 'edge' 2 1)         == 'vertices' [1,2]--- 'isSubgraphOf' ('forest' $ dfsForest x) x == True--- 'isDfsForestOf' (dfsForest x) x         == True--- dfsForest . 'forest' . dfsForest        == dfsForest--- dfsForest ('vertices' vs)               == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs)--- 'dfsForestFrom' ('vertexList' x) x        == dfsForest x--- dfsForest $ 3 * (1 + 4) * (1 + 5)     == [ Node { rootLabel = 1---                                                 , subForest = [ Node { rootLabel = 5---                                                                      , subForest = [] }]}---                                          , Node { rootLabel = 3---                                                 , subForest = [ Node { rootLabel = 4---                                                                      , subForest = [] }]}]--- @-dfsForest :: Ord a => AdjacencyMap a -> Forest a-dfsForest g = dfsForestFrom (vertexList g) g---- | Compute the /depth-first search/ forest of a graph, searching from each of--- the given vertices in order. Note that the resulting forest does not--- necessarily span the whole graph, as some vertices may be unreachable.------ @--- dfsForestFrom vs 'empty'                           == []--- 'forest' (dfsForestFrom [1]   $ 'edge' 1 1)          == 'vertex' 1--- 'forest' (dfsForestFrom [1]   $ 'edge' 1 2)          == 'edge' 1 2--- 'forest' (dfsForestFrom [2]   $ 'edge' 1 2)          == 'vertex' 2--- 'forest' (dfsForestFrom [3]   $ 'edge' 1 2)          == 'empty'--- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2)          == 'vertices' [1,2]--- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x     == True--- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True--- dfsForestFrom ('vertexList' x) x                   == 'dfsForest' x--- dfsForestFrom vs             ('vertices' vs)       == map (\\v -> Node v []) ('Data.List.nub' vs)--- dfsForestFrom []             x                   == []--- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5)      == [ Node { rootLabel = 1---                                                            , subForest = [ Node { rootLabel = 5---                                                                                 , subForest = [] }---                                                     , Node { rootLabel = 4---                                                            , subForest = [] }]--- @-dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a-dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap---- | Compute the list of vertices visited by the /depth-first search/ in a--- graph, when searching from each of the given vertices in order.------ @--- dfs vs    $ 'empty'                    == []--- dfs [1]   $ 'edge' 1 1                 == [1]--- dfs [1]   $ 'edge' 1 2                 == [1,2]--- dfs [2]   $ 'edge' 1 2                 == [2]--- dfs [3]   $ 'edge' 1 2                 == []--- dfs [1,2] $ 'edge' 1 2                 == [1,2]--- dfs [2,1] $ 'edge' 1 2                 == [2,1]--- dfs []    $ x                        == []--- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4]--- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True--- @-dfs :: Ord a => [a] -> AdjacencyMap a -> [a]-dfs vs = concatMap flatten . dfsForestFrom vs---- | Compute the list of vertices that are /reachable/ from a given source--- vertex in a graph. The vertices in the resulting list appear in the--- /depth-first order/.------ @--- reachable x $ 'empty'                       == []--- reachable 1 $ 'vertex' 1                    == [1]--- reachable 1 $ 'vertex' 2                    == []--- reachable 1 $ 'edge' 1 1                    == [1]--- reachable 1 $ 'edge' 1 2                    == [1,2]--- reachable 4 $ 'path'    [1..8]              == [4..8]--- reachable 4 $ 'circuit' [1..8]              == [4..8] ++ [1..3]--- reachable 8 $ 'clique'  [8,7..1]            == [8] ++ [1..7]--- 'isSubgraphOf' ('vertices' $ reachable x y) y == True--- @-reachable :: Ord a => a -> AdjacencyMap a -> [a]-reachable x = dfs [x]---- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph--- is cyclic.+-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are+-- connected in the resulting graph if there is a vertex @y@, such that @x@ is+-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the+-- second graph. There are no isolated vertices in the result. This operation is+-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/,+-- and distributes over 'overlay'.+-- Complexity: /O(n * m * log(n))/ time and /O(n + m)/ memory. -- -- @--- topSort (1 * 2 + 3 * 1)               == Just [3,1,2]--- topSort (1 * 2 + 2 * 1)               == Nothing--- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False--- 'isJust' . topSort                      == 'isAcyclic'+-- compose 'empty'            x                == 'empty'+-- compose x                'empty'            == 'empty'+-- compose ('vertex' x)       y                == 'empty'+-- compose x                ('vertex' y)       == 'empty'+-- compose x                (compose y z)    == compose (compose x y) z+-- compose x                ('overlay' y z)    == 'overlay' (compose x y) (compose x z)+-- compose ('overlay' x y)    z                == 'overlay' (compose x z) (compose y z)+-- compose ('edge' x y)       ('edge' y z)       == 'edge' x z+-- compose ('path'    [1..5]) ('path'    [1..5]) == 'edges' [(1,3), (2,4), (3,5)]+-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @-topSort :: Ord a => AdjacencyMap a -> Maybe [a]-topSort m = if isTopSortOf result m then Just result else Nothing+compose :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+compose x y = fromAdjacencySets+    [ (t, ys) | v <- Set.toList vs, let ys = postSet v y, not (Set.null ys)+              , t <- Set.toList (postSet v tx) ]   where-    result = Typed.topSort (Typed.fromAdjacencyMap m)+    tx = transpose x+    vs = vertexSet x `Set.union` vertexSet y --- | Check if a given graph is /acyclic/.+-- | Compute the /reflexive and transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @--- isAcyclic (1 * 2 + 3 * 1) == True--- isAcyclic (1 * 2 + 2 * 1) == False--- isAcyclic . 'circuit'       == 'null'--- isAcyclic                 == 'isJust' . 'topSort'+-- closure 'empty'           == 'empty'+-- closure ('vertex' x)      == 'edge' x x+-- closure ('edge' x x)      == 'edge' x x+-- closure ('edge' x y)      == 'edges' [(x,x), (x,y), (y,y)]+-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs)+-- closure                 == 'reflexiveClosure' . 'transitiveClosure'+-- closure                 == 'transitiveClosure' . 'reflexiveClosure'+-- closure . closure       == closure+-- 'postSet' x (closure y)   == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) -- @-isAcyclic :: Ord a => AdjacencyMap a -> Bool-isAcyclic = isJust . topSort+closure :: Ord a => AdjacencyMap a -> AdjacencyMap a+closure = reflexiveClosure . transitiveClosure --- | Compute the /condensation/ of a graph, where each vertex corresponds to a--- /strongly-connected component/ of the original graph.+-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every+-- vertex.+-- Complexity: /O(n * log(n))/ time. -- -- @--- scc 'empty'               == 'empty'--- scc ('vertex' x)          == 'vertex' (Set.'Set.singleton' x)--- scc ('edge' x y)          == 'edge' (Set.'Set.singleton' x) (Set.'Set.singleton' y)--- scc ('circuit' (1:xs))    == 'edge' (Set.'Set.fromList' (1:xs)) (Set.'Set.fromList' (1:xs))--- scc (3 * 1 * 4 * 1 * 5) == 'edges' [ (Set.'Set.fromList' [1,4], Set.'Set.fromList' [1,4])---                                  , (Set.'Set.fromList' [1,4], Set.'Set.fromList' [5]  )---                                  , (Set.'Set.fromList' [3]  , Set.'Set.fromList' [1,4])---                                  , (Set.'Set.fromList' [3]  , Set.'Set.fromList' [5]  )]+-- reflexiveClosure 'empty'              == 'empty'+-- reflexiveClosure ('vertex' x)         == 'edge' x x+-- reflexiveClosure ('edge' x x)         == 'edge' x x+-- reflexiveClosure ('edge' x y)         == 'edges' [(x,x), (x,y), (y,y)]+-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @-scc :: Ord a => AdjacencyMap a -> AdjacencyMap (Set a)-scc m = gmap (\v -> Map.findWithDefault Set.empty v components) m-  where-    (Typed.GraphKL g r _) = Typed.fromAdjacencyMap m-    components = Map.fromList $ concatMap (expand . fmap r . toList) (KL.scc g)-    expand xs  = let s = Set.fromList xs in map (\x -> (x, s)) xs+reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Set.insert k) m --- | Check if a given forest is a correct /depth-first search/ forest of a graph.--- The implementation is based on the paper "Depth-First Search and Strong--- Connectivity in Coq" by François Pottier.+-- | Compute the /symmetric closure/ of a graph by overlaying it with its own+-- transpose.+-- Complexity: /O((n + m) * log(n))/ time. -- -- @--- isDfsForestOf []                              'empty'            == True--- isDfsForestOf []                              ('vertex' 1)       == False--- isDfsForestOf [Node 1 []]                     ('vertex' 1)       == True--- isDfsForestOf [Node 1 []]                     ('vertex' 2)       == False--- isDfsForestOf [Node 1 [], Node 1 []]          ('vertex' 1)       == False--- isDfsForestOf [Node 1 []]                     ('edge' 1 1)       == True--- isDfsForestOf [Node 1 []]                     ('edge' 1 2)       == False--- isDfsForestOf [Node 1 [], Node 2 []]          ('edge' 1 2)       == False--- isDfsForestOf [Node 2 [], Node 1 []]          ('edge' 1 2)       == True--- isDfsForestOf [Node 1 [Node 2 []]]            ('edge' 1 2)       == True--- isDfsForestOf [Node 1 [], Node 2 []]          ('vertices' [1,2]) == True--- isDfsForestOf [Node 2 [], Node 1 []]          ('vertices' [1,2]) == True--- isDfsForestOf [Node 1 [Node 2 []]]            ('vertices' [1,2]) == False--- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]]   ('path' [1,2,3])   == True--- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]]   ('path' [1,2,3])   == False--- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3])   == True--- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3])   == True--- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3])   == False+-- symmetricClosure 'empty'              == 'empty'+-- symmetricClosure ('vertex' x)         == 'vertex' x+-- symmetricClosure ('edge' x y)         == 'edges' [(x,y), (y,x)]+-- symmetricClosure x                  == 'overlay' x ('transpose' x)+-- symmetricClosure . symmetricClosure == symmetricClosure -- @-isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool-isDfsForestOf f am = case go Set.empty f of-    Just seen -> seen == vertexSet am-    Nothing   -> False-  where-    go seen []     = Just seen-    go seen (t:ts) = do-        let root = rootLabel t-        guard $ root `Set.notMember` seen-        guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ]-        newSeen <- go (Set.insert root seen) (subForest t)-        guard $ postSet root am `Set.isSubsetOf` newSeen-        go newSeen ts+symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+symmetricClosure m = overlay m (transpose m) --- | Check if a given list of vertices is a correct /topological sort/ of a graph.+-- | Compute the /transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @--- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True--- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False--- isTopSortOf []      (1 * 2 + 3 * 1) == False--- isTopSortOf []      'empty'           == True--- isTopSortOf [x]     ('vertex' x)      == True--- isTopSortOf [x]     ('edge' x x)      == False+-- transitiveClosure 'empty'               == 'empty'+-- transitiveClosure ('vertex' x)          == 'vertex' x+-- transitiveClosure ('edge' x y)          == 'edge' x y+-- transitiveClosure ('path' $ 'Data.List.nub' xs)     == 'clique' ('Data.List.nub' xs)+-- transitiveClosure . transitiveClosure == transitiveClosure -- @-isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool-isTopSortOf xs m = go Set.empty xs+transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+transitiveClosure old+    | old == new = old+    | otherwise  = transitiveClosure new   where-    go seen []     = seen == Map.keysSet (adjacencyMap m)-    go seen (v:vs) = postSet v m `Set.intersection` newSeen == Set.empty-                  && go newSeen vs-      where-        newSeen = Set.insert v seen+    new = overlay old (old `compose` old)

@@ -0,0 +1,235 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.AdjacencyMap.Algorithm+-- Copyright  : (c) Andrey Mokhov 2016-2018+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : unstable+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module provides basic graph algorithms, such as /depth-first search/,+-- implemented for the "Algebra.Graph.AdjacencyMap" data type.+-----------------------------------------------------------------------------+module Algebra.Graph.AdjacencyMap.Algorithm (+    -- * Algorithms+    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc,++    -- * Correctness properties+    isDfsForestOf, isTopSortOf+    ) where++import Control.Monad+import Data.Foldable (toList)+import Data.Maybe+import Data.Tree++import Algebra.Graph.AdjacencyMap++import qualified Algebra.Graph.AdjacencyMap.Internal as AM+import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty+import qualified Data.Graph                          as KL+import qualified Data.Graph.Typed                    as Typed+import qualified Data.Map.Strict                     as Map+import qualified Data.Set                            as Set++-- | Compute the /depth-first search/ forest of a graph that corresponds to+-- searching from each of the graph vertices in the 'Ord' @a@ order.+--+-- @+-- dfsForest 'empty'                       == []+-- 'forest' (dfsForest $ 'edge' 1 1)         == 'vertex' 1+-- 'forest' (dfsForest $ 'edge' 1 2)         == 'edge' 1 2+-- 'forest' (dfsForest $ 'edge' 2 1)         == 'vertices' [1,2]+-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True+-- 'isDfsForestOf' (dfsForest x) x         == True+-- dfsForest . 'forest' . dfsForest        == dfsForest+-- dfsForest ('vertices' vs)               == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs)+-- 'dfsForestFrom' ('vertexList' x) x        == dfsForest x+-- dfsForest $ 3 * (1 + 4) * (1 + 5)     == [ Node { rootLabel = 1+--                                                 , subForest = [ Node { rootLabel = 5+--                                                                      , subForest = [] }]}+--                                          , Node { rootLabel = 3+--                                                 , subForest = [ Node { rootLabel = 4+--                                                                      , subForest = [] }]}]+-- @+dfsForest :: Ord a => AdjacencyMap a -> Forest a+dfsForest g = dfsForestFrom (vertexList g) g++-- | Compute the /depth-first search/ forest of a graph, searching from each of+-- the given vertices in order. Note that the resulting forest does not+-- necessarily span the whole graph, as some vertices may be unreachable.+--+-- @+-- dfsForestFrom vs 'empty'                           == []+-- 'forest' (dfsForestFrom [1]   $ 'edge' 1 1)          == 'vertex' 1+-- 'forest' (dfsForestFrom [1]   $ 'edge' 1 2)          == 'edge' 1 2+-- 'forest' (dfsForestFrom [2]   $ 'edge' 1 2)          == 'vertex' 2+-- 'forest' (dfsForestFrom [3]   $ 'edge' 1 2)          == 'empty'+-- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2)          == 'vertices' [1,2]+-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x     == True+-- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True+-- dfsForestFrom ('vertexList' x) x                   == 'dfsForest' x+-- dfsForestFrom vs             ('vertices' vs)       == 'map' (\\v -> Node v []) ('Data.List.nub' vs)+-- dfsForestFrom []             x                   == []+-- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5)      == [ Node { rootLabel = 1+--                                                            , subForest = [ Node { rootLabel = 5+--                                                                                 , subForest = [] }+--                                                     , Node { rootLabel = 4+--                                                            , subForest = [] }]+-- @+dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a+dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap++-- | Compute the list of vertices visited by the /depth-first search/ in a+-- graph, when searching from each of the given vertices in order.+--+-- @+-- dfs vs    $ 'empty'                    == []+-- dfs [1]   $ 'edge' 1 1                 == [1]+-- dfs [1]   $ 'edge' 1 2                 == [1,2]+-- dfs [2]   $ 'edge' 1 2                 == [2]+-- dfs [3]   $ 'edge' 1 2                 == []+-- dfs [1,2] $ 'edge' 1 2                 == [1,2]+-- dfs [2,1] $ 'edge' 1 2                 == [2,1]+-- dfs []    $ x                        == []+-- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4]+-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True+-- @+dfs :: Ord a => [a] -> AdjacencyMap a -> [a]+dfs vs = concatMap flatten . dfsForestFrom vs++-- | Compute the list of vertices that are /reachable/ from a given source+-- vertex in a graph. The vertices in the resulting list appear in the+-- /depth-first order/.+--+-- @+-- reachable x $ 'empty'                       == []+-- reachable 1 $ 'vertex' 1                    == [1]+-- reachable 1 $ 'vertex' 2                    == []+-- reachable 1 $ 'edge' 1 1                    == [1]+-- reachable 1 $ 'edge' 1 2                    == [1,2]+-- reachable 4 $ 'path'    [1..8]              == [4..8]+-- reachable 4 $ 'circuit' [1..8]              == [4..8] ++ [1..3]+-- reachable 8 $ 'clique'  [8,7..1]            == [8] ++ [1..7]+-- 'isSubgraphOf' ('vertices' $ reachable x y) y == True+-- @+reachable :: Ord a => a -> AdjacencyMap a -> [a]+reachable x = dfs [x]++-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph+-- is cyclic.+--+-- @+-- topSort (1 * 2 + 3 * 1)               == Just [3,1,2]+-- topSort (1 * 2 + 2 * 1)               == Nothing+-- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Just False+-- 'isJust' . topSort                      == 'isAcyclic'+-- @+topSort :: Ord a => AdjacencyMap a -> Maybe [a]+topSort m = if isTopSortOf result m then Just result else Nothing+  where+    result = Typed.topSort (Typed.fromAdjacencyMap m)++-- | Check if a given graph is /acyclic/.+--+-- @+-- isAcyclic (1 * 2 + 3 * 1) == True+-- isAcyclic (1 * 2 + 2 * 1) == False+-- isAcyclic . 'circuit'       == 'null'+-- isAcyclic                 == 'isJust' . 'topSort'+-- @+isAcyclic :: Ord a => AdjacencyMap a -> Bool+isAcyclic = isJust . topSort++-- TODO: Benchmark and optimise.+-- | Compute the /condensation/ of a graph, where each vertex corresponds to a+-- /strongly-connected component/ of the original graph. Note that component+-- graphs are non-empty, and are therefore of type+-- "Algebra.Graph.NonEmpty.AdjacencyMap".+--+-- @+-- scc 'empty'               == 'empty'+-- scc ('vertex' x)          == 'vertex' (NonEmpty.'NonEmpty.vertex' x)+-- scc ('edge' 1 1)          == 'vertex' (NonEmpty.'NonEmpty.edge' 1 1)+-- scc ('edge' 1 2)          == 'edge'   (NonEmpty.'NonEmpty.vertex' 1) (NonEmpty.'NonEmpty.vertex' 2)+-- scc ('circuit' (1:xs))    == 'vertex' (NonEmpty.'NonEmpty.circuit1' (1 'Data.List.NonEmpty.:|' xs))+-- scc (3 * 1 * 4 * 1 * 5) == 'edges'  [ (NonEmpty.'NonEmpty.vertex'  3      , NonEmpty.'NonEmpty.vertex'  5      )+--                                   , (NonEmpty.'NonEmpty.vertex'  3      , NonEmpty.'NonEmpty.clique1' [1,4,1])+--                                   , (NonEmpty.'NonEmpty.clique1' [1,4,1], NonEmpty.'NonEmpty.vertex'  5      ) ]+-- 'isAcyclic' . scc == 'const' True+-- 'isAcyclic' x     == (scc x == 'gmap' NonEmpty.'NonEmpty.vertex' x)+-- @+scc :: Ord a => AdjacencyMap a -> AdjacencyMap (NonEmpty.AdjacencyMap a)+scc m = gmap (component Map.!) $ removeSelfLoops $ gmap (leader Map.!) m+  where+    Typed.GraphKL g decode _ = Typed.fromAdjacencyMap m+    sccs      = map toList (KL.scc g)+    leader    = Map.fromList [ (decode y, x)      | x:xs <- sccs, y <- x:xs ]+    component = Map.fromList [ (x, expand (x:xs)) | x:xs <- sccs ]+    expand xs = fromJust $ NonEmpty.toNonEmpty $ induce (`Set.member` s) m+      where+        s = Set.fromList (map decode xs)++-- Remove all self loops from a graph.+removeSelfLoops :: Ord a => AdjacencyMap a -> AdjacencyMap a+removeSelfLoops (AM.AM m) = AM.AM (Map.mapWithKey Set.delete m)++-- | Check if a given forest is a correct /depth-first search/ forest of a graph.+-- The implementation is based on the paper "Depth-First Search and Strong+-- Connectivity in Coq" by François Pottier.+--+-- @+-- isDfsForestOf []                              'empty'            == True+-- isDfsForestOf []                              ('vertex' 1)       == False+-- isDfsForestOf [Node 1 []]                     ('vertex' 1)       == True+-- isDfsForestOf [Node 1 []]                     ('vertex' 2)       == False+-- isDfsForestOf [Node 1 [], Node 1 []]          ('vertex' 1)       == False+-- isDfsForestOf [Node 1 []]                     ('edge' 1 1)       == True+-- isDfsForestOf [Node 1 []]                     ('edge' 1 2)       == False+-- isDfsForestOf [Node 1 [], Node 2 []]          ('edge' 1 2)       == False+-- isDfsForestOf [Node 2 [], Node 1 []]          ('edge' 1 2)       == True+-- isDfsForestOf [Node 1 [Node 2 []]]            ('edge' 1 2)       == True+-- isDfsForestOf [Node 1 [], Node 2 []]          ('vertices' [1,2]) == True+-- isDfsForestOf [Node 2 [], Node 1 []]          ('vertices' [1,2]) == True+-- isDfsForestOf [Node 1 [Node 2 []]]            ('vertices' [1,2]) == False+-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]]   ('path' [1,2,3])   == True+-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]]   ('path' [1,2,3])   == False+-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3])   == True+-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3])   == True+-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3])   == False+-- @+isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool+isDfsForestOf f am = case go Set.empty f of+    Just seen -> seen == vertexSet am+    Nothing   -> False+  where+    go seen []     = Just seen+    go seen (t:ts) = do+        let root = rootLabel t+        guard $ root `Set.notMember` seen+        guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ]+        newSeen <- go (Set.insert root seen) (subForest t)+        guard $ postSet root am `Set.isSubsetOf` newSeen+        go newSeen ts++-- | Check if a given list of vertices is a correct /topological sort/ of a graph.+--+-- @+-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True+-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False+-- isTopSortOf []      (1 * 2 + 3 * 1) == False+-- isTopSortOf []      'empty'           == True+-- isTopSortOf [x]     ('vertex' x)      == True+-- isTopSortOf [x]     ('edge' x x)      == False+-- @+isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool+isTopSortOf xs m = go Set.empty xs+  where+    go seen []     = seen == Map.keysSet (adjacencyMap m)+    go seen (v:vs) = postSet v m `Set.intersection` newSeen == Set.empty+                  && go newSeen vs+      where+        newSeen = Set.insert v seen

@@ -12,16 +12,19 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap.Internal (     -- * Adjacency map implementation-    AdjacencyMap (..), empty, vertex, overlay, connect, fromAdjacencySets,-    consistent+    AdjacencyMap (..), consistent, internalEdgeList, referredToVertexSet   ) where +import Prelude ()+import Prelude.Compat hiding (null)++import Control.DeepSeq+import Data.Foldable (foldMap) import Data.List import Data.Map.Strict (Map, keysSet, fromSet)+import Data.Monoid import Data.Set (Set) -import Control.DeepSeq (NFData (..))- import qualified Data.Map.Strict as Map import qualified Data.Set        as Set @@ -35,6 +38,14 @@     > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))     > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num',+which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as+additive and multiplicative identities, and 'negate' as additive inverse.+Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when+working with algebraic graphs; we hope that in future Haskell's Prelude will+provide a more fine-grained class hierarchy for algebraic structures, which we+would be able to utilise without violating any laws.+ The 'Show' instance is defined using basic graph construction primitives:  @show (empty     :: AdjacencyMap Int) == "empty"@@ -84,128 +95,88 @@  When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively.++The total order on graphs is defined using /size-lexicographic/ comparison:++* Compare the number of vertices. In case of a tie, continue.+* Compare the sets of vertices. In case of a tie, continue.+* Compare the number of edges. In case of a tie, continue.+* Compare the sets of edges.++Here are a few examples:++@'Algebra.Graph.AdjacencyMap.vertex' 1 < 'Algebra.Graph.AdjacencyMap.vertex' 2+'Algebra.Graph.AdjacencyMap.vertex' 3 < 'Algebra.Graph.AdjacencyMap.edge' 1 2+'Algebra.Graph.AdjacencyMap.vertex' 1 < 'Algebra.Graph.AdjacencyMap.edge' 1 1+'Algebra.Graph.AdjacencyMap.edge' 1 1 < 'Algebra.Graph.AdjacencyMap.edge' 1 2+'Algebra.Graph.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.AdjacencyMap.edge' 1 1 + 'Algebra.Graph.AdjacencyMap.edge' 2 2+'Algebra.Graph.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.AdjacencyMap.edge' 1 3@++Note that the resulting order refines the 'Algebra.Graph.AdjacencyMap.isSubgraphOf'+relation and is compatible with 'Algebra.Graph.AdjacencyMap.overlay' and+'Algebra.Graph.AdjacencyMap.connect' operations:++@'Algebra.Graph.AdjacencyMap.isSubgraphOf' x y ==> x <= y@++@'Algebra.Graph.AdjacencyMap.empty' <= x+x     <= x + y+x + y <= x * y@ -} newtype AdjacencyMap a = AM {-    -- | The /adjacency map/ of the graph: each vertex is associated with a set-    -- of its direct successors. Complexity: /O(1)/ time and memory.+    -- | The /adjacency map/ of a graph: each vertex is associated with a set of+    -- its direct successors. Complexity: /O(1)/ time and memory.     --     -- @-    -- adjacencyMap 'empty'      == Map.'Map.empty'-    -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty'+    -- adjacencyMap 'Algebra.Graph.AdjacencyMap.empty'      == Map.'Map.empty'+    -- adjacencyMap ('Algebra.Graph.AdjacencyMap.vertex' x) == Map.'Map.singleton' x Set.'Set.empty'     -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1)     -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')]     -- @     adjacencyMap :: Map a (Set a) } deriving Eq +instance Ord a => Ord (AdjacencyMap a) where+    compare (AM x) (AM y) = mconcat+        [ compare (vNum x) (vNum y)+        , compare (vSet x) (vSet y)+        , compare (eNum x) (eNum y)+        , compare       x        y ]+      where+        vNum = Map.size+        vSet = Map.keysSet+        eNum = getSum . foldMap (Sum . Set.size)+ instance (Ord a, Show a) => Show (AdjacencyMap a) where-    show (AM m)-        | null vs    = "empty"-        | null es    = vshow vs-        | vs == used = eshow es-        | otherwise  = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")"+    showsPrec p (AM m)+        | null vs    = showString "empty"+        | null es    = showParen (p > 10) $ vshow vs+        | vs == used = showParen (p > 10) $ eshow es+        | otherwise  = showParen (p > 10) $+                           showString "overlay (" . vshow (vs \\ used) .+                           showString ") (" . eshow es . showString ")"       where         vs             = Set.toAscList (keysSet m)         es             = internalEdgeList m-        vshow [x]      = "vertex "   ++ show x-        vshow xs       = "vertices " ++ show xs-        eshow [(x, y)] = "edge "     ++ show x ++ " " ++ show y-        eshow xs       = "edges "    ++ show xs+        vshow [x]      = showString "vertex "   . showsPrec 11 x+        vshow xs       = showString "vertices " . showsPrec 11 xs+        eshow [(x, y)] = showString "edge "     . showsPrec 11 x .+                         showString " "         . showsPrec 11 y+        eshow xs       = showString "edges "    . showsPrec 11 xs         used           = Set.toAscList (referredToVertexSet m) --- | Construct the /empty graph/.--- Complexity: /O(1)/ time and memory.------ @--- 'Algebra.Graph.AdjacencyMap.isEmpty'     empty == True--- 'Algebra.Graph.AdjacencyMap.hasVertex' x empty == False--- 'Algebra.Graph.AdjacencyMap.vertexCount' empty == 0--- 'Algebra.Graph.AdjacencyMap.edgeCount'   empty == 0--- @-empty :: AdjacencyMap a-empty = AM Map.empty-{-# NOINLINE [1] empty #-}---- | Construct the graph comprising /a single isolated vertex/.--- Complexity: /O(1)/ time and memory.------ @--- 'Algebra.Graph.AdjacencyMap.isEmpty'     (vertex x) == False--- 'Algebra.Graph.AdjacencyMap.hasVertex' x (vertex x) == True--- 'Algebra.Graph.AdjacencyMap.vertexCount' (vertex x) == 1--- 'Algebra.Graph.AdjacencyMap.edgeCount'   (vertex x) == 0--- @-vertex :: a -> AdjacencyMap a-vertex x = AM $ Map.singleton x Set.empty-{-# NOINLINE [1] vertex #-}---- | /Overlay/ two graphs. This is a commutative, associative and idempotent--- operation with the identity 'empty'.--- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.------ @--- 'Algebra.Graph.AdjacencyMap.isEmpty'     (overlay x y) == 'Algebra.Graph.AdjacencyMap.isEmpty'   x   && 'Algebra.Graph.AdjacencyMap.isEmpty'   y--- 'Algebra.Graph.AdjacencyMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyMap.hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y--- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.vertexCount' x--- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y--- 'Algebra.Graph.AdjacencyMap.edgeCount'   (overlay x y) >= 'Algebra.Graph.AdjacencyMap.edgeCount' x--- 'Algebra.Graph.AdjacencyMap.edgeCount'   (overlay x y) <= 'Algebra.Graph.AdjacencyMap.edgeCount' x   + 'Algebra.Graph.AdjacencyMap.edgeCount' y--- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay 1 2) == 2--- 'Algebra.Graph.AdjacencyMap.edgeCount'   (overlay 1 2) == 0--- @-overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a-overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y)-{-# NOINLINE [1] overlay #-}---- | /Connect/ two graphs. This is an associative operation with the identity--- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.--- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the--- number of edges in the resulting graph is quadratic with respect to the number--- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.------ @--- 'isEmpty'     (connect x y) == 'isEmpty'   x   && 'Algebra.Graph.AdjacencyMap.isEmpty'   y--- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y--- 'vertexCount' (connect x y) >= 'vertexCount' x--- 'vertexCount' (connect x y) <= 'vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y--- 'edgeCount'   (connect x y) >= 'edgeCount' x--- 'edgeCount'   (connect x y) >= 'edgeCount' y--- 'edgeCount'   (connect x y) >= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y--- 'edgeCount'   (connect x y) <= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y + 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y--- 'vertexCount' (connect 1 2) == 2--- 'edgeCount'   (connect 1 2) == 1--- @-connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a-connect x y = AM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y,-    fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ]-{-# NOINLINE [1] connect #-}-+-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap'+-- for more details. instance (Ord a, Num a) => Num (AdjacencyMap a) where-    fromInteger = vertex . fromInteger-    (+)         = overlay-    (*)         = connect-    signum      = const empty-    abs         = id-    negate      = id+    fromInteger x = AM $ Map.singleton (fromInteger x) Set.empty+    x + y  = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y)+    x * y  = AM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y,+        fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ]+    signum = const (AM Map.empty)+    abs    = id+    negate = id  instance NFData a => NFData (AdjacencyMap a) where     rnf (AM a) = rnf a --- | Construct a graph from a list of adjacency sets.--- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.------ @--- fromAdjacencySets []                                        == 'Algebra.Graph.AdjacencyMap.empty'--- fromAdjacencySets [(x, Set.'Set.empty')]                          == 'Algebra.Graph.AdjacencyMap.vertex' x--- fromAdjacencySets [(x, Set.'Set.singleton' y)]                    == 'Algebra.Graph.AdjacencyMap.edge' x y--- fromAdjacencySets . map (fmap Set.'Set.fromList') . 'Algebra.Graph.AdjacencyMap.adjacencyList' == id--- 'Algebra.Graph.AdjacencyMap.overlay' (fromAdjacencySets xs) (fromAdjacencySets ys)       == fromAdjacencySets (xs ++ ys)--- @-fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a-fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es-  where-    vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss-    es = Map.fromListWith Set.union ss- -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices. It should be impossible to create an -- inconsistent adjacency map, and we use this function in testing.@@ -223,10 +194,12 @@ consistent :: Ord a => AdjacencyMap a -> Bool consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` keysSet m --- The set of vertices that are referred to by the edges-referredToVertexSet :: Ord a => Map a (Set a) -> Set a-referredToVertexSet = Set.fromList . uncurry (++) . unzip . internalEdgeList---- The list of edges in adjacency map+-- | The list of edges of an adjacency map.+-- /Note: this function is for internal use only/. internalEdgeList :: Map a (Set a) -> [(a, a)] internalEdgeList m = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]++-- | The set of vertices that are referred to by the edges of an adjacency map.+-- /Note: this function is for internal use only/.+referredToVertexSet :: Ord a => Map a (Set a) -> Set a+referredToVertexSet = Set.fromList . uncurry (++) . unzip . internalEdgeList

@@ -44,20 +44,24 @@     isSubgraphOf,      -- * Standard families of graphs-    path, circuit, clique, biclique, star, starTranspose, tree, forest-  ) where+    path, circuit, clique, biclique, star, tree, forest+    ) where  import Prelude () import Prelude.Compat  import Data.Tree -import qualified Algebra.Graph                 as G-import qualified Algebra.Graph.AdjacencyMap    as AM-import qualified Algebra.Graph.Fold            as F-import qualified Algebra.Graph.AdjacencyIntMap as AIM-import qualified Algebra.Graph.Relation        as R+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+import qualified Algebra.Graph.Relation              as R+ {-| The core type class for constructing algebraic graphs, characterised by the following minimal set of axioms. In equations we use @+@ and @*@ as convenient@@ -145,6 +149,20 @@     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+    vertex  = LAM.vertex+    overlay = LAM.overlay+    connect = LAM.connect one+ instance Ord a => Graph (R.Relation a) where     type Vertex (R.Relation a) = a     empty   = R.empty@@ -405,21 +423,6 @@ star x [] = vertex x star x ys = connect (vertex x) (vertices ys) --- | The /star transpose/ formed by a list of leaves connected to a centre vertex.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- given list.------ @--- starTranspose x []    == 'vertex' x--- starTranspose x [y]   == 'edge' y x--- starTranspose x [y,z] == 'edges' [(y,x), (z,x)]--- starTranspose x ys    == 'connect' ('vertices' ys) ('vertex' x)--- starTranspose x ys    == transpose ('star' x ys)--- @-starTranspose :: Graph g => Vertex g -> [Vertex g] -> g-starTranspose x [] = vertex x-starTranspose x ys = connect (vertices ys) (vertex x)- -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the -- given tree (i.e. the number of vertices in the tree).@@ -443,7 +446,7 @@ -- forest []                                                  == 'empty' -- forest [x]                                                 == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)]--- forest                                                     == 'overlays' . map 'tree'+-- forest                                                     == 'overlays' . 'map' 'tree' -- @ forest :: Graph g => Forest (Vertex g) -> g forest = overlays . map tree

@@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Export (     -- * Constructing and exporting documents-    Doc, literal, render,+    Doc, isEmpty, literal, render,      -- * Common combinators for text documents     (<+>), brackets, doubleQuotes, indent, unlines,@@ -39,26 +39,56 @@ -- | An abstract document data type with /O(1)/ time concatenation (the current -- implementation uses difference lists). Here @s@ is the type of abstract -- symbols or strings (text or binary). 'Doc' @s@ is a 'Monoid', therefore--- 'mempty' corresponds to the empty document and two documents can be+-- 'mempty' corresponds to the /empty document/ and two documents can be -- concatenated with 'mappend' (or operator 'Data.Monoid.<>'). Documents -- comprising a single symbol or string can be constructed using the function--- 'literal'. Alternatively, you can construct documents as string literals, e.g.--- simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To extract--- the document contents use the function 'render'. See some examples below.+-- 'literal'. Alternatively, you can construct documents as string literals,+-- e.g. simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To+-- extract the document contents use the function 'render'.+--+-- Note that the document comprising a single empty string is considered to be+-- different from the empty document. This design choice is motivated by the+-- desire to support string types @s@ that have no 'Eq' instance, such as+-- "Data.ByteString.Builder", for which there is no way to check whether a+-- string is empty or not. As a consequence, the 'Eq' and 'Ord' instances are+-- defined as follows:+--+-- @+-- 'mempty' /= 'literal' ""+-- 'mempty' <  'literal' ""+-- @ newtype Doc s = Doc (List s) deriving (Monoid, Semigroup)  instance (Monoid s, Show s) => Show (Doc s) where     show = show . render  instance (Monoid s, Eq s) => Eq (Doc s) where-    x == y = render x == render y+    x == y | isEmpty x = isEmpty y+           | isEmpty y = False+           | otherwise = render x == render y +-- | The empty document is smallest. instance (Monoid s, Ord s) => Ord (Doc s) where-    compare x y = compare (render x) (render y)+    compare x y | isEmpty x = if isEmpty y then EQ else LT+                | isEmpty y = GT+                | otherwise = compare (render x) (render y)  instance IsString s => IsString (Doc s) where     fromString = literal . fromString +-- | Check if a document is empty. The result is the same as when comparing the+-- given document to 'mempty', but this function does not require the 'Eq' @s@+-- constraint. Note that the document comprising a single empty string is+-- considered to be different from the empty document.+--+-- @+-- isEmpty 'mempty'       == True+-- isEmpty ('literal' \"\") == False+-- isEmpty x            == (x == 'mempty')+-- @+isEmpty :: Doc s -> Bool+isEmpty (Doc xs) = null xs+ -- | Construct a document comprising a single symbol or string. If @s@ is an -- instance of class 'IsString', then documents of type 'Doc' @s@ can be -- constructed directly from string literals (see the second example below).@@ -66,9 +96,7 @@ -- @ -- literal "Hello, " 'Data.Monoid.<>' literal "World!" == literal "Hello, World!" -- literal "I am just a string literal"  == "I am just a string literal"--- literal 'mempty'                        == 'mempty' -- 'render' . literal                      == 'id'--- literal . 'render'                      == 'id' -- @ literal :: s -> Doc s literal = Doc . pure@@ -80,7 +108,6 @@ -- render ('literal' "al" 'Data.Monoid.<>' 'literal' "ga") == "alga" -- render 'mempty'                         == 'mempty' -- render . 'literal'                      == 'id'--- 'literal' . render                      == 'id' -- @ render :: Monoid s => Doc s -> s render (Doc x) = fold x@@ -94,10 +121,10 @@ -- x \<+\> (y \<+\> z)      == (x \<+\> y) \<+\> z -- "name" \<+\> "surname" == "name surname" -- @-(<+>) :: (Eq s, IsString s, Monoid s) => Doc s -> Doc s -> Doc s-x <+> y | x == mempty = y-        | y == mempty = x-        | otherwise   = x <> " " <> y+(<+>) :: IsString s => Doc s -> Doc s -> Doc s+x <+> y | isEmpty x = y+        | isEmpty y = x+        | otherwise = x <> " " <> y  infixl 7 <+> 

@@ -43,8 +43,8 @@ data Style a s = Style     { graphName :: s     -- ^ Name of the graph.-    , preamble :: s-    -- ^ Preamble is added at the beginning of the DOT file body.+    , preamble :: [s]+    -- ^ Preamble (a list of lines) is added at the beginning of the DOT file body.     , graphAttributes :: [Attribute s]     -- ^ Graph style, e.g. @["bgcolor" := "azure"]@.     , defaultVertexAttributes :: [Attribute s]@@ -62,7 +62,7 @@ -- | Default style for exporting graphs. All style settings are empty except for -- 'vertexName', which is provided as the only argument. defaultStyle :: Monoid s => (a -> s) -> Style a s-defaultStyle v = Style mempty mempty [] [] [] v (\_ -> []) (\_ _ -> [])+defaultStyle v = Style mempty [] [] [] [] v (\_ -> []) (\_ _ -> [])  -- | Default style for exporting graphs whose vertices are 'Show'-able. All -- style settings are empty except for 'vertexName', which is computed from@@ -82,7 +82,7 @@ -- style :: 'Style' Int String -- style = 'Style' --     { 'graphName'               = \"Example\"---     , 'preamble'                = "  // This is an example\\n"+--     , 'preamble'                = ["  // This is an example", ""] --     , 'graphAttributes'         = ["label" := \"Example\", "labelloc" := "top"] --     , 'defaultVertexAttributes' = ["shape" := "circle"] --     , 'defaultEdgeAttributes'   = 'mempty'@@ -109,14 +109,14 @@ --   "v4" -> "v5" -- } -- @-export :: (IsString s, Monoid s, Eq s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s+export :: (IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s export Style {..} g = render $ header <> body <> "}\n"   where     header    = "digraph" <+> literal graphName <> "\n{\n"-             <> if preamble == mempty then mempty else literal preamble <> "\n"-    with x as = if null as            then mempty else line (x <+> attributes as)+    with x as = if null as then mempty else line (x <+> attributes as)     line s    = indent 2 s <> "\n"-    body      = ("graph" `with` graphAttributes)+    body      = unlines (map literal preamble)+             <> ("graph" `with` graphAttributes)              <> ("node"  `with` defaultVertexAttributes)              <> ("edge"  `with` defaultEdgeAttributes)              <> E.export vDoc eDoc g@@ -150,7 +150,7 @@ --   "c" -> "a" -- } -- @-exportAsIs :: (IsString s, Monoid s, Ord s, ToGraph g, ToVertex g ~ s) => g -> s+exportAsIs :: (IsString s, Monoid s, Ord (ToVertex g), ToGraph g, ToVertex g ~ s) => g -> s exportAsIs = export (defaultStyle id)  -- | Export a graph using the 'defaultStyleViaShow'.@@ -170,5 +170,5 @@ --   "2" -> "4" -- } -- @-exportViaShow :: (IsString s, Monoid s, Eq s, ToGraph g, Ord (ToVertex g), Show (ToVertex g)) => g -> s+exportViaShow :: (IsString s, Monoid s, Ord (ToVertex g), Show (ToVertex g), ToGraph g) => g -> s exportViaShow = export defaultStyleViaShow

@@ -33,19 +33,19 @@      -- * Graph properties     isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList,-    edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList,+    edgeList, vertexSet, edgeSet, adjacencyList,      -- * Standard families of graphs     path, circuit, clique, biclique, star, stars,      -- * Graph transformation     removeVertex, removeEdge, transpose, induce, simplify,-  ) where+    ) where  import Prelude () import Prelude.Compat -import Control.Applicative (Alternative, liftA2)+import Control.Applicative (Alternative) import Control.Monad.Compat (MonadPlus (..), ap) import Data.Function @@ -57,7 +57,6 @@ import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.ToGraph      as T import qualified Control.Applicative        as Ap-import qualified Data.IntSet                as IntSet import qualified Data.Set                   as Set  {-| The 'Fold' data type is the Boehm-Berarducci encoding of the core graph@@ -70,6 +69,14 @@     > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))     > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num',+which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as+additive and multiplicative identities, and 'negate' as additive inverse.+Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when+working with algebraic graphs; we hope that in future Haskell's Prelude will+provide a more fine-grained class hierarchy for algebraic structures, which we+would be able to utilise without violating any laws.+ The 'Show' instance is defined using basic graph construction primitives:  @show (empty     :: Fold Int) == "empty"@@ -125,36 +132,61 @@ m == 'edgeCount' g s == 'size' g@ -Note that 'size' is slightly different from the 'length' method of the-'Foldable' type class, as the latter does not count 'empty' leaves of the-expression:--@'length' 'empty'           == 0-'size'   'empty'           == 1-'length' ('vertex' x)      == 1-'size'   ('vertex' x)      == 1-'length' ('empty' + 'empty') == 0-'size'   ('empty' + 'empty') == 2@+Note that 'size' counts all leaves of the expression: -The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@-corresponds to the number of occurrences of 'empty' in an expression @g@.+@'vertexCount' 'empty'           == 0+'size'        'empty'           == 1+'vertexCount' ('vertex' x)      == 1+'size'        ('vertex' x)      == 1+'vertexCount' ('empty' + 'empty') == 0+'size'        ('empty' + 'empty') == 2@  Converting a 'Fold' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the complexity of the graph equality test, because it is currently implemented by converting graph expressions to canonical representations based on adjacency maps.++The total order on graphs is defined using /size-lexicographic/ comparison:++* Compare the number of vertices. In case of a tie, continue.+* Compare the sets of vertices. In case of a tie, continue.+* Compare the number of edges. In case of a tie, continue.+* Compare the sets of edges.++Here are a few examples:++@'vertex' 1 < 'vertex' 2+'vertex' 3 < 'edge' 1 2+'vertex' 1 < 'edge' 1 1+'edge' 1 1 < 'edge' 1 2+'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2+'edge' 1 2 < 'edge' 1 3@++Note that the resulting order refines the 'isSubgraphOf' relation and is+compatible with 'overlay' and 'connect' operations:++@'isSubgraphOf' x y ==> x <= y@++@'empty' <= x+x     <= x + y+x + y <= x * y@ -} newtype Fold a = Fold { runFold :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b }  instance (Ord a, Show a) => Show (Fold a) where-    show = show . foldg AM.empty AM.vertex AM.overlay AM.connect+    showsPrec p = showsPrec p . foldg AM.empty AM.vertex AM.overlay AM.connect  instance Ord a => Eq (Fold a) where-    x == y = T.adjacencyMap x == T.adjacencyMap y+    x == y = T.toAdjacencyMap x == T.toAdjacencyMap y +instance Ord a => Ord (Fold a) where+    compare x y = compare (T.toAdjacencyMap x) (T.toAdjacencyMap y)+ instance NFData a => NFData (Fold a) where     rnf = foldg () rnf seq seq +-- | __Note:__ this does not satisfy the usual ring laws; see 'Fold' for more+-- details. instance Num a => Num (Fold a) where     fromInteger = vertex . fromInteger     (+)         = overlay@@ -182,12 +214,6 @@     return = vertex     g >>=f = foldg empty f overlay connect g -instance Foldable Fold where-    foldMap f = foldg mempty f mappend mappend--instance Traversable Fold where-    traverse f = foldg (pure empty) (fmap vertex . f) (liftA2 overlay) (liftA2 connect)- instance ToGraph (Fold a) where     type ToVertex (Fold a) = a     foldg = foldg@@ -340,11 +366,10 @@ -- -- @ -- foldg 'empty' 'vertex'        'overlay' 'connect'        == id--- foldg 'empty' 'vertex'        'overlay' (flip 'connect') == 'transpose'--- foldg []    return        (++)    (++)           == 'Data.Foldable.toList'--- foldg 0     (const 1)     (+)     (+)            == 'Data.Foldable.length'--- foldg 1     (const 1)     (+)     (+)            == 'size'--- foldg True  (const False) (&&)    (&&)           == 'isEmpty'+-- foldg 'empty' 'vertex'        'overlay' ('flip' 'connect') == 'transpose'+-- foldg 1     ('const' 1)     (+)     (+)            == 'size'+-- foldg True  ('const' False) (&&)    (&&)           == 'isEmpty'+-- foldg False (== x)        (||)    (||)           == 'hasVertex' x -- @ foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Fold a -> b foldg e v o c g = runFold g e v o c@@ -355,11 +380,12 @@ -- graph can be quadratic with respect to the expression size /s/. -- -- @--- isSubgraphOf 'empty'         x             == True--- isSubgraphOf ('vertex' x)    'empty'         == False--- isSubgraphOf x             ('overlay' x y) == True--- isSubgraphOf ('overlay' x y) ('connect' x y) == True--- isSubgraphOf ('path' xs)     ('circuit' xs)  == True+-- isSubgraphOf 'empty'         x             ==  True+-- isSubgraphOf ('vertex' x)    'empty'         ==  False+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf ('path' xs)     ('circuit' xs)  ==  True+-- isSubgraphOf x y                         ==> x <= y -- @ isSubgraphOf :: Ord a => Fold a -> Fold a -> Bool isSubgraphOf x y = overlay x y == y@@ -392,14 +418,14 @@ size :: Fold a -> Int size = T.size --- | Check if a graph contains a given vertex. A convenient alias for `elem`.+-- | 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 x . 'removeVertex' x == 'const' False -- @ hasVertex :: Eq a => a -> Fold a -> Bool hasVertex = T.hasVertex@@ -411,7 +437,7 @@ -- hasEdge x y 'empty'            == False -- hasEdge x y ('vertex' z)       == False -- hasEdge x y ('edge' x y)       == True--- hasEdge x y . 'removeEdge' x y == const False+-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Eq a => a -> a -> Fold a -> Bool@@ -421,9 +447,10 @@ -- Complexity: /O(s * log(n))/ time. -- -- @--- vertexCount 'empty'      == 0--- vertexCount ('vertex' x) == 1--- vertexCount            == 'length' . 'vertexList'+-- vertexCount 'empty'             ==  0+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: Ord a => Fold a -> Int vertexCount = T.vertexCount@@ -462,7 +489,7 @@ -- edgeList ('edge' x y)     == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges'        == 'Data.List.nub' . 'Data.List.sort'--- edgeList . 'transpose'    == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList+-- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: Ord a => Fold a -> [(a, a)] edgeList = T.edgeList@@ -474,24 +501,10 @@ -- 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 --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for--- graphs with vertices of type 'Int'.--- Complexity: /O(s * log(n))/ time and /O(n)/ memory.------ @--- vertexIntSet 'empty'      == IntSet.'IntSet.empty'--- vertexIntSet . 'vertex'   == IntSet.'IntSet.singleton'--- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'--- vertexIntSet . 'clique'   == IntSet.'IntSet.fromList'--- @-vertexIntSet :: Fold Int -> IntSet.IntSet-vertexIntSet = T.vertexIntSet- -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. --@@ -604,7 +617,7 @@ -- stars [(x, [])]               == 'vertex' x -- stars [(x, [y])]              == 'edge' x y -- stars [(x, ys)]               == 'star' x ys--- stars                         == 'overlays' . map (uncurry 'star')+-- stars                         == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList'         == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @@@ -640,12 +653,12 @@ 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.@@ -656,7 +669,7 @@ -- transpose ('edge' x y)  == 'edge' y x -- transpose . transpose == id -- transpose ('box' x y)   == 'box' (transpose x) (transpose y)--- 'edgeList' . transpose  == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList'+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Fold a -> Fold a transpose = foldg empty vertex overlay (flip connect)@@ -681,8 +694,8 @@ -- /O(1)/ to be evaluated. -- -- @--- induce (const True ) x      == x--- induce (const False) x      == 'empty'+-- 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

@@ -43,31 +43,25 @@     isSubgraphOf,      -- * Graph properties-    isEmpty, hasVertex, hasEdge, vertexCount, vertexList, vertexSet, vertexIntSet,+    hasEdge,      -- * Standard families of graphs-    path, circuit, clique, biclique, star, starTranspose, tree, forest, mesh,-    torus, deBruijn,+    path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus,+    deBruijn,      -- * Graph transformation-    removeVertex, replaceVertex, mergeVertices, splitVertex, induce,--    -- * Graph composition-    box-  ) where+    removeVertex, replaceVertex, mergeVertices, splitVertex, induce+    ) where  import Prelude () import Prelude.Compat  import Control.Applicative (Alternative(empty, (<|>)))-import Control.Monad.Compat (MonadPlus, msum, mfilter)-import Data.Foldable (toList)+import Control.Monad.Compat (MonadPlus, mfilter) import Data.Tree  import qualified Algebra.Graph      as G import qualified Algebra.Graph.Fold as F-import qualified Data.IntSet        as IntSet-import qualified Data.Set           as Set  {-| The core type class for constructing algebraic graphs is defined by introducing@@ -128,7 +122,7 @@ edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' expression. -}-class (Traversable g,+class ( #if !MIN_VERSION_base(4,8,0)   Alternative g, #endif@@ -282,30 +276,6 @@ isSubgraphOf :: (Graph g, Eq (g a)) => g a -> g a -> Bool isSubgraphOf x y = overlay x y == y --- | Check if a graph is empty. A convenient alias for 'null'.--- Complexity: /O(s)/ time.------ @--- isEmpty 'empty'                       == True--- isEmpty ('overlay' 'empty' 'empty')       == True--- isEmpty ('vertex' x)                  == False--- isEmpty ('removeVertex' x $ 'vertex' x) == True--- @-isEmpty :: Graph g => g a -> Bool-isEmpty = null---- | Check if a graph contains a given vertex. A convenient alias for `elem`.--- 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, Graph g) => a -> g a -> Bool-hasVertex = elem- -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. --@@ -316,54 +286,7 @@ -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: (Eq (g a), Graph g, Ord a) => a -> a -> g a -> Bool-hasEdge u v = (edge u v `isSubgraphOf`) . induce (`elem` [u, v])---- | The number of vertices in a graph.--- Complexity: /O(s * log(n))/ time.------ @--- vertexCount 'empty'      == 0--- vertexCount ('vertex' x) == 1--- vertexCount            == 'length' . 'vertexList'--- @-vertexCount :: (Ord a, Graph g) => g a -> Int-vertexCount = length . vertexList---- | 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 g) => g a -> [a]-vertexList = Set.toAscList . vertexSet---- | 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 . 'clique'   == Set.'Set.fromList'--- @-vertexSet :: (Ord a, Graph g) => g a -> Set.Set a-vertexSet = foldr Set.insert Set.empty---- | The set of vertices of a given graph. Like 'vertexSet' but specialised for--- graphs with vertices of type 'Int'.--- Complexity: /O(s * log(n))/ time and /O(n)/ memory.------ @--- vertexIntSet 'empty'      == IntSet.'IntSet.empty'--- vertexIntSet . 'vertex'   == IntSet.'IntSet.singleton'--- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'--- vertexIntSet . 'clique'   == IntSet.'IntSet.fromList'--- @-vertexIntSet :: Graph g => g Int -> IntSet.IntSet-vertexIntSet = foldr IntSet.insert IntSet.empty+hasEdge u v = (edge u v `isSubgraphOf`) . induce (\x -> x == u || x == v)  -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the@@ -436,20 +359,22 @@ star x [] = vertex x star x ys = connect (vertex x) (vertices ys) --- | The /star transpose/ formed by a list of leaves connected to a centre vertex.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- given list.+-- | The /stars/ formed by overlaying a list of 'star's. An inverse of+-- 'adjacencyList'.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the+-- input. -- -- @--- starTranspose x []    == 'vertex' x--- starTranspose x [y]   == 'edge' y x--- starTranspose x [y,z] == 'edges' [(y,x), (z,x)]--- starTranspose x ys    == 'connect' ('vertices' ys) ('vertex' x)--- starTranspose x ys    == transpose ('star' x ys)+-- stars []                      == 'empty'+-- stars [(x, [])]               == 'vertex' x+-- stars [(x, [y])]              == 'edge' x y+-- stars [(x, ys)]               == 'star' x ys+-- stars                         == 'overlays' . 'map' ('uncurry' 'star')+-- stars . 'adjacencyList'         == id+-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @-starTranspose :: Graph g => a -> [a] -> g a-starTranspose x [] = vertex x-starTranspose x ys = connect (vertices ys) (vertex x)+stars :: Graph g => [(a, [a])] -> g a+stars = overlays . map (uncurry star)  -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the@@ -474,7 +399,7 @@ -- forest []                                                  == 'empty' -- forest [x]                                                 == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)]--- forest                                                     == 'overlays' . map 'tree'+-- forest                                                     == 'overlays' . 'map' 'tree' -- @ forest :: Graph g => Forest a -> g a forest = overlays . map tree@@ -492,7 +417,17 @@ --                           , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ] -- @ mesh :: Graph g => [a] -> [b] -> g (a, b)-mesh xs ys = path xs `box` path ys+mesh []  _   = empty+mesh _   []  = empty+mesh [x] [y] = vertex (x, y)+mesh xs  ys  = stars $  [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ipxs, (b1, b2) <- ipys ]+                     ++ [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys]+                     ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs]+  where+    lx = last xs+    ly = last ys+    ipxs = init (pairs xs)+    ipys = init (pairs ys)  -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the@@ -507,8 +442,13 @@ --                           , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ torus :: Graph g => [a] -> [b] -> g (a, b)-torus xs ys = circuit xs `box` circuit ys+torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] +-- | Auxiliary function for 'mesh' and 'torus'+pairs :: [a] -> [(a, a)]+pairs [] = []+pairs as@(x:xs) = zip as (xs ++ [x])+ -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols -- from a given alphabet. -- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the@@ -539,8 +479,8 @@ -- /O(1)/ to be evaluated. -- -- @--- induce (const True ) x      == x--- induce (const False) x      == 'empty'+-- 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@@ -578,10 +518,10 @@ -- /O(1)/ to be evaluated. -- -- @--- mergeVertices (const False) x    == id+-- mergeVertices ('const' False) x    == id -- mergeVertices (== x) y           == 'replaceVertex' x y--- mergeVertices even 1 (0 * 2)     == 1 * 1--- mergeVertices odd  1 (3 + 4 * 5) == 4 * 1+-- mergeVertices 'even' 1 (0 * 2)     == 1 * 1+-- mergeVertices 'odd'  1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Graph g => (a -> Bool) -> a -> g a -> g a mergeVertices p v = fmap $ \w -> if p w then v else w@@ -599,33 +539,3 @@ -- @ splitVertex :: (Eq a, Graph g) => a -> [a] -> g a -> g a splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w---- | Compute the /Cartesian product/ of graphs.--- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the--- sizes of the given graphs.------ @--- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\'))---                                       , ((0,\'a\'), (1,\'a\'))---                                       , ((0,\'b\'), (1,\'b\'))---                                       , ((1,\'a\'), (1,\'b\')) ]--- @--- Up to an isomorphism between the resulting vertex types, this operation--- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton--- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@--- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@.------ @--- box x y               ~~ box y x--- box x (box y z)       ~~ box (box x y) z--- box x ('overlay' y z)   == 'overlay' (box x y) (box x z)--- box x ('vertex' ())     ~~ x--- box x 'empty'           ~~ 'empty'--- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y--- 'edgeCount'   (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y--- @-box :: Graph g => g a -> g b -> g (a, b)-box x y = msum $ xs ++ ys-  where-    xs = map (\b -> fmap (,b) x) $ toList y-    ys = map (\a -> fmap (a,) y) $ toList x

@@ -16,13 +16,15 @@ -- is unstable and unsafe, and is exposed only for documentation. ----------------------------------------------------------------------------- module Algebra.Graph.Internal (-    -- * General data structures+    -- * Data structures     List (..), -    -- * Data structures for graph traversal+    -- * Graph traversal     Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, Hit (..),+    foldr1Safe, maybeF, -    foldr1Safe+    -- * Utilities+    setProduct, setProductWith   ) where  import Prelude ()@@ -30,7 +32,9 @@  import Data.Foldable import Data.Semigroup+import Data.Set (Set) +import qualified Data.Set as Set import qualified GHC.Exts as Exts  -- | An abstract list data type with /O(1)/ time concatenation (the current@@ -110,11 +114,33 @@ -- its 'Tail', i.e. the source vertex, the whole 'Edge', or 'Miss' it entirely. data Hit = Miss | Tail | Edge deriving (Eq, Ord) --- | A safe version of 'foldr1'+-- | A safe version of 'foldr1'. foldr1Safe :: (a -> a -> a) -> [a] -> Maybe a-foldr1Safe f = foldr mf Nothing-  where-    mf x m = Just (case m of-                        Nothing -> x-                        Just y  -> f x y)-{-# INLINE foldr1Safe #-}+foldr1Safe f = foldr (maybeF f) Nothing+{-# INLINE [0] foldr1Safe #-}++-- | Tragetting 'map' directly+{-# RULES+"foldr1Safe/build"+  forall k f lst.+  foldr1Safe k (map f lst) = foldr (maybeF k . f) Nothing lst+ #-}++-- | Auxiliary function that try to apply a function to a base case and a 'Maybe'+-- value and return 'Just' the result or 'Just' the base case.+maybeF :: (a -> b -> a) -> a -> Maybe b -> Maybe a+maybeF f x = Just . maybe x (f x)+{-# INLINE maybeF #-}++-- | Compute the Cartesian product of two sets.+setProduct :: Set a -> Set b -> Set (a, b)+#if MIN_VERSION_containers(0,5,11)+setProduct = Set.cartesianProduct+#else+setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- Set.toAscList y ]+#endif++-- | Compute the Cartesian product of two sets, applying a function to each+-- resulting pair.+setProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c+setProductWith f x y = Set.fromList [ f a b | a <- Set.toAscList x, b <- Set.toAscList y ]

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor, OverloadedLists #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Label@@ -15,112 +16,459 @@ -- ----------------------------------------------------------------------------- module Algebra.Graph.Label (-    -- * Type classes for edge labels-    Semilattice (..), Dioid (..),+    -- * Semirings and dioids+    Semiring (..), zero, (<+>), StarSemiring (..), Dioid,      -- * Data types for edge labels-    Distance (..)-  ) where+    NonNegative, finite, finiteWord, unsafeFinite, infinite, getFinite,+    Distance, distance, getDistance, Capacity, capacity, getCapacity,+    Count, count, getCount, PowerSet (..), Minimum, getMinimum, noMinimum,+    Path, Label, isZero, RegularExpression, +    -- * Combining edge labels+    Optimum (..), ShortestPath, AllShortestPaths, CountShortestPaths, WidestPath+    ) where+ import Prelude () import Prelude.Compat++import Control.Applicative+import Control.Monad+import Data.Maybe+import Data.Monoid (Any (..), Monoid (..), Sum (..))+import Data.Semigroup (Min (..), Max (..), Semigroup (..)) import Data.Set (Set)+import GHC.Exts (IsList (..)) +import Algebra.Graph.Internal+ import qualified Data.Set as Set -{-| A /bounded join semilattice/, satisfying the following laws:+{-| A /semiring/ extends a commutative 'Monoid' with operation '<.>' that acts+similarly to multiplication over the underlying (additive) monoid and has 'one'+as the identity. This module also provides two convenient aliases: 'zero' for+'mempty', and '<+>' for '<>', which makes the interface more uniform. -    * Commutativity:+Instances of this type class must satisfy the following semiring laws: -        > x \/ y == y \/ x+    * Associativity of '<+>' and '<.>': -    * Associativity:+        > x <+> (y <+> z) == (x <+> y) <+> z+        > x <.> (y <.> z) == (x <.> y) <.> z -        > x \/ (y \/ z) == (x \/ y) \/ z+    * Identities of '<+>' and '<.>': -    * Identity:+        > zero <+> x == x == x <+> zero+        >  one <.> x == x == x <.> one -        > x \/ zero == x+    * Commutativity of '<+>': -    * Idempotence:+        > x <+> y == y <+> x -        > x \/ x == x+    * Annihilating 'zero':++        > x <.> zero == zero+        > zero <.> x == zero++    * Distributivity:++        > x <.> (y <+> z) == x <.> y <+> x <.> z+        > (x <+> y) <.> z == x <.> z <+> y <.> z -}-class Semilattice a where-    zero :: a-    (\/) :: a -> a -> a+class (Monoid a, Semigroup a) => Semiring a where+    one   :: a+    (<.>) :: a -> a -> a -{-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following laws:+{-| A /star semiring/ is a 'Semiring' with an additional unary operator 'star'+satisfying the following two laws: -    * Associativity:+    > star a = one <+> a <.> star a+    > star a = one <+> star a <.> a+-}+class Semiring a => StarSemiring a where+    star :: a -> a -        > x /\ (y /\ z) == (x /\ y) /\ z+{-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following+/idempotence/ law in addition to the 'Semiring' laws: -    * Identity:+    > x <+> x == x+-}+class Semiring a => Dioid a -        > x /\ one == x-        > one /\ x == x+-- | An alias for 'mempty'.+zero :: Monoid a => a+zero = mempty -    * Annihilating zero:+-- | An alias for '<>'.+(<+>) :: Semigroup a => a -> a -> a+(<+>) = (<>) -        > x /\ zero == zero-        > zero /\ x == zero+infixr 6 <+>+infixr 7 <.> -    * Distributivity:+instance Semiring Any where+    one             = Any True+    Any x <.> Any y = Any (x && y) -        > x /\ (y \/ z) == x /\ y \/ x /\ z-        > (x \/ y) /\ z == x /\ z \/ y /\ z--}-class Semilattice a => Dioid a where-    one  :: a-    (/\) :: a -> a -> a+instance StarSemiring Any where+    star _ = Any True -infixl 6 \/-infixl 7 /\+instance Dioid Any -instance Semilattice Bool where-    zero = False-    (\/) = (||)+-- | A non-negative value that can be 'finite' or 'infinite'. Note: the current+-- implementation of the 'Num' instance raises an error on negative literals+-- and on the 'negate' method.+newtype NonNegative a = NonNegative (Extended a)+    deriving (Applicative, Eq, Functor, Ord, Monad) -instance Dioid Bool where-    one  = True-    (/\) = (&&)+instance (Num a, Show a) => Show (NonNegative a) where+    show (NonNegative Infinite  ) = "infinite"+    show (NonNegative (Finite x)) = show x --- | A /distance/ is a non-negative value that can be 'Finite' or 'Infinite'.-data Distance a = Finite a | Infinite deriving (Eq, Ord, Show)+instance Num a => Bounded (NonNegative a) where+    minBound = unsafeFinite 0+    maxBound = infinite -instance (Ord a, Num a) => Num (Distance a) where+instance (Num a, Ord a) => Num (NonNegative a) where+    fromInteger x | f < 0     = error "NonNegative values cannot be negative"+                  | otherwise = unsafeFinite f+      where+        f = fromInteger x++    (+) = liftA2 (+)+    (*) = liftA2 (*)++    negate _ = error "NonNegative values cannot be negated"++    signum (NonNegative Infinite) = 1+    signum x = signum <$> x++    abs = id++-- | A finite non-negative value or @Nothing@ if the argument is negative.+finite :: (Num a, Ord a) => a -> Maybe (NonNegative a)+finite x | x < 0      = Nothing+         | otherwise  = Just (unsafeFinite x)++-- | A finite 'Word'.+finiteWord :: Word -> NonNegative Word+finiteWord = unsafeFinite++-- | A non-negative finite value, created /unsafely/: the argument is not+-- checked for being non-negative, so @unsafeFinite (-1)@ compiles just fine.+unsafeFinite :: a -> NonNegative a+unsafeFinite = NonNegative . Finite++-- | The (non-negative) infinite value.+infinite :: NonNegative a+infinite = NonNegative Infinite++-- | Get a finite value or @Nothing@ if the value is infinite.+getFinite :: NonNegative a -> Maybe a+getFinite (NonNegative x) = fromExtended x++-- | A /capacity/ is a non-negative value that can be 'finite' or 'infinite'.+-- Capacities form a 'Dioid' as follows:+--+-- @+-- 'zero'  = 0+-- 'one'   = 'capacity' 'infinite'+-- ('<+>') = 'max'+-- ('<.>') = 'min'+-- @+newtype Capacity a = Capacity (Max (NonNegative a))+    deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup)++instance Show a => Show (Capacity a) where+    show (Capacity (Max (NonNegative (Finite x)))) = show x+    show _ = "capacity infinite"++instance (Num a, Ord a) => Semiring (Capacity a) where+    one   = capacity infinite+    (<.>) = min++instance (Num a, Ord a) => StarSemiring (Capacity a) where+    star _ = one++instance (Num a, Ord a) => Dioid (Capacity a)++-- | A non-negative capacity.+capacity :: NonNegative a -> Capacity a+capacity = Capacity . Max++-- | Get the value of a capacity.+getCapacity :: Capacity a -> NonNegative a+getCapacity (Capacity (Max x)) = x++-- | A /count/ is a non-negative value that can be 'finite' or 'infinite'.+-- Counts form a 'Semiring' as follows:+--+-- @+-- 'zero'  = 0+-- 'one'   = 1+-- ('<+>') = ('+')+-- ('<.>') = ('*')+-- @+newtype Count a = Count (Sum (NonNegative a))+    deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup)++instance Show a => Show (Count a) where+    show (Count (Sum (NonNegative (Finite x)))) = show x+    show _ = "count infinite"++instance (Num a, Ord a) => Semiring (Count a) where+    one   = 1+    (<.>) = (*)++instance (Num a, Ord a) => StarSemiring (Count a) where+    star x | x == zero = one+           | otherwise = count infinite++-- | A non-negative count.+count :: NonNegative a -> Count a+count = Count . Sum++-- | Get the value of a count.+getCount :: Count a -> NonNegative a+getCount (Count (Sum x)) = x++-- | A /distance/ is a non-negative value that can be 'finite' or 'infinite'.+-- Distances form a 'Dioid' as follows:+--+-- @+-- 'zero'  = 'distance' 'infinite'+-- 'one'   = 0+-- ('<+>') = 'min'+-- ('<.>') = ('+')+-- @+newtype Distance a = Distance (Min (NonNegative a))+    deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup)++instance Show a => Show (Distance a) where+    show (Distance (Min (NonNegative (Finite x)))) = show x+    show _ = "distance infinite"++instance (Num a, Ord a) => Semiring (Distance a) where+    one   = 0+    (<.>) = (+)++instance (Num a, Ord a) => StarSemiring (Distance a) where+    star _ = one++instance (Num a, Ord a) => Dioid (Distance a)++-- | A non-negative distance.+distance :: NonNegative a -> Distance a+distance = Distance . Min++-- | Get the value of a distance.+getDistance :: Distance a -> NonNegative a+getDistance (Distance (Min x)) = x++-- This data type extends the underlying type @a@ with a new 'Infinite' value.+data Extended a = Finite a | Infinite+    deriving (Eq, Functor, Ord, Show)++instance Applicative Extended where+    pure  = Finite+    (<*>) = ap++instance Monad Extended where+    return = pure++    Infinite >>= _ = Infinite+    Finite x >>= f = f x++-- Extract the finite value or @Nothing@ if the value is 'Infinite'.+fromExtended :: Extended a -> Maybe a+fromExtended (Finite a) = Just a+fromExtended Infinite   = Nothing++instance Num a => Num (Extended a) where     fromInteger = Finite . fromInteger -    Infinite + _        = Infinite-    _        + Infinite = Infinite-    Finite x + Finite y = Finite (x + y)+    (+) = liftA2 (+)+    (*) = liftA2 (*) -    Infinite * _        = Infinite-    _        * Infinite = Infinite-    Finite x * Finite y = Finite (x * y)+    negate = fmap negate+    signum = fmap signum+    abs    = fmap abs -    negate _ = error "Negative distances not allowed"+-- | If @a@ is a monoid, 'Minimum' @a@ forms the following 'Dioid':+--+-- @+-- 'zero'  = 'pure' 'mempty'+-- 'one'   = 'noMinimum'+-- ('<+>') = 'liftA2' 'min'+-- ('<.>') = 'liftA2' 'mappend'+-- @+--+-- To create a singleton value of type 'Minimum' @a@ use the 'pure' function.+-- For example:+--+-- @+-- getMinimum ('pure' "Hello, " '<+>' 'pure' "World!") == Just "Hello, "+-- getMinimum ('pure' "Hello, " '<.>' 'pure' "World!") == Just "Hello, World!"+-- @+newtype Minimum a = Minimum (Extended a)+    deriving (Applicative, Eq, Functor, Ord, Monad) -    signum (Finite 0) = 0-    signum _          = 1+-- | Extract the minimum or @Nothing@ if it does not exist.+getMinimum :: Minimum a -> Maybe a+getMinimum (Minimum x) = fromExtended x -    abs = id+-- | The value corresponding to the lack of minimum, e.g. the minimum of the+-- empty set.+noMinimum :: Minimum a+noMinimum = Minimum Infinite -instance Ord a => Semilattice (Distance a) where-    zero = Infinite+instance (Num a, Show a) => Show (Minimum a) where+    show (Minimum Infinite  ) = "one"+    show (Minimum (Finite x)) = show x -    Infinite \/ x        = x-    x        \/ Infinite = x-    Finite x \/ Finite y = Finite (min x y)+instance IsList a => IsList (Minimum a) where+    type Item (Minimum a) = Item a+    fromList = Minimum . Finite . fromList+    toList (Minimum x) = toList $ fromMaybe errorMessage (fromExtended x)+      where+        errorMessage = error "Minimum.toList applied to noMinimum value." -instance (Num a, Ord a) => Dioid (Distance a) where-    one = Finite 0+-- | The /power set/ over the underlying set of elements @a@. If @a@ is a+-- monoid, then the power set forms a 'Dioid' as follows:+--+-- @+-- 'zero'    = PowerSet Set.'Set.empty'+-- 'one'     = PowerSet $ Set.'Set.singleton' 'mempty'+-- x '<+>' y = PowerSet $ Set.'Set.union' (getPowerSet x) (getPowerSet y)+-- x '<.>' y = PowerSet $ 'setProductWith' 'mappend' (getPowerSet x) (getPowerSet y)+-- @+newtype PowerSet a = PowerSet { getPowerSet :: Set a }+    deriving (Eq, Monoid, Ord, Semigroup) -    Infinite /\ _        = Infinite-    _        /\ Infinite = Infinite-    Finite x /\ Finite y = Finite (x + y)+instance (Monoid a, Ord a) => Semiring (PowerSet a) where+    one                       = PowerSet (Set.singleton mempty)+    PowerSet x <.> PowerSet y = PowerSet (setProductWith mappend x y) -instance Ord a => Semilattice (Set a) where-    zero = Set.empty-    (\/) = Set.union+instance (Monoid a, Ord a) => StarSemiring (PowerSet a) where+    star _ = one++instance (Monoid a, Ord a) => Dioid (PowerSet a) where++-- | The type of /free labels/ over the underlying set of symbols @a@. This data+-- type is an instance of classes 'StarSemiring' and 'Dioid'.+data Label a = Zero+             | One+             | Symbol a+             | Label a :+: Label a+             | Label a :*: Label a+             | Star (Label a)+             deriving Functor++infixl 6 :+:+infixl 7 :*:++instance IsList (Label a) where+    type Item (Label a) = a+    fromList = foldr ((<>) . Symbol) Zero+    toList   = error "Label.toList cannot be given a reasonable definition"++instance Show a => Show (Label a) where+    showsPrec p label = case label of+        Zero     -> shows (0 :: Int)+        One      -> shows (1 :: Int)+        Symbol x -> shows x+        x :+: y  -> showParen (p >= 6) $ showsPrec 6 x . (" | " ++) . showsPrec 6 y+        x :*: y  -> showParen (p >= 7) $ showsPrec 7 x . (" ; " ++) . showsPrec 7 y+        Star x   -> showParen (p >= 8) $ showsPrec 8 x . ("*"   ++)++instance Semigroup (Label a) where+    Zero   <> x      = x+    x      <> Zero   = x+    One    <> One    = One+    One    <> Star x = Star x+    Star x <> One    = Star x+    x      <> y      = x :+: y++instance Monoid (Label a) where+    mempty  = Zero+    mappend = (<>)++instance Semiring (Label a) where+    one = One++    One  <.> x    = x+    x    <.> One  = x+    Zero <.> _    = Zero+    _    <.> Zero = Zero+    x    <.> y    = x :*: y++instance StarSemiring (Label a) where+    star Zero     = One+    star One      = One+    star (Star x) = star x+    star x        = Star x++-- | Check if a 'Label' is 'zero'.+isZero :: Label a -> Bool+isZero Zero = True+isZero _    = False++-- | A type synonym for /regular expressions/, built on top of /free labels/.+type RegularExpression a = Label a++-- | An /optimum semiring/ obtained by combining a semiring @o@ that defines an+-- /optimisation criterion/, and a semiring @a@ that describes the /arguments/+-- of an optimisation problem. For example, by choosing @o = 'Distance' Int@ and+-- and @a = 'Minimum' ('Path' String)@, we obtain the /shortest path semiring/+-- for computing the shortest path in an @Int@-labelled graph with @String@+-- vertices.+--+-- We assume that the semiring @o@ is /selective/ i.e. for all @x@ and @y@:+--+-- > x <+> y == x || x <+> y == y+--+-- In words, the operation '<+>' always simply selects one of its arguments. For+-- example, the 'Capacity' and 'Distance' semirings are selective, whereas the+-- the 'Count' semiring is not.+data Optimum o a = Optimum { getOptimum :: o, getArgument :: a }+    deriving (Eq, Ord, Show)++-- This is similar to geodetic semirings.+-- See http://vlado.fmf.uni-lj.si/vlado/papers/SemiRingSNA.pdf+instance (Eq o, Monoid a, Monoid o) => Semigroup (Optimum o a) where+    Optimum o1 a1 <> Optimum o2 a2+        | o1 == o2  = Optimum o1 (mappend a1 a2)+        | otherwise = Optimum o a+            where+              o = mappend o1 o2+              a = if o == o1 then a1 else a2++instance (Eq o, Monoid a, Monoid o) => Monoid (Optimum o a) where+    mempty  = Optimum mempty mempty+    mappend = (<>)++instance (Eq o, Semiring a, Semiring o) => Semiring (Optimum o a) where+    one = Optimum one one+    Optimum o1 a1 <.> Optimum o2 a2 = Optimum (o1 <.> o2) (a1 <.> a2)++instance (Eq o, StarSemiring a, StarSemiring o) => StarSemiring (Optimum o a) where+    star (Optimum o a) = Optimum (star o) (star a)++instance (Eq o, Dioid a, Dioid o) => Dioid (Optimum o a) where++-- | A /path/ is a list of edges.+type Path a = [(a, a)]++-- | The 'Optimum' semiring specialised to /finding the lexicographically+-- smallest shortest path/.+type ShortestPath e a = Optimum (Distance e) (Minimum (Path a))++-- | The 'Optimum' semiring specialised to /finding all shortest paths/.+type AllShortestPaths e a = Optimum (Distance e) (PowerSet (Path a))++-- | The 'Optimum' semiring specialised to /counting all shortest paths/.+type CountShortestPaths e a = Optimum (Distance e) (Count Integer)++-- | The 'Optimum' semiring specialised to /finding the lexicographically+-- smallest widest path/.+type WidestPath e a = Optimum (Capacity e) (Minimum (Path a))

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE DeriveFunctor, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Labelled@@ -16,107 +16,619 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Labelled (     -- * Algebraic data type for edge-labeleld graphs-    Graph (..), UnlabelledGraph, empty, vertex, edge, overlay, connect,-    connectBy, (-<), (>-),+    Graph (..), empty, vertex, edge, (-<), (>-), overlay, connect, vertices,+    edges, overlays, -    -- * Operations-    edgeLabel-  ) where+    -- * Graph folding+    foldg, +    -- * Relations on graphs+    isSubgraphOf,++    -- * Graph properties+    isEmpty, size, hasVertex, hasEdge, edgeLabel, vertexList, edgeList,+    vertexSet, edgeSet,++    -- * Graph transformation+    removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, emap,+    induce,++    -- * Relational operations+    closure, reflexiveClosure, symmetricClosure, transitiveClosure,++    -- * Types of edge-labelled graphs+    UnlabelledGraph, Automaton, Network,++    -- * Context+    Context (..), context+    ) where+ import Prelude () import Prelude.Compat +import Data.Monoid (Any (..))+import Data.Semigroup ((<>))++import Algebra.Graph.Internal (List (..)) import Algebra.Graph.Label-import qualified Algebra.Graph.Class as C +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+-- For example, 'Graph' @Bool@ @a@ is isomorphic to unlabelled graphs defined in -- the top-level module "Algebra.Graph.Graph", where @False@ and @True@ denote -- the lack of and the existence of an unlabelled edge, respectively. data Graph e a = Empty                | Vertex a                | Connect e (Graph e a) (Graph e a)-               deriving (Foldable, Functor, Show, Traversable)+               deriving (Functor, Show) --- | A type synonym for unlabelled graphs.-type UnlabelledGraph a = Graph Bool a+instance (Eq e, Monoid e, Ord a) => Eq (Graph e a) where+    x == y = toAdjacencyMap x == toAdjacencyMap y +instance (Eq e, Monoid e, Ord a, Ord e) => Ord (Graph e a) where+    compare x y = compare (toAdjacencyMap x) (toAdjacencyMap y)++-- | __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++-- 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++-- 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.+-- 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 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+  where+    go Empty           = e+    go (Vertex    x  ) = v x+    go (Connect e x y) = c e (go x) (go y)++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a+-- graph can be quadratic with respect to the expression size /s/.+--+-- @+-- isSubgraphOf 'empty'         x             ==  True+-- isSubgraphOf ('vertex' x)    'empty'         ==  False+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf x y                         ==> x <= y+-- @+isSubgraphOf :: (Eq e, Monoid e, Ord a) => Graph e a -> Graph e a -> Bool+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+-- 'Algebra.Graph.ToGraph.vertexCount' empty == 0+-- 'Algebra.Graph.ToGraph.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+-- 'Algebra.Graph.ToGraph.vertexCount' (vertex x) == 1+-- 'Algebra.Graph.ToGraph.edgeCount'   (vertex x) == 0+-- @ vertex :: a -> Graph e a vertex = Vertex --- | Construct the graph comprising /a single edge/ with the label 'one'.+-- | Construct the graph comprising /a single labelled edge/. -- Complexity: /O(1)/ time, memory and size.-edge :: Dioid e => a -> a -> Graph e a-edge = C.edge+--+-- @+-- 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+-- '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) --- | /Overlay/ two graphs. An alias for 'Connect' 'zero'. This is a commutative,--- associative and idempotent operation with the identity 'empty'.--- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size.-overlay :: Semilattice e => Graph e a -> Graph e a -> Graph e a-overlay = Connect zero+-- | The left-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- y == 'edge' e x y+-- @+(-<) :: a -> e -> (a, e)+g -< e = (g, e) --- | /Connect/ two graphs. An alias for 'Connect' 'one'. This is an associative--- operation with the identity 'empty', which distributes over 'overlay' and--- obeys the decomposition axiom. See the full list of laws in "Algebra.Graph".--- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number--- of edges in the resulting graph is quadratic with respect to the number of--- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.-connect :: Dioid e => Graph e a -> Graph e a -> Graph e a-connect = Connect one+-- | The right-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- y == 'edge' e x y+-- @+(>-) :: (a, e) -> a -> Graph e a+(x, e) >- y = edge e x y +infixl 5 -<+infixl 5 >-++-- | /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:+--+-- @+-- '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+ -- | /Connect/ two graphs with edges labelled by a given label. An alias for -- 'Connect'. -- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number -- of edges in the resulting graph is quadratic with respect to the number of -- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.-connectBy :: e -> Graph e a -> Graph e a -> Graph e a-connectBy = Connect+--+-- @+-- '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 --- | The left-hand part of a convenient ternary-ish operator @x -\<e\>- y@ for--- connecting graphs with 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. -- -- @--- x = 'vertex' "x"--- y = 'vertex' "y"--- z = x -\<2\>- y+-- vertices []            == 'empty'+-- vertices [x]           == 'vertex' x+-- 'hasVertex' x . vertices == 'elem' x+-- 'Algebra.Graph.ToGraph.vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'Algebra.Graph.ToGraph.vertexSet'   . vertices == Set.'Set.fromList' -- @-(-<) :: Graph e a -> e -> (Graph e a, e)-g -< e = (g, e)+vertices :: Monoid e => [a] -> Graph e a+vertices = overlays . map vertex --- | The right-hand part of a convenient ternary-ish operator @x -\<e\>- y@ for--- connecting graphs with labelled edges. For example:+-- | 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. -- -- @--- x = 'vertex' "x"--- y = 'vertex' "y"--- z = x -\<2\>- y+-- edges []        == 'empty'+-- edges [(e,x,y)] == 'edge' e x y+-- edges           == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) -- @-(>-) :: (Graph e a, e) -> Graph e a -> Graph e a-(g, e) >- h = Connect e g h+edges :: Monoid e => [(e, a, a)] -> Graph e a+edges = overlays . map (\(e, x, y) -> edge e x y) -infixl 5 -<-infixl 5 >-+-- | 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 -instance Dioid e => C.Graph (Graph e a) where-    type Vertex (Graph e a) = a-    empty   = Empty-    vertex  = Vertex-    overlay = overlay-    connect = connect+-- | Check if a graph is empty. A convenient alias for 'null'.+-- Complexity: /O(s)/ 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 :: Graph e a -> Bool+isEmpty = foldg True (const False) (const (&&)) +-- | 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             >= 'Algebra.Graph.ToGraph.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, Semilattice e) => a -> a -> Graph e a -> e-edgeLabel _ _ Empty           = zero-edgeLabel _ _ (Vertex _)      = zero-edgeLabel x y (Connect e g h) = edgeLabel x y g \/ edgeLabel x y h \/ new+edgeLabel :: (Eq a, Monoid e) => a -> a -> Graph e a -> e+edgeLabel s t g = let (res, _, _) = foldg e v c g in res   where-    new | x `elem` g && y `elem` h = e-        | otherwise                = zero+    e                                         = (zero               , False   , False   )+    v x                                       = (zero               , x == s  , x == t  )+    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.+--+-- @+-- 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 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.+--+-- @+-- 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)++-- | 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.+--+-- @+-- 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++-- | 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.+--+-- @+-- 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(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(s)/ time, memory and size, 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++-- | 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++-- | A type synonym for /automata/ or /labelled transition systems/.+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 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+-- @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 ('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)+context p g | ok f      = Just $ Context (Exts.toList $ is f) (Exts.toList $ os f)+            | otherwise = Nothing+  where+    f = focus p g

@@ -0,0 +1,612 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Labelled.AdjacencyMap+-- Copyright  : (c) Andrey Mokhov 2016-2018+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : experimental+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the 'AdjacencyMap' data type for edge-labelled graphs, as+-- well as associated operations and algorithms. 'AdjacencyMap' is an instance+-- of the 'C.Graph' type class, which can be used for polymorphic graph+-- construction and manipulation.+-----------------------------------------------------------------------------+module Algebra.Graph.Labelled.AdjacencyMap (+    -- * Data structure+    AdjacencyMap, adjacencyMap,++    -- * Basic graph construction primitives+    empty, vertex, edge, (-<), (>-), overlay, connect, vertices, edges,+    overlays, fromAdjacencyMaps,++    -- * Relations on graphs+    isSubgraphOf,++    -- * Graph properties+    isEmpty, hasVertex, hasEdge, edgeLabel, vertexCount, edgeCount, vertexList,+    edgeList, vertexSet, edgeSet, preSet, postSet, skeleton,++    -- * Graph transformation+    removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap,+    emap, induce,++    -- * Relational operations+    closure, reflexiveClosure, symmetricClosure, transitiveClosure+  ) where++import Prelude ()+import Prelude.Compat++import Data.Foldable (foldMap)+import Data.Maybe+import Data.Map (Map)+import Data.Monoid (Monoid, Sum (..))+import Data.Set (Set)++import Algebra.Graph.Label+import Algebra.Graph.Labelled.AdjacencyMap.Internal++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++-- | 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-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- y == 'edge' e x y+-- @+(-<) :: a -> e -> (a, e)+g -< e = (g, e)++-- | The right-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- y == 'edge' e x y+-- @+(>-) :: (Eq e, Monoid e, Ord a) => (a, e) -> a -> AdjacencyMap e a+(x, e) >- y = edge e x y++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.+--+-- @+-- '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 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:+--+-- @+-- '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++-- 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++-- 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.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the+-- number of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'isEmpty'     (connect 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 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.+--+-- @+-- overlays []        == 'empty'+-- overlays [x]       == x+-- overlays [x,y]     == 'overlay' x y+-- overlays           == 'foldr' 'overlay' 'empty'+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+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 []                                  == '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) 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.+-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a+-- graph can be quadratic with respect to the expression size /s/.+--+-- @+-- isSubgraphOf 'empty'      x     ==  True+-- isSubgraphOf ('vertex' x) 'empty' ==  False+-- isSubgraphOf x 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+  where+    le x y = mappend x y == 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++-- | 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 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)++-- | The number of vertices in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexCount 'empty'             ==  0+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y+-- @+vertexCount :: AdjacencyMap e a -> Int+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 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 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 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 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 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 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.+-- 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 -> AdjacencyMap e a -> AdjacencyMap e a+replaceEdge e x y+    | 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++-- | 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 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)++-- | Transform a graph by applying a function to each of its vertices. This is+-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric+-- 'AdjacencyMap'.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- 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 mappend f) .+    Map.mapKeysWith (Map.unionWith mappend) f . adjacencyMap++-- | Transform a graph by applying a function @h@ to each of its edge labels.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- 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++-- The iterative part of the Warshall-Floyd-Kleene algorithm+goWarshallFloydKleene :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a+goWarshallFloydKleene (AM m) = AM $ foldr update m vs+  where+    vs = Set.toAscList (Map.keysSet m)+    update k cur = Map.fromAscList [ (i, go i (get i k <.> starkk)) | i <- vs ]+      where+        get i j = edgeLabel i j (AM cur)+        starkk  = star (get k k)+        go i ik = Map.fromAscList+            [ (j, e) | j <- vs, let e = get i j <+> ik <.> get k j, e /= zero ]

@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Labelled.AdjdacencyMap.Internal+-- Copyright  : (c) Andrey Mokhov 2016-2018+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : unstable+--+-- This module exposes the implementation of edge-labelled adjacency maps. The+-- API is unstable and unsafe, and is exposed only for documentation. You should+-- use the non-internal module "Algebra.Graph.Labelled.AdjdacencyMap" instead.+-----------------------------------------------------------------------------+module Algebra.Graph.Labelled.AdjacencyMap.Internal (+    -- * Labelled adjacency map implementation+    AdjacencyMap (..), consistent+    ) where++import Prelude ()+import Prelude.Compat++import Control.DeepSeq+import Data.Map.Strict (Map)+import Data.Monoid (Monoid, getSum, Sum (..))+import Data.Set (Set, (\\))++import qualified Data.Map.Strict as Map+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+    -- edge labels.+    adjacencyMap :: Map a (Map a e) } deriving (Eq, NFData)++instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where+    showsPrec p (AM m)+        | Set.null vs = showString "empty"+        | null es     = showParen (p > 10) $ vshow vs+        | vs == used  = showParen (p > 10) $ eshow es+        | otherwise   = showParen (p > 10) $+                            showString "overlay (" . vshow (vs \\ used) .+                            showString ") ("       . eshow es . showString ")"+      where+        vs   = Map.keysSet m+        es   = internalEdgeList m+        used = referredToVertexSet m+        vshow vs = case Set.toAscList vs of+            [x] -> showString "vertex "   . showsPrec 11 x+            xs  -> showString "vertices " . showsPrec 11 xs+        eshow es = case es of+            [(e, x, y)] -> showString "edge "  . showsPrec 11 e .+                           showString " "      . showsPrec 11 x .+                           showString " "      . showsPrec 11 y+            xs          -> showString "edges " . showsPrec 11 xs++instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where+    compare (AM x) (AM y) = mconcat+        [ compare (vNum x) (vNum y)+        , compare (vSet x) (vSet y)+        , compare (eNum x) (eNum y)+        , compare (eSet x) (eSet 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 (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 $ 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)+    signum      = const (AM Map.empty)+    abs         = id+    negate      = id++-- | 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+-- function in testing.+-- /Note: this function is for internal use only/.+consistent :: (Ord a, Eq e, Monoid e) => AdjacencyMap e a -> Bool+consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` Map.keysSet m+    && and [ e /= zero | (_, es) <- Map.toAscList m, (_, e) <- Map.toAscList es ]++-- The set of vertices that are referred to by the edges in an adjacency map+referredToVertexSet :: Ord a => Map a (Map a e) -> Set a+referredToVertexSet m = Set.fromList $ concat+    [ [x, y] | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ]++-- The list of edges in an adjacency map+internalEdgeList :: Map a (Map a e) -> [(e, a, a)]+internalEdgeList m =+    [ (e, x, y) | (x, ys) <- Map.toAscList m, (y, e) <- Map.toAscList ys ]

@@ -0,0 +1,84 @@+{-# LANGUAGE CPP, OverloadedLists, TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Labelled.Example.Automaton+-- Copyright  : (c) Andrey Mokhov 2016-2018+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : experimental+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module contains a simple example of using edge-labelled graphs defined+-- in the module "Algebra.Graph.Labelled" for working with finite automata.+-----------------------------------------------------------------------------+module Algebra.Graph.Labelled.Example.Automaton where++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+import GHC.Exts hiding (Any)++instance Ord a => IsList (Set a) where+    type Item (Set a) = a+    fromList = Set.fromList+    toList   = Set.toList+#endif++-- | The alphabet of actions for ordering coffee or tea.+data Alphabet = Coffee -- ^ Order coffee+              | Tea    -- ^ Order tea+              | Cancel -- ^ Cancel payment or order+              | Pay    -- ^ Pay for the order+              deriving (Bounded, Enum, Eq, Ord, Show)++-- | The state of the order.+data State = Choice   -- ^ Choosing what to order+           | Payment  -- ^ Making the payment+           | Complete -- ^ The order is complete+           deriving (Bounded, Enum, Eq, Ord, Show)++-- TODO: Add an illustration.+-- | An example automaton for ordering coffee or tea.+--+-- @+-- order = 'overlays' [ 'Choice'  '-<'['Coffee', 'Tea']'>-' 'Payment'+--                  , 'Choice'  '-<'['Cancel'     ]'>-' 'Complete'+--                  , 'Payment' '-<'['Cancel'     ]'>-' 'Choice'+--                  , 'Payment' '-<'['Pay'        ]'>-' 'Complete' ]+-- @+coffeeTeaAutomaton :: Automaton Alphabet State+coffeeTeaAutomaton = overlays [ Choice  -<[Coffee, Tea]>- Payment+                              , Payment -<[Pay        ]>- Complete+                              , Choice  -<[Cancel     ]>- Complete+                              , Payment -<[Cancel     ]>- Choice ]++-- | The map of 'State' reachability.+--+-- @+-- reachability = Map.'Map.fromList' $ map (\s -> (s, 'reachable' s 'order')) ['Choice' ..]+-- @+--+-- Or, when evaluated:+--+-- @+-- reachability = Map.'Map.fromList' [ ('Choice'  , ['Choice'  , 'Payment', 'Complete'])+--                             , ('Payment' , ['Payment' , 'Choice' , 'Complete'])+--                             , ('Complete', ['Complete'                   ]) ]+-- @+reachability :: Map State [State]+reachability = Map.fromList $ map (\s -> (s, reachable s skeleton)) [Choice ..]+  where+    skeleton :: Graph Any State+    skeleton = emap (Any . not . isZero) coffeeTeaAutomaton

@@ -0,0 +1,64 @@+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Labelled.Example.Network+-- Copyright  : (c) Andrey Mokhov 2016-2018+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : experimental+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module contains a simple example of using edge-labelled graphs defined+-- in the module "Algebra.Graph.Labelled" for working with networks, i.e. graphs+-- whose edges are labelled with distances.+-----------------------------------------------------------------------------+module Algebra.Graph.Labelled.Example.Network where++import Algebra.Graph.Labelled++-- | Our example networks have /cities/ as vertices.+data City = Aberdeen+          | Edinburgh+          | Glasgow+          | London+          | Newcastle+          deriving (Bounded, Enum, Eq, Ord, Show)++-- | For simplicity we measure /journey times/ in integer number of minutes.+type JourneyTime = Int++-- | A part of the EastCoast train network between 'Aberdeen' and 'London'.+--+-- @+-- eastCoast = 'overlays' [ 'Aberdeen'  '-<'&#49;50'>-' 'Edinburgh'+--                      , 'Edinburgh' '-<' 90'>-' 'Newcastle'+--                      , 'Newcastle' '-<'&#49;70'>-' 'London' ]+-- @+eastCoast :: Network JourneyTime City+eastCoast = overlays [ Aberdeen  -<150>- Edinburgh+                     , Edinburgh -< 90>- Newcastle+                     , Newcastle -<170>- London ]++-- | A part of the ScotRail train network between 'Aberdeen' and 'Glasgow'.+--+-- @+-- scotRail = 'overlays' [ 'Aberdeen'  '-<'&#49;40'>-' 'Edinburgh'+--                     , 'Edinburgh' '-<' 50'>-' 'Glasgow'+--                     , 'Edinburgh' '-<' 70'>-' 'Glasgow' ]+-- @+scotRail :: Network JourneyTime City+scotRail = overlays [ Aberdeen  -<140>- Edinburgh+                    , Edinburgh -< 50>- Glasgow+                    , Edinburgh -< 70>- Glasgow ]++-- TODO: Add an illustration.+-- | An example train network.+--+-- @+-- network = 'overlay' 'scotRail' 'eastCoast'+-- @+network :: Network JourneyTime City+network = overlay scotRail eastCoast

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE CPP, DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.NonEmpty@@ -11,15 +11,22 @@ -- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the -- motivation behind the library, the underlying theory, and implementation details. ----- This module defines the data type 'NonEmptyGraph' for graphs that are known--- to be non-empty at compile time. The naming convention generally follows that--- of "Data.List.NonEmpty": we use suffix @1@ to indicate the functions whose--- interface must be changed compared to "Algebra.Graph", e.g. 'vertices1'.+-- This module defines the data type 'Graph' for algebraic graphs that are known+-- to be non-empty at compile time. To avoid name clashes with "Algebra.Graph",+-- this module can be imported qualified: --+-- @+-- import qualified Algebra.Graph.NonEmpty as NonEmpty+-- @+--+-- The naming convention generally follows that of "Data.List.NonEmpty": we use+-- suffix @1@ to indicate the functions whose interface must be changed compared+-- to "Algebra.Graph", e.g. 'vertices1'.+-- ----------------------------------------------------------------------------- module Algebra.Graph.NonEmpty (-    -- * Algebraic data type for non-empty graphs-    NonEmptyGraph (..), toNonEmptyGraph,+    -- * Non-empty algebraic graphs+    Graph (..), toNonEmpty,      -- * Basic graph construction primitives     vertex, edge, overlay, overlay1, connect, vertices1, edges1, overlays1,@@ -33,7 +40,7 @@      -- * Graph properties     size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList1, edgeList,-    vertexSet, vertexIntSet, edgeSet,+    vertexSet, edgeSet,      -- * Standard families of graphs     path1, circuit1, clique1, biclique1, star, stars1, tree, mesh1, torus1,@@ -44,7 +51,7 @@      -- * Graph composition     box-  ) where+    ) where  import Prelude () import Prelude.Compat@@ -53,40 +60,43 @@ import Data.Semigroup #endif -import Control.DeepSeq (NFData (..))+import Control.DeepSeq import Control.Monad.Compat-import Control.Monad.State (runState, get, put)+import Control.Monad.State import Data.List.NonEmpty (NonEmpty (..))  import Algebra.Graph.Internal -import qualified Algebra.Graph                 as G-import qualified Algebra.Graph.AdjacencyIntMap as AIM-import qualified Algebra.Graph.ToGraph         as T-import qualified Data.IntSet                   as IntSet-import qualified Data.List.NonEmpty            as NonEmpty-import qualified Data.Set                      as Set-import qualified Data.Tree                     as Tree+import qualified Algebra.Graph         as G+import qualified Algebra.Graph.ToGraph as T+import qualified Data.IntSet           as IntSet+import qualified Data.List.NonEmpty    as NonEmpty+import qualified Data.Set              as Set+import qualified Data.Tree             as Tree -{-| The 'NonEmptyGraph' data type is a deep embedding of the core graph-construction primitives 'vertex', 'overlay' and 'connect'. As one can guess from-the name, the empty graph cannot be represented using this data type. See module-"Algebra.Graph" for a graph data type that allows for the construction of the-empty graph.+{-| Non-empty algebraic graphs, which are constructed using three primitives:+'vertex', 'overlay' and 'connect'. See module "Algebra.Graph" for algebraic+graphs that can be empty.  We define a 'Num' instance as a convenient notation for working with graphs: -    > 0           == Vertex 0-    > 1 + 2       == Overlay (Vertex 1) (Vertex 2)-    > 1 * 2       == Connect (Vertex 1) (Vertex 2)-    > 1 + 2 * 3   == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3))-    > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3))+    > 0           == vertex 0+    > 1 + 2       == overlay (vertex 1) (vertex 2)+    > 1 * 2       == connect (vertex 1) (vertex 2)+    > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))+    > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) -Note that the 'signum' method of the 'Num' type class cannot be implemented.+__Note:__ the 'signum' method of the type class 'Num' cannot be implemented and+will throw an error. Furthermore, the 'Num' instance does not satisfy several+"customary laws" of 'Num', which dictate that 'fromInteger' @0@ and+'fromInteger' @1@ should act as additive and multiplicative identities, and+'negate' as additive inverse. Nevertheless, overloading 'fromInteger', '+' and+'*' is very convenient when working with algebraic graphs; we hope that in+future Haskell's Prelude will provide a more fine-grained class hierarchy for+algebraic structures, which we would be able to utilise without violating any+laws. -The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the-/canonical graph representation/ and satisfies the following laws of algebraic-graphs:+The 'Eq' instance satisfies the following laws of non-empty algebraic graphs.      * 'overlay' is commutative, associative and idempotent: @@ -114,78 +124,115 @@  When specifying the time and memory complexity of graph algorithms, /n/ will denote the number of vertices in the graph, /m/ will denote the number of-edges in the graph, and /s/ will denote the /size/ of the corresponding-'NonEmptyGraph' expression, defined as the number of vertex leaves. For example,-if @g@ is a 'NonEmptyGraph' then /n/, /m/ and /s/ can be computed as follows:+edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph'+expression, defined as the number of vertex leaves (note that /n/ <= /s/). If+@g@ is a 'Graph', the corresponding /n/, /m/ and /s/ can be computed as follows:  @n == 'vertexCount' g m == 'edgeCount' g s == 'size' g@ -The 'size' of any graph is positive and coincides with the result of 'length'-method of the 'Foldable' type class. We define 'size' only for the consistency-with the API of other graph representations, such as "Algebra.Graph".+Converting a 'Graph' to the corresponding+'Algebra.Graph.NonEmpty.AdjacencyMap.AdjacencyMap' takes /O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the+complexity of the graph equality test, because it is currently implemented by+converting graph expressions to canonical representations based on adjacency+maps. -Converting a 'NonEmptyGraph' to the corresponding 'AM.AdjacencyMap' takes-/O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the complexity of-the graph equality test, because it is currently implemented by converting graph-expressions to canonical representations based on adjacency maps.+The total order 'Ord' on graphs is defined using /size-lexicographic/ comparison:++* Compare the number of vertices. In case of a tie, continue.+* Compare the sets of vertices. In case of a tie, continue.+* Compare the number of edges. In case of a tie, continue.+* Compare the sets of edges.++Here are a few examples:++@'vertex' 1 < 'vertex' 2+'vertex' 3 < 'edge' 1 2+'vertex' 1 < 'edge' 1 1+'edge' 1 1 < 'edge' 1 2+'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2+'edge' 1 2 < 'edge' 1 3@++Note that the resulting order refines the 'isSubgraphOf' relation and is+compatible with 'overlay' and 'connect' operations:++@'isSubgraphOf' x y ==> x <= y@++@x     <= x + y+x + y <= x * y@ -}-data NonEmptyGraph a = Vertex a-                     | Overlay (NonEmptyGraph a) (NonEmptyGraph a)-                     | Connect (NonEmptyGraph a) (NonEmptyGraph a)-                     deriving (Foldable, Functor, Show, Traversable)+data Graph a = Vertex a+             | Overlay (Graph a) (Graph a)+             | Connect (Graph a) (Graph a)+             deriving (Functor, Show) -instance NFData a => NFData (NonEmptyGraph a) where+instance NFData a => NFData (Graph a) where     rnf (Vertex  x  ) = rnf x     rnf (Overlay x y) = rnf x `seq` rnf y     rnf (Connect x y) = rnf x `seq` rnf y -instance T.ToGraph (NonEmptyGraph a) where-    type ToVertex (NonEmptyGraph a) = a+instance T.ToGraph (Graph a) where+    type ToVertex (Graph a) = a     foldg _ = foldg1     hasEdge = hasEdge -instance Num a => Num (NonEmptyGraph a) where+-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more+-- details.+instance Num a => Num (Graph a) where     fromInteger = Vertex . fromInteger     (+)         = Overlay     (*)         = Connect-    signum      = error "NonEmptyGraph.signum cannot be implemented."+    signum      = error "NonEmpty.Graph.signum cannot be implemented."     abs         = id     negate      = id -instance Ord a => Eq (NonEmptyGraph a) where-    (==) = equals+instance Ord a => Eq (Graph a) where+    (==) = eq +instance Ord a => Ord (Graph a) where+    compare = ord+ -- TODO: Find a more efficient equality check.--- | Compare two graphs by converting them to their adjacency maps.-{-# NOINLINE [1] equals #-}-{-# RULES "equalsInt" equals = equalsInt #-}-equals :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool-equals x y = T.adjacencyMap x == T.adjacencyMap y+-- | Check if two graphs are equal by converting them to their adjacency maps.+eq :: Ord a => Graph a -> Graph a -> Bool+eq x y = T.toAdjacencyMap x == T.toAdjacencyMap y+{-# NOINLINE [1] eq #-}+{-# RULES "eqInt" eq = eqInt #-} --- | Like @equals@ but specialised for graphs with vertices of type 'Int'.-equalsInt :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool-equalsInt x y = T.adjacencyIntMap x == T.adjacencyIntMap y+-- Like @eq@ but specialised for graphs with vertices of type 'Int'.+eqInt :: Graph Int -> Graph Int -> Bool+eqInt x y = T.toAdjacencyIntMap x == T.toAdjacencyIntMap y -instance Applicative NonEmptyGraph where+-- TODO: Find a more efficient comparison.+-- Compare two graphs by converting them to their adjacency maps.+ord :: Ord a => Graph a -> Graph a -> Ordering+ord x y = compare (T.toAdjacencyMap x) (T.toAdjacencyMap y)+{-# NOINLINE [1] ord #-}+{-# RULES "ordInt" ord = ordInt #-}++-- Like @ord@ but specialised for graphs with vertices of type 'Int'.+ordInt :: Graph Int -> Graph Int -> Ordering+ordInt x y = compare (T.toAdjacencyIntMap x) (T.toAdjacencyIntMap y)++instance Applicative Graph where     pure  = Vertex     (<*>) = ap -instance Monad NonEmptyGraph where+instance Monad Graph where     return  = pure     g >>= f = foldg1 f Overlay Connect g --- | Convert a 'G.Graph' into 'NonEmptyGraph'. Returns 'Nothing' if the argument--- is 'G.empty'.+-- | Convert an algebraic graph (from "Algebra.Graph") into a non-empty+-- algebraic graph. Returns 'Nothing' if the argument is 'G.empty'. -- Complexity: /O(s)/ time, memory and size. -- -- @--- toNonEmptyGraph 'G.empty'       == Nothing--- toNonEmptyGraph ('C.toGraph' x) == Just (x :: NonEmptyGraph a)+-- toNonEmpty 'G.empty'       == Nothing+-- toNonEmpty ('T.toGraph' x) == Just (x :: 'Graph' a) -- @-toNonEmptyGraph :: G.Graph a -> Maybe (NonEmptyGraph a)-toNonEmptyGraph = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect)+toNonEmpty :: G.Graph a -> Maybe (Graph a)+toNonEmpty = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect)   where     go _ Nothing  y        = y     go _ x        Nothing  = x@@ -201,7 +248,7 @@ -- 'edgeCount'   (vertex x) == 0 -- 'size'        (vertex x) == 1 -- @-vertex :: a -> NonEmptyGraph a+vertex :: a -> Graph a vertex = Vertex {-# INLINE vertex #-} @@ -215,7 +262,7 @@ -- 'vertexCount' (edge 1 1) == 1 -- 'vertexCount' (edge 1 2) == 2 -- @-edge :: a -> a -> NonEmptyGraph a+edge :: a -> a -> Graph a edge u v = connect (vertex u) (vertex v)  -- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a@@ -232,21 +279,21 @@ -- 'vertexCount' (overlay 1 2) == 2 -- 'edgeCount'   (overlay 1 2) == 0 -- @-overlay :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a+overlay :: Graph a -> Graph a -> Graph a overlay = Overlay {-# INLINE overlay #-} --- | Overlay a possibly empty graph with a non-empty graph. If the first--- argument is 'G.empty', the function returns the second argument; otherwise--- it is semantically the same as 'overlay'.+-- | Overlay a possibly empty graph (from "Algebra.Graph") with a non-empty+-- graph. If the first argument is 'G.empty', the function returns the second+-- argument; otherwise it is semantically the same as 'overlay'. -- Complexity: /O(s1)/ time and memory, and /O(s1 + s2)/ size. -- -- @ --                overlay1 'G.empty' x == x--- x /= 'G.empty' ==> overlay1 x     y == overlay (fromJust $ toNonEmptyGraph x) y+-- x /= 'G.empty' ==> overlay1 x     y == overlay (fromJust $ toNonEmpty x) y -- @-overlay1 :: G.Graph a -> NonEmptyGraph a -> NonEmptyGraph a-overlay1 = maybe id overlay . toNonEmptyGraph+overlay1 :: G.Graph a -> Graph a -> Graph a+overlay1 = maybe id overlay . toNonEmpty  -- | /Connect/ two graphs. An alias for the constructor 'Connect'. This is an -- associative operation, which distributes over 'overlay' and obeys the@@ -267,7 +314,7 @@ -- 'vertexCount' (connect 1 2) == 2 -- 'edgeCount'   (connect 1 2) == 1 -- @-connect :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a+connect :: Graph a -> Graph a -> Graph a connect = Connect {-# INLINE connect #-} @@ -276,12 +323,12 @@ -- given list. -- -- @--- vertices1 (x ':|' [])     == 'vertex' x+-- vertices1 [x]           == 'vertex' x -- 'hasVertex' x . vertices1 == 'elem' x -- 'vertexCount' . vertices1 == 'length' . 'Data.List.NonEmpty.nub' -- 'vertexSet'   . vertices1 == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @-vertices1 :: NonEmpty a -> NonEmptyGraph a+vertices1 :: NonEmpty a -> Graph a vertices1 = overlays1 . fmap vertex {-# NOINLINE [1] vertices1 #-} @@ -290,10 +337,10 @@ -- given list. -- -- @--- edges1 ((x,y) ':|' []) == 'edge' x y--- 'edgeCount' . edges1   == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub'+-- edges1 [(x,y)]     == 'edge' x y+-- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @-edges1 :: NonEmpty (a, a) -> NonEmptyGraph a+edges1 :: NonEmpty (a, a) -> Graph a edges1  = overlays1 . fmap (uncurry edge)  -- | Overlay a given list of graphs.@@ -301,10 +348,10 @@ -- of the given list, and /S/ is the sum of sizes of the graphs in the list. -- -- @--- overlays1 (x ':|' [] ) == x--- overlays1 (x ':|' [y]) == 'overlay' x y+-- overlays1 [x]   == x+-- overlays1 [x,y] == 'overlay' x y -- @-overlays1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a+overlays1 :: NonEmpty (Graph a) -> Graph a overlays1 = concatg1 overlay {-# INLINE [2] overlays1 #-} @@ -313,28 +360,30 @@ -- of the given list, and /S/ is the sum of sizes of the graphs in the list. -- -- @--- connects1 (x ':|' [] ) == x--- connects1 (x ':|' [y]) == 'connect' x y+-- connects1 [x]   == x+-- connects1 [x,y] == 'connect' x y -- @-connects1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a+connects1 :: NonEmpty (Graph a) -> Graph a connects1 = concatg1 connect {-# INLINE [2] connects1 #-} --- | Auxiliary function, similar to 'sconcat'.-concatg1 :: (NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a) -> NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a+-- Auxiliary function, similar to 'sconcat'.+concatg1 :: (Graph a -> Graph a -> Graph a) -> NonEmpty (Graph a) -> Graph a concatg1 combine (x :| xs) = maybe x (combine x) $ foldr1Safe combine xs --- | Generalised graph folding: recursively collapse a 'NonEmptyGraph' by+-- | 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: vertex, overlay 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)/. -- -- @--- foldg1 (const 1) (+)  (+)  == 'size'--- foldg1 (==x)     (||) (||) == 'hasVertex' x+-- foldg1 'vertex'    'overlay' 'connect'        == id+-- foldg1 'vertex'    'overlay' ('flip' 'connect') == 'transpose'+-- foldg1 ('const' 1) (+)     (+)            == 'size'+-- foldg1 (== x)    (||)    (||)           == 'hasVertex' x -- @-foldg1 :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> NonEmptyGraph a -> b+foldg1 :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b foldg1 v o c = go   where     go (Vertex  x  ) = v x@@ -347,13 +396,14 @@ -- graph can be quadratic with respect to the expression size /s/. -- -- @--- isSubgraphOf x             ('overlay' x y) == True--- isSubgraphOf ('overlay' x y) ('connect' x y) == True--- isSubgraphOf ('path1' xs)    ('circuit1' xs) == True+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf ('path1' xs)    ('circuit1' xs) ==  True+-- isSubgraphOf x y                         ==> x <= y -- @-{-# SPECIALISE isSubgraphOf :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-}-isSubgraphOf :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool+isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool isSubgraphOf x y = overlay x y == y+{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-}  -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time.@@ -364,12 +414,12 @@ -- 1 + 2 === 2 + 1 == False -- x + y === x * y == False -- @-{-# SPECIALISE (===) :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-}-(===) :: Eq a => NonEmptyGraph a -> NonEmptyGraph a -> Bool+(===) :: Eq a => Graph a -> Graph a -> Bool (Vertex  x1   ) === (Vertex  x2   ) = x1 ==  x2 (Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2 (Connect x1 y1) === (Connect x2 y2) = x1 === x2 && y1 === y2 _               === _               = False+{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-}  infix 4 === @@ -383,19 +433,19 @@ -- size x             >= 1 -- size x             >= 'vertexCount' x -- @-size :: NonEmptyGraph a -> Int+size :: Graph a -> Int size = foldg1 (const 1) (+) (+) --- | Check if a graph contains a given vertex. A convenient alias for `elem`.+-- | Check if a graph contains a given vertex. -- Complexity: /O(s)/ time. -- -- @ -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False -- @-{-# SPECIALISE hasVertex :: Int -> NonEmptyGraph Int -> Bool #-}-hasVertex :: Eq a => a -> NonEmptyGraph a -> Bool+hasVertex :: Eq a => a -> Graph a -> Bool hasVertex v = foldg1 (==v) (||) (||)+{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-}  -- TODO: Reduce code duplication with 'Algebra.Graph.hasEdge'. -- | Check if a graph contains a given edge.@@ -404,11 +454,10 @@ -- @ -- hasEdge x y ('vertex' z)       == False -- hasEdge x y ('edge' x y)       == True--- hasEdge x y . 'removeEdge' x y == const False+-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @-{-# SPECIALISE hasEdge :: Int -> Int -> NonEmptyGraph Int -> Bool #-}-hasEdge :: Eq a => a -> a -> NonEmptyGraph a -> Bool+hasEdge :: Eq a => a -> a -> Graph a -> Bool hasEdge s t g = hit g == Edge   where     hit (Vertex x   ) = if x == s then Tail else Miss@@ -420,22 +469,23 @@         Miss -> hit y         Tail -> if hasVertex t y then Edge else Tail         Edge -> Edge+{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-}  -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. -- -- @--- vertexCount ('vertex' x) == 1--- vertexCount x          >= 1--- vertexCount            == 'length' . 'vertexList1'+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y -- @+vertexCount :: Ord a => Graph a -> Int+vertexCount = T.vertexCount {-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} {-# INLINE [1] vertexCount #-}-vertexCount :: Ord a => NonEmptyGraph a -> Int-vertexCount = T.vertexCount --- | Like 'vertexCount' but specialised for NonEmptyGraph with vertices of type 'Int'.-vertexIntCount :: NonEmptyGraph Int -> Int+-- Like 'vertexCount' but specialised for Graph with vertices of type 'Int'.+vertexIntCount :: Graph Int -> Int vertexIntCount = IntSet.size . vertexIntSet  -- | The number of edges in a graph.@@ -447,29 +497,29 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount            == 'length' . 'edgeList' -- @+edgeCount :: Ord a => Graph a -> Int+edgeCount = T.edgeCount {-# INLINE [1] edgeCount #-} {-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-}-edgeCount :: Ord a => NonEmptyGraph a -> Int-edgeCount = T.edgeCount --- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'.-edgeCountInt :: NonEmptyGraph Int -> Int-edgeCountInt = AIM.edgeCount . T.toAdjacencyIntMap+-- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'.+edgeCountInt :: Graph Int -> Int+edgeCountInt = T.edgeCount . T.toAdjacencyIntMap  -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- -- @--- vertexList1 ('vertex' x)  == x ':|' []+-- vertexList1 ('vertex' x)  == [x] -- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' -- @+vertexList1 :: Ord a => Graph a -> NonEmpty a+vertexList1 = NonEmpty.fromList . Set.toAscList . vertexSet {-# RULES "vertexList1/Int" vertexList1 = vertexIntList1 #-} {-# INLINE [1] vertexList1 #-}-vertexList1 :: Ord a => NonEmptyGraph a -> NonEmpty a-vertexList1 = NonEmpty.fromList . Set.toAscList . vertexSet --- | Like 'vertexList1' but specialised for NonEmptyGraph with vertices of type 'Int'.-vertexIntList1 :: NonEmptyGraph Int -> NonEmpty Int+-- | Like 'vertexList1' but specialised for Graph with vertices of type 'Int'.+vertexIntList1 :: Graph Int -> NonEmpty Int vertexIntList1 = NonEmpty.fromList . IntSet.toAscList . vertexIntSet  -- | The sorted list of edges of a graph.@@ -481,16 +531,16 @@ -- edgeList ('edge' x y)     == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges1'       == 'Data.List.nub' . 'Data.List.sort' . 'Data.List.NonEmpty.toList'--- edgeList . 'transpose'    == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList+-- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @+edgeList :: Ord a => Graph a -> [(a, a)]+edgeList = T.edgeList {-# RULES "edgeList/Int" edgeList = edgeIntList #-} {-# INLINE [1] edgeList #-}-edgeList :: Ord a => NonEmptyGraph a -> [(a, a)]-edgeList = T.edgeList --- | Like 'edgeList' but specialised for NonEmptyGraph with vertices of type 'Int'.-edgeIntList :: NonEmptyGraph Int -> [(Int,Int)]-edgeIntList = AIM.edgeList . T.toAdjacencyIntMap+-- Like 'edgeList' but specialised for Graph with vertices of type 'Int'.+edgeIntList :: Graph Int -> [(Int, Int)]+edgeIntList = T.edgeList . T.toAdjacencyIntMap  -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory.@@ -500,19 +550,11 @@ -- vertexSet . 'vertices1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- vertexSet . 'clique1'   == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @-vertexSet :: Ord a => NonEmptyGraph a -> Set.Set a+vertexSet :: Ord a => Graph a -> Set.Set a vertexSet = T.vertexSet --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for--- graphs with vertices of type 'Int'.--- Complexity: /O(s * log(n))/ time and /O(n)/ memory.------ @--- vertexIntSet . 'vertex'    == IntSet.'IntSet.singleton'--- vertexIntSet . 'vertices1' == IntSet.'IntSet.fromList' . 'Data.List.NonEmpty.toList'--- vertexIntSet . 'clique1'   == IntSet.'IntSet.fromList' . 'Data.List.NonEmpty.toList'--- @-vertexIntSet :: NonEmptyGraph Int -> IntSet.IntSet+-- Like 'vertexSet' but specialised for graphs with vertices of type 'Int'.+vertexIntSet :: Graph Int -> IntSet.IntSet vertexIntSet = T.vertexIntSet  -- | The set of edges of a given graph.@@ -523,7 +565,7 @@ -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges1'   == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @-edgeSet :: Ord a => NonEmptyGraph a -> Set.Set (a, a)+edgeSet :: Ord a => Graph a -> Set.Set (a, a) edgeSet = T.edgeSet  -- | The /path/ on a list of vertices.@@ -531,11 +573,11 @@ -- given list. -- -- @--- path1 (x ':|' [] ) == 'vertex' x--- path1 (x ':|' [y]) == 'edge' x y--- path1 . 'Data.List.NonEmpty.reverse'  == 'transpose' . path1+-- path1 [x]       == 'vertex' x+-- path1 [x,y]     == 'edge' x y+-- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 -- @-path1 :: NonEmpty a -> NonEmptyGraph a+path1 :: NonEmpty a -> Graph a path1 (x :| []    ) = vertex x path1 (x :| (y:ys)) = edges1 ((x, y) :| zip (y:ys) ys) @@ -544,11 +586,11 @@ -- given list. -- -- @--- circuit1 (x ':|' [] ) == 'edge' x x--- circuit1 (x ':|' [y]) == 'edges1' ((x,y) ':|' [(y,x)])--- circuit1 . 'Data.List.NonEmpty.reverse'  == 'transpose' . circuit1+-- circuit1 [x]       == 'edge' x x+-- circuit1 [x,y]     == 'edges1' [(x,y), (y,x)]+-- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 -- @-circuit1 :: NonEmpty a -> NonEmptyGraph a+circuit1 :: NonEmpty a -> Graph a circuit1 (x :| xs) = path1 (x :| xs ++ [x])  -- | The /clique/ on a list of vertices.@@ -556,13 +598,13 @@ -- given list. -- -- @--- clique1 (x ':|' []   ) == 'vertex' x--- clique1 (x ':|' [y]  ) == 'edge' x y--- clique1 (x ':|' [y,z]) == 'edges1' ((x,y) ':|' [(x,z), (y,z)])--- clique1 (xs '<>' ys)   == 'connect' (clique1 xs) (clique1 ys)--- clique1 . 'Data.List.NonEmpty.reverse'    == 'transpose' . clique1+-- clique1 [x]        == 'vertex' x+-- clique1 [x,y]      == 'edge' x y+-- clique1 [x,y,z]    == 'edges1' [(x,y), (x,z), (y,z)]+-- clique1 (xs '<>' ys) == 'connect' (clique1 xs) (clique1 ys)+-- clique1 . 'Data.List.NonEmpty.reverse'  == 'transpose' . clique1 -- @-clique1 :: NonEmpty a -> NonEmptyGraph a+clique1 :: NonEmpty a -> Graph a clique1 = connects1 . fmap vertex {-# NOINLINE [1] clique1 #-} @@ -571,10 +613,10 @@ -- lengths of the given lists. -- -- @--- biclique1 (x1 ':|' [x2]) (y1 ':|' [y2]) == 'edges1' ((x1,y1) ':|' [(x1,y2), (x2,y1), (x2,y2)])--- biclique1 xs            ys          == 'connect' ('vertices1' xs) ('vertices1' ys)+-- biclique1 [x1,x2] [y1,y2] == 'edges1' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- biclique1 xs      ys      == 'connect' ('vertices1' xs) ('vertices1' ys) -- @-biclique1 :: NonEmpty a -> NonEmpty a -> NonEmptyGraph a+biclique1 :: NonEmpty a -> NonEmpty a -> Graph a biclique1 xs ys = connect (vertices1 xs) (vertices1 ys)  -- | The /star/ formed by a centre vertex connected to a list of leaves.@@ -584,9 +626,9 @@ -- @ -- star x []    == 'vertex' x -- star x [y]   == 'edge' x y--- star x [y,z] == 'edges1' ((x,y) ':|' [(x,z)])+-- star x [y,z] == 'edges1' [(x,y), (x,z)] -- @-star :: a -> [a] -> NonEmptyGraph a+star :: a -> [a] -> Graph a star x []     = vertex x star x (y:ys) = connect (vertex x) (vertices1 $ y :| ys) {-# INLINE star #-}@@ -596,13 +638,13 @@ -- input. -- -- @--- stars1 ((x, [])  ':|' [])         == 'vertex' x--- stars1 ((x, [y]) ':|' [])         == 'edge' x y--- stars1 ((x, ys)  ':|' [])         == 'star' x ys--- stars1                          == 'overlays1' . fmap (uncurry 'star')--- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs <> ys)+-- stars1 [(x, [] )]               == 'vertex' x+-- stars1 [(x, [y])]               == 'edge' x y+-- stars1 [(x, ys )]               == 'star' x ys+-- stars1                          == 'overlays1' . 'fmap' ('uncurry' 'star')+-- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs '<>' ys) -- @-stars1 :: NonEmpty (a, [a]) -> NonEmptyGraph a+stars1 :: NonEmpty (a, [a]) -> Graph a stars1 = overlays1 . fmap (uncurry star) {-# INLINE stars1 #-} @@ -612,11 +654,11 @@ -- -- @ -- tree (Node x [])                                         == 'vertex' x--- tree (Node x [Node y [Node z []]])                       == 'path1' (x ':|' [y,z])+-- tree (Node x [Node y [Node z []]])                       == 'path1' [x,y,z] -- tree (Node x [Node y [], Node z []])                     == 'star' x [y,z]--- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges1' ((1,2) ':|' [(1,3), (3,4), (3,5)])+-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges1' [(1,2), (1,3), (3,4), (3,5)] -- @-tree :: Tree.Tree a -> NonEmptyGraph a+tree :: Tree.Tree a -> Graph a tree (Tree.Node x f) = overlays1 $ star x (map Tree.rootLabel f) :| map tree f  -- | Construct a /mesh graph/ from two lists of vertices.@@ -624,14 +666,14 @@ -- lengths of the given lists. -- -- @--- mesh1 (x ':|' [])    (y ':|' [])    == 'vertex' (x, y)--- mesh1 xs           ys           == 'box' ('path1' xs) ('path1' ys)--- mesh1 (1 ':|' [2,3]) (\'a\' ':|' "b") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\'))---                                                     , ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\'))---                                                     , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\'))---                                                     , ((3,\'a\'),(3,\'b\')) ])+-- mesh1 [x]     [y]        == 'vertex' (x, y)+-- mesh1 xs      ys         == 'box' ('path1' xs) ('path1' ys)+-- mesh1 [1,2,3] [\'a\', \'b\'] == 'edges1' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\'))+--                                    , ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\'))+--                                    , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\'))+--                                    , ((3,\'a\'),(3,\'b\')) ] -- @-mesh1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b)+mesh1 :: NonEmpty a -> NonEmpty b -> Graph (a, b) mesh1 xx@(x:|xs) yy@(y:|ys) =   case NonEmpty.nonEmpty ipxs of     Nothing ->@@ -659,21 +701,22 @@ -- lengths of the given lists. -- -- @--- torus1 (x ':|' [])  (y ':|' [])    == 'edge' (x,y) (x,y)--- torus1 xs         ys           == 'box' ('circuit1' xs) ('circuit1' ys)--- torus1 (1 ':|' [2]) (\'a\' ':|' "b") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\'))---                                                    , ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\'))---                                                    , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\'))---                                                    , ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ])+-- torus1 [x]   [y]        == 'edge' (x,y) (x,y)+-- torus1 xs    ys         == 'box' ('circuit1' xs) ('circuit1' ys)+-- torus1 [1,2] [\'a\', \'b\'] == 'edges1' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\'))+--                                   , ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\'))+--                                   , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\'))+--                                   , ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @-torus1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b)-torus1 xs ys = stars1 $ fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) $ liftM2 (,) (pairs1 xs) (pairs1 ys)+torus1 :: NonEmpty a -> NonEmpty b -> Graph (a, b)+torus1 xs ys = stars1 $ fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)]))+    $ liftM2 (,) (pairs1 xs) (pairs1 ys) --- | Auxiliary function for 'mesh1' and 'torus1'+-- Auxiliary function for 'mesh1' and 'torus1' pairs1 :: NonEmpty a -> NonEmpty (a, a) pairs1 as@(x:|xs) = NonEmpty.zip as $ maybe (x :| []) (`appendNonEmpty` [x]) $ NonEmpty.nonEmpty xs --- | Append a list to a non-empty one+-- Append a list to a non-empty one appendNonEmpty :: NonEmpty a -> [a] -> NonEmpty a appendNonEmpty (w:|ws) zs = w :| (ws++zs) @@ -688,34 +731,34 @@ -- removeVertex1 1 ('edge' 1 2)          == Just ('vertex' 2) -- removeVertex1 x '>=>' removeVertex1 x == removeVertex1 x -- @-{-# SPECIALISE removeVertex1 :: Int -> NonEmptyGraph Int -> Maybe (NonEmptyGraph Int) #-}-removeVertex1 :: Eq a => a -> NonEmptyGraph a -> Maybe (NonEmptyGraph a)+removeVertex1 :: Eq a => a -> Graph a -> Maybe (Graph a) removeVertex1 x = induce1 (/= x)+{-# SPECIALISE removeVertex1 :: Int -> Graph Int -> Maybe (Graph Int) #-}  -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size. -- -- @--- removeEdge x y ('edge' x y)       == 'vertices1' (x ':|' [y])+-- removeEdge x y ('edge' x y)       == 'vertices1' [x,y] -- removeEdge x y . removeEdge x y == removeEdge x y -- removeEdge 1 1 (1 * 1 * 2 * 2)  == 1 * 2 * 2 -- removeEdge 1 2 (1 * 1 * 2 * 2)  == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z)         <= 3 * 'size' z -- @-{-# SPECIALISE removeEdge :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-}-removeEdge :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a+removeEdge :: Eq a => a -> a -> Graph a -> Graph a removeEdge s t = filterContext s (/=s) (/=t)+{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-}  -- TODO: Export-{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> NonEmptyGraph Int -> NonEmptyGraph Int #-}-filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> NonEmptyGraph a -> NonEmptyGraph a+filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Graph a -> Graph a filterContext s i o g = maybe g go $ G.context (==s) (T.toGraph g)   where     go (G.Context is os) = G.induce (/=s) (T.toGraph g)     `overlay1`                            transpose (star s (filter i is)) `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--- given 'NonEmptyGraph'. If @y@ already exists, @x@ and @y@ will be merged.+-- | 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. -- -- @@@ -723,21 +766,21 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y            == 'mergeVertices' (== x) y -- @-{-# SPECIALISE replaceVertex :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-}-replaceVertex :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a+replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex u v = fmap $ \w -> if w == u then v else w+{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-}  -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes -- /O(1)/ to be evaluated. -- -- @--- mergeVertices (const False) x    == id+-- mergeVertices ('const' False) x    == id -- mergeVertices (== x) y           == 'replaceVertex' x y--- mergeVertices even 1 (0 * 2)     == 1 * 1--- mergeVertices odd  1 (3 + 4 * 5) == 4 * 1+-- mergeVertices 'even' 1 (0 * 2)     == 1 * 1+-- mergeVertices 'odd'  1 (3 + 4 * 5) == 4 * 1 -- @-mergeVertices :: (a -> Bool) -> a -> NonEmptyGraph a -> NonEmptyGraph a+mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a mergeVertices p v = fmap $ \w -> if p w then v else w  -- | Split a vertex into a list of vertices with the same connectivity.@@ -746,13 +789,13 @@ -- given list. -- -- @--- splitVertex1 x (x ':|' [] )               == id--- splitVertex1 x (y ':|' [] )               == 'replaceVertex' x y--- splitVertex1 1 (0 ':|' [1]) $ 1 * (2 + 3) == (0 + 1) * (2 + 3)+-- splitVertex1 x [x]                 == id+-- splitVertex1 x [y]                 == 'replaceVertex' x y+-- splitVertex1 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @-{-# SPECIALISE splitVertex1 :: Int -> NonEmpty Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-}-splitVertex1 :: Eq a => a -> NonEmpty a -> NonEmptyGraph a -> NonEmptyGraph a+splitVertex1 :: Eq a => a -> NonEmpty a -> Graph a -> Graph a splitVertex1 v us g = g >>= \w -> if w == v then vertices1 us else vertex w+{-# SPECIALISE splitVertex1 :: Int -> NonEmpty Int -> Graph Int -> Graph Int #-}  -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size.@@ -762,9 +805,9 @@ -- transpose ('edge' x y)  == 'edge' y x -- transpose . transpose == id -- transpose ('box' x y)   == 'box' (transpose x) (transpose y)--- 'edgeList' . transpose  == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList'+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @-transpose :: NonEmptyGraph a -> NonEmptyGraph a+transpose :: Graph a -> Graph a transpose = foldg1 vertex overlay (flip connect) {-# NOINLINE [1] transpose #-} @@ -787,12 +830,12 @@ -- /O(1)/ to be evaluated. -- -- @--- induce1 (const True ) x == Just x--- induce1 (const False) x == Nothing+-- induce1 ('const' True ) x == Just x+-- induce1 ('const' False) x == Nothing -- induce1 (/= x)          == 'removeVertex1' x -- induce1 p '>=>' induce1 q == induce1 (\\x -> p x && q x) -- @-induce1 :: (a -> Bool) -> NonEmptyGraph a -> Maybe (NonEmptyGraph a)+induce1 :: (a -> Bool) -> Graph a -> Maybe (Graph a) induce1 p = foldg1   (\x -> if p x then Just (Vertex x) else Nothing)   (k Overlay)@@ -810,18 +853,17 @@ -- that the size of the result does not exceed the size of the given expression. -- -- @--- simplify              == id--- 'size' (simplify x)     <= 'size' x+-- simplify             ==  id+-- 'size' (simplify x)    <=  'size' x -- simplify 1           '===' 1 -- simplify (1 + 1)     '===' 1 -- simplify (1 + 2 + 1) '===' 1 + 2 -- simplify (1 * 1 * 1) '===' 1 * 1 -- @-{-# SPECIALISE simplify :: NonEmptyGraph Int -> NonEmptyGraph Int #-}-simplify :: Ord a => NonEmptyGraph a -> NonEmptyGraph a+simplify :: Ord a => Graph a -> Graph a simplify = foldg1 Vertex (simple Overlay) (simple Connect)+{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} -{-# SPECIALISE simple :: (NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int) -> NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y     | x == z    = x@@ -829,16 +871,17 @@     | otherwise = z   where     z = op x y+{-# SPECIALISE simple :: (Graph Int -> Graph Int -> Graph Int) -> Graph Int -> Graph Int -> Graph Int #-}  -- | Compute the /Cartesian product/ of graphs. -- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the -- sizes of the given graphs. -- -- @--- box ('path1' $ 'Data.List.NonEmpty.fromList' [0,1]) ('path1' $ 'Data.List.NonEmpty.fromList' "ab") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((0,\'a\'), (0,\'b\'))---                                                                          , ((0,\'a\'), (1,\'a\'))---                                                                          , ((0,\'b\'), (1,\'b\'))---                                                                          , ((1,\'a\'), (1,\'b\')) ])+-- box ('path1' [0,1]) ('path1' [\'a\',\'b\']) == 'edges1' [ ((0,\'a\'), (0,\'b\'))+--                                               , ((0,\'a\'), (1,\'a\'))+--                                               , ((0,\'b\'), (1,\'b\'))+--                                               , ((1,\'a\'), (1,\'b\')) ] -- @ -- Up to an isomorphism between the resulting vertex types, this operation -- is /commutative/, /associative/, /distributes/ over 'overlay', and has@@ -854,12 +897,15 @@ -- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y -- 'edgeCount'   (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @-box :: NonEmptyGraph a -> NonEmptyGraph b -> NonEmptyGraph (a, b)+box :: Graph a -> Graph b -> Graph (a, b) box x y = overlays1 xs `overlay` overlays1 ys   where-    xs = fmap (\b -> fmap (,b) x) $ toNonEmpty y-    ys = fmap (\a -> fmap (a,) y) $ toNonEmpty x+    xs = fmap (\b -> fmap (,b) x) $ toNonEmptyList y+    ys = fmap (\a -> fmap (a,) y) $ toNonEmptyList x +toNonEmptyList :: Graph a -> NonEmpty a+toNonEmptyList = foldg1 (:| []) (<>) (<>)+ -- | /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@@ -875,7 +921,7 @@ -- 'edgeCount'   (sparsify x) <= 3 * 'size' x -- 'size'        (sparsify x) <= 3 * 'size' x -- @-sparsify :: NonEmptyGraph a -> NonEmptyGraph (Either Int a)+sparsify :: Graph a -> Graph (Either Int a) sparsify graph = res   where     (res, end) = runState (foldg1 v o c graph 0 end) 1@@ -885,7 +931,3 @@         m <- get         put (m + 1)         overlay <$> s `x` m <*> m `y` t---- Shall we export this? I suggest to wait for Foldable1 type class instead.-toNonEmpty :: NonEmptyGraph a -> NonEmpty a-toNonEmpty = foldg1 (:| []) (<>) (<>)

@@ -0,0 +1,568 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.NonEmpty.AdjacencyMap+-- Copyright  : (c) Andrey Mokhov 2016-2018+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : experimental+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the data type 'AdjacencyMap' for graphs that are known+-- to be non-empty at compile time. To avoid name clashes with+-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified:+--+-- @+-- import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty+-- @+--+-- The naming convention generally follows that of "Data.List.NonEmpty": we use+-- suffix @1@ to indicate the functions whose interface must be changed compared+-- to "Algebra.Graph.AdjacencyMap", e.g. 'vertices1'.+-----------------------------------------------------------------------------+module Algebra.Graph.NonEmpty.AdjacencyMap (+    -- * Data structure+    AdjacencyMap, toNonEmpty,++    -- * Basic graph construction primitives+    vertex, edge, overlay, connect, vertices1, edges1, overlays1, connects1,++    -- * Relations on graphs+    isSubgraphOf,++    -- * Graph properties+    hasVertex, hasEdge, vertexCount, edgeCount, vertexList1, edgeList,+    vertexSet, edgeSet, preSet, postSet,++    -- * Standard families of graphs+    path1, circuit1, clique1, biclique1, star, stars1, tree,++    -- * Graph transformation+    removeVertex1, removeEdge, replaceVertex, mergeVertices, transpose, gmap,+    induce1,++    -- * Graph closure+    closure, reflexiveClosure, symmetricClosure, transitiveClosure+    ) where++import Prelude hiding (reverse)+import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, reverse)+import Data.Maybe+import Data.Set (Set)+import Data.Tree++import Algebra.Graph.NonEmpty.AdjacencyMap.Internal++import qualified Algebra.Graph.AdjacencyMap as AM+import qualified Data.Set                   as Set++-- Lift a function to non-empty adjacency maps+via :: (AM.AdjacencyMap a -> AM.AdjacencyMap b)+    ->     AdjacencyMap a ->    AdjacencyMap b+via f = NAM . f . am++-- Lift a two-argument function to non-empty adjacency maps+via2 :: (AM.AdjacencyMap a -> AM.AdjacencyMap b -> AM.AdjacencyMap c)+     ->     AdjacencyMap a ->    AdjacencyMap b ->    AdjacencyMap c+via2 f (NAM x) (NAM y) = NAM (f x y)++-- Lift a list function to non-empty adjacency maps+viaL :: (         [AM.AdjacencyMap a] -> AM.AdjacencyMap b)+     ->  NonEmpty (   AdjacencyMap a) ->    AdjacencyMap b+viaL f = NAM . f . fmap am . toList++-- Unsafe creation of a NonEmpty list.+unsafeNonEmpty :: [a] -> NonEmpty a+unsafeNonEmpty = fromMaybe (error msg) . nonEmpty+  where+    msg = "Algebra.Graph.AdjacencyMap.unsafeNonEmpty: Graph is empty"++-- | Convert a possibly empty 'AM.AdjacencyMap' into NonEmpty.'AdjacencyMap'.+-- Returns 'Nothing' if the argument is 'AM.empty'.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- toNonEmpty 'AM.empty'              == Nothing+-- toNonEmpty ('Algebra.Graph.ToGraph.toAdjacencyMap' x) == Just (x :: 'AdjacencyMap' a)+-- @+toNonEmpty :: AM.AdjacencyMap a -> Maybe (AdjacencyMap a)+toNonEmpty x | AM.isEmpty x = Nothing+             | otherwise    = Just (NAM x)++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'AdjacencyMap.hasVertex' x (vertex x) == True+-- 'AdjacencyMap.vertexCount' (vertex x) == 1+-- 'AdjacencyMap.edgeCount'   (vertex x) == 0+-- @+vertex :: a -> AdjacencyMap a+vertex = NAM . AM.vertex+{-# NOINLINE [1] vertex #-}++-- | /Overlay/ two graphs. This is a commutative, associative and idempotent+-- operation with the identity 'empty'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (overlay x y) >= 'vertexCount' x+-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (overlay x y) >= 'edgeCount' x+-- 'edgeCount'   (overlay x y) <= 'edgeCount' x   + 'edgeCount' y+-- 'vertexCount' (overlay 1 2) == 2+-- 'edgeCount'   (overlay 1 2) == 0+-- @+overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+overlay = via2 AM.overlay+{-# NOINLINE [1] overlay #-}++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (connect x y) >= 'vertexCount' x+-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (connect x y) >= 'edgeCount' x+-- 'edgeCount'   (connect x y) >= 'edgeCount' y+-- 'edgeCount'   (connect x y) >= 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y+-- 'vertexCount' (connect 1 2) == 2+-- 'edgeCount'   (connect 1 2) == 1+-- @+connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+connect = via2 AM.connect+{-# NOINLINE [1] connect #-}++-- | Construct the graph comprising /a single edge/.+-- Complexity: /O(1)/ time, memory.+--+-- @+-- edge x y               == 'connect' ('vertex' x) ('vertex' y)+-- 'hasEdge' x y (edge x y) == True+-- 'edgeCount'   (edge x y) == 1+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: Ord a => a -> a -> AdjacencyMap a+edge x y = NAM (AM.edge x y)++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length+-- of the given list.+--+-- @+-- vertices1 [x]           == 'vertex' x+-- 'hasVertex' x . vertices1 == 'elem' x+-- 'vertexCount' . vertices1 == 'length' . 'Data.List.NonEmpty.nub'+-- 'vertexSet'   . vertices1 == Set.'Set.fromList' . 'Data.List.NonEmpty.toList'+-- @+vertices1 :: Ord a => NonEmpty a -> AdjacencyMap a+vertices1 = NAM . AM.vertices . toList+{-# NOINLINE [1] vertices1 #-}++-- | Construct the graph from a list of edges.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- edges1 [(x,y)]     == 'edge' x y+-- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub'+-- @+edges1 :: Ord a => NonEmpty (a, a) -> AdjacencyMap a+edges1 = NAM . AM.edges . toList++-- | Overlay a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- overlays1 [x]   == x+-- overlays1 [x,y] == 'overlay' x y+-- @+overlays1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a+overlays1 = viaL AM.overlays+{-# NOINLINE overlays1 #-}++-- | Connect a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- connects1 [x]   == x+-- connects1 [x,y] == 'connect' x y+-- @+connects1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a+connects1 = viaL AM.connects+{-# NOINLINE connects1 #-}++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf ('path1' xs)    ('circuit1' xs) ==  True+-- isSubgraphOf x y                         ==> x <= y+-- @+isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool+isSubgraphOf (NAM x) (NAM y) = AM.isSubgraphOf x y++-- | Check if a graph contains a given vertex.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasVertex x ('vertex' x) == True+-- hasVertex 1 ('vertex' 2) == False+-- @+hasVertex :: Ord a => a -> AdjacencyMap a -> Bool+hasVertex x = AM.hasVertex x . am++-- | Check if a graph contains a given edge.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasEdge x y ('vertex' z)       == False+-- hasEdge x y ('edge' x y)       == True+-- hasEdge x y . 'removeEdge' x y == 'const' False+-- hasEdge x y                  == 'elem' (x,y) . 'edgeList'+-- @+hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool+hasEdge x y = AM.hasEdge x y . am++-- | The number of vertices in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y+-- @+vertexCount :: AdjacencyMap a -> Int+vertexCount = AM.vertexCount . am++-- | The number of edges in a graph.+-- Complexity: /O(n)/ time.+--+-- @+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount            == 'length' . 'edgeList'+-- @+edgeCount :: AdjacencyMap a -> Int+edgeCount = AM.edgeCount . am++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexList1 ('vertex' x)  == [x]+-- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort'+-- @+vertexList1 :: AdjacencyMap a -> NonEmpty a+vertexList1 = unsafeNonEmpty . AM.vertexList . am++-- | The sorted list of edges of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeList ('vertex' x)     == []+-- edgeList ('edge' x y)     == [(x,y)]+-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)]+-- edgeList . 'edges'        == 'Data.List.NonEmpty.nub' . 'Data.List.sort'+-- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList+-- @+edgeList :: AdjacencyMap a -> [(a, a)]+edgeList = AM.edgeList . am++-- | The set of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexSet . 'vertex'    == Set.'Set.singleton'+-- vertexSet . 'vertices1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList'+-- vertexSet . 'clique1'   == Set.'Set.fromList' . 'Data.List.NonEmpty.toList'+-- @+vertexSet :: AdjacencyMap a -> Set a+vertexSet = AM.vertexSet . am++-- | The set of edges of a given graph.+-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.+--+-- @+-- edgeSet ('vertex' x) == Set.'Set.empty'+-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)+-- edgeSet . 'edges'    == Set.'Set.fromList'+-- @+edgeSet :: Ord a => AdjacencyMap a -> Set (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 x ('vertex' x) == Set.'Set.empty'+-- preSet 1 ('edge' 1 2) == Set.'Set.empty'+-- preSet y ('edge' x y) == Set.'Set.fromList' [x]+-- @+preSet :: Ord a => a -> AdjacencyMap a -> Set.Set a+preSet x = AM.preSet x . am++-- | The /postset/ of a vertex is the set of its /direct successors/.+-- Complexity: /O(log(n))/ time and /O(1)/ memory.+--+-- @+-- postSet x ('vertex' x) == Set.'Set.empty'+-- postSet x ('edge' x y) == Set.'Set.fromList' [y]+-- postSet 2 ('edge' 1 2) == Set.'Set.empty'+-- @+postSet :: Ord a => a -> AdjacencyMap a -> Set a+postSet x = AM.postSet x . am++-- | The /path/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- path1 [x]       == 'vertex' x+-- path1 [x,y]     == 'edge' x y+-- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1+-- @+path1 :: Ord a => NonEmpty a -> AdjacencyMap a+path1 = NAM . AM.path . toList++-- | The /circuit/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- circuit1 [x]       == 'edge' x x+-- circuit1 [x,y]     == 'edges1' [(x,y), (y,x)]+-- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1+-- @+circuit1 :: Ord a => NonEmpty a -> AdjacencyMap a+circuit1 = NAM . AM.circuit . toList++-- | The /clique/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- clique1 [x]        == 'vertex' x+-- clique1 [x,y]      == 'edge' x y+-- clique1 [x,y,z]    == 'edges1' [(x,y), (x,z), (y,z)]+-- clique1 (xs '<>' ys) == 'connect' (clique1 xs) (clique1 ys)+-- clique1 . 'Data.List.NonEmpty.reverse'  == 'transpose' . clique1+-- @+clique1 :: Ord a => NonEmpty a -> AdjacencyMap a+clique1 = NAM . AM.clique . toList+{-# NOINLINE [1] clique1 #-}++-- | The /biclique/ on two lists of vertices.+-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory.+--+-- @+-- biclique1 [x1,x2] [y1,y2] == 'edges1' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- biclique1 xs      ys      == 'connect' ('vertices1' xs) ('vertices1' ys)+-- @+biclique1 :: Ord a => NonEmpty a -> NonEmpty a -> AdjacencyMap a+biclique1 xs ys = NAM $ AM.biclique (toList xs) (toList ys)++-- TODO: Optimise.+-- | The /star/ formed by a centre vertex connected to a list of leaves.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- star x []    == 'vertex' x+-- star x [y]   == 'edge' x y+-- star x [y,z] == 'edges1' [(x,y), (x,z)]+-- @+star :: Ord a => a -> [a] -> AdjacencyMap a+star x = NAM . AM.star x+{-# INLINE star #-}++-- | The /stars/ formed by overlaying a list of 'star's. An inverse of+-- 'adjacencyList'.+-- Complexity: /O(L * log(n))/ time, memory and size, where /L/ is the total+-- size of the input.+--+-- @+-- stars1 [(x, [] )]               == 'vertex' x+-- stars1 [(x, [y])]               == 'edge' x y+-- stars1 [(x, ys )]               == 'star' x ys+-- stars1                          == 'overlays1' . 'fmap' ('uncurry' 'star')+-- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs '<>' ys)+-- @+stars1 :: Ord a => NonEmpty (a, [a]) -> AdjacencyMap a+stars1 = NAM . AM.stars . toList++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- tree (Node x [])                                         == 'vertex' x+-- tree (Node x [Node y [Node z []]])                       == 'path1' [x,y,z]+-- tree (Node x [Node y [], Node z []])                     == 'star' x [y,z]+-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges1' [(1,2), (1,3), (3,4), (3,5)]+-- @+tree :: Ord a => Tree a -> AdjacencyMap a+tree = NAM . AM.tree++-- | Remove a vertex from a given graph.+-- Complexity: /O(n*log(n))/ time.+--+-- @+-- removeVertex1 x ('vertex' x)          == Nothing+-- removeVertex1 1 ('vertex' 2)          == Just ('vertex' 2)+-- removeVertex1 x ('edge' x x)          == Nothing+-- removeVertex1 1 ('edge' 1 2)          == Just ('vertex' 2)+-- removeVertex1 x 'Control.Monad.>=>' removeVertex1 x == removeVertex1 x+-- @+removeVertex1 :: Ord a => a -> AdjacencyMap a -> Maybe (AdjacencyMap a)+removeVertex1 x = toNonEmpty . AM.removeVertex x . am++-- | Remove an edge from a given graph.+-- Complexity: /O(log(n))/ time.+--+-- @+-- removeEdge x y ('edge' x y)       == 'vertices1' [x,y]+-- removeEdge x y . removeEdge x y == removeEdge x y+-- removeEdge 1 1 (1 * 1 * 2 * 2)  == 1 * 2 * 2+-- removeEdge 1 2 (1 * 1 * 2 * 2)  == 1 * 1 + 2 * 2+-- @+removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+removeEdge x y = via (AM.removeEdge x y)++-- | 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 x x            == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y            == 'mergeVertices' (== x) y+-- @+replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+replaceVertex u v = via (AM.replaceVertex u v)++-- | Merge vertices satisfying a given predicate into a given vertex.+-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- mergeVertices ('const' False) x    == id+-- mergeVertices (== x) y           == 'replaceVertex' x y+-- mergeVertices 'even' 1 (0 * 2)     == 1 * 1+-- mergeVertices 'odd'  1 (3 + 4 * 5) == 4 * 1+-- @+mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a+mergeVertices p v = via (AM.mergeVertices p v)++-- | Transpose a given graph.+-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory.+--+-- @+-- transpose ('vertex' x)  == 'vertex' x+-- transpose ('edge' x y)  == 'edge' y x+-- transpose . transpose == id+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList'+-- @+transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a+transpose = via AM.transpose+{-# NOINLINE [1] transpose #-}++{-# RULES+"transpose/vertex"   forall x. transpose (vertex x) = vertex x+"transpose/overlay"  forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2)+"transpose/connect"  forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1)++"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs)+"transpose/connects1" forall xs. transpose (connects1 xs) = connects1 (reverse (fmap transpose xs))++"transpose/vertices1" forall xs. transpose (vertices1 xs) = vertices1 xs+"transpose/clique1"   forall xs. transpose (clique1 xs)   = clique1 (reverse xs)+ #-}++-- | Transform a graph by applying a function to each of its vertices. This is+-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric+-- 'AdjacencyMap'.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- gmap f ('vertex' x) == 'vertex' (f x)+-- gmap f ('edge' x y) == 'edge' (f x) (f y)+-- gmap id           == id+-- gmap f . gmap g   == gmap (f . g)+-- @+gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b+gmap f = via (AM.gmap 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.+--+-- @+-- induce1 ('const' True ) x == Just x+-- induce1 ('const' False) x == Nothing+-- induce1 (/= x)          == 'removeVertex1' x+-- induce1 p 'Control.Monad.>=>' induce1 q == induce1 (\\x -> p x && q x)+-- @+induce1 :: (a -> Bool) -> AdjacencyMap a -> Maybe (AdjacencyMap a)+induce1 p = toNonEmpty . AM.induce p . am++-- | Compute the /reflexive and transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time.+--+-- @+-- closure ('vertex' x)       == 'edge' x x+-- closure ('edge' x x)       == 'edge' x x+-- closure ('edge' x y)       == 'edges1' [(x,x), (x,y), (y,y)]+-- closure ('path1' $ 'Data.List.NonEmpty.nub' xs) == 'reflexiveClosure' ('clique1' $ 'Data.List.NonEmpty.nub' xs)+-- closure                  == 'reflexiveClosure' . 'transitiveClosure'+-- closure                  == 'transitiveClosure' . 'reflexiveClosure'+-- closure . closure        == closure+-- 'postSet' x (closure y)    == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y)+-- @+closure :: Ord a => AdjacencyMap a -> AdjacencyMap a+closure = via (AM.closure)++-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every+-- vertex.+-- Complexity: /O(n * log(n))/ time.+--+-- @+-- reflexiveClosure ('vertex' x)         == 'edge' x x+-- reflexiveClosure ('edge' x x)         == 'edge' x x+-- reflexiveClosure ('edge' x y)         == 'edges1' [(x,x), (x,y), (y,y)]+-- reflexiveClosure . reflexiveClosure == reflexiveClosure+-- @+reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+reflexiveClosure = via AM.reflexiveClosure++-- | Compute the /symmetric closure/ of a graph by overlaying it with its own+-- transpose.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- symmetricClosure ('vertex' x)         == 'vertex' x+-- symmetricClosure ('edge' x y)         == 'edges1' [(x,y), (y,x)]+-- symmetricClosure x                  == 'overlay' x ('transpose' x)+-- symmetricClosure . symmetricClosure == symmetricClosure+-- @+symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+symmetricClosure = via AM.symmetricClosure++-- | Compute the /transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time.+--+-- @+-- transitiveClosure ('vertex' x)          == 'vertex' x+-- transitiveClosure ('edge' x y)          == 'edge' x y+-- transitiveClosure ('path1' $ 'Data.List.NonEmpty.nub' xs)    == 'clique1' ('Data.List.NonEmpty.nub' xs)+-- transitiveClosure . transitiveClosure == transitiveClosure+-- @+transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+transitiveClosure = via AM.transitiveClosure