algebraic-graphs 0.4 → 0.5

raw patch · 61 files changed

+9473/−5354 lines, 61 filesdep +transformersdep −base-compatdep −base-orphansdep −bifunctorsdep ~QuickCheckdep ~extradep ~inspection-testingPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependencies removed: base-compat, base-orphans, bifunctors, semigroups

Dependency ranges changed: QuickCheck, extra, inspection-testing

API changes (from Hackage documentation)

Files

• AUTHORS.md +23/−0
• CHANGES.md +23/−0
• LICENSE +1/−1
• algebraic-graphs.cabal +52/−79
• src/Algebra/Graph.hs +278/−140
• src/Algebra/Graph/Acyclic/AdjacencyMap.hs +543/−0
• src/Algebra/Graph/AdjacencyIntMap.hs +202/−18
• src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs +190/−30
• src/Algebra/Graph/AdjacencyIntMap/Internal.hs +0/−206
• src/Algebra/Graph/AdjacencyMap.hs +238/−16
• src/Algebra/Graph/AdjacencyMap/Algorithm.hs +285/−43
• src/Algebra/Graph/AdjacencyMap/Internal.hs +0/−207
• src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs +836/−0
• src/Algebra/Graph/Class.hs +11/−13
• src/Algebra/Graph/Export.hs +3/−5
• src/Algebra/Graph/Export/Dot.hs +1/−1
• src/Algebra/Graph/Fold.hs +0/−736
• src/Algebra/Graph/HigherKinded/Class.hs +4/−16
• src/Algebra/Graph/Internal.hs +49/−24
• src/Algebra/Graph/Label.hs +32/−23
• src/Algebra/Graph/Labelled.hs +34/−14
• src/Algebra/Graph/Labelled/AdjacencyMap.hs +104/−20
• src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +0/−115
• src/Algebra/Graph/Labelled/Example/Automaton.hs +1/−12
• src/Algebra/Graph/NonEmpty.hs +37/−27
• src/Algebra/Graph/NonEmpty/AdjacencyMap.hs +208/−62
• src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs +0/−165
• src/Algebra/Graph/Relation.hs +257/−12
• src/Algebra/Graph/Relation/Internal.hs +0/−250
• src/Algebra/Graph/Relation/InternalDerived.hs +0/−130
• src/Algebra/Graph/Relation/Preorder.hs +50/−3
• src/Algebra/Graph/Relation/Reflexive.hs +37/−3
• src/Algebra/Graph/Relation/Symmetric.hs +237/−57
• src/Algebra/Graph/Relation/Symmetric/Internal.hs +0/−215
• src/Algebra/Graph/Relation/Transitive.hs +43/−3
• src/Algebra/Graph/ToGraph.hs +69/−101
• src/Algebra/Graph/Undirected.hs +819/−0
• src/Data/Graph/Typed.hs +95/−53
• test/Algebra/Graph/Test.hs +43/−32
• test/Algebra/Graph/Test/API.hs +633/−280
• test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs +502/−0
• test/Algebra/Graph/Test/AdjacencyIntMap.hs +14/−5
• test/Algebra/Graph/Test/AdjacencyMap.hs +20/−5
• test/Algebra/Graph/Test/Arbitrary.hs +81/−73
• test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs +628/−0
• test/Algebra/Graph/Test/Export.hs +3/−9
• test/Algebra/Graph/Test/Fold.hs +0/−40
• test/Algebra/Graph/Test/Generic.hs +2069/−1833
• test/Algebra/Graph/Test/Graph.hs +35/−103
• test/Algebra/Graph/Test/Internal.hs +4/−12
• test/Algebra/Graph/Test/Label.hs +143/−0
• test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +10/−6
• test/Algebra/Graph/Test/Labelled/Graph.hs +8/−3
• test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs +33/−21
• test/Algebra/Graph/Test/NonEmpty/Graph.hs +25/−17
• test/Algebra/Graph/Test/Relation.hs +16/−11
• test/Algebra/Graph/Test/Relation/SymmetricRelation.hs +12/−8
• test/Algebra/Graph/Test/RewriteRules.hs +315/−76
• test/Algebra/Graph/Test/Undirected.hs +90/−0
• test/Data/Graph/Test/Typed.hs +4/−3
• test/Main.hs +23/−17

@@ -0,0 +1,23 @@+The Alga library was originally developed by++* [Andrey Mokhov](mailto:andrey.mokhov@gmail.com) [@snowleopard](https://github.com/snowleopard)++but over time many contributors helped make it much better, including (among others):++* [Vasily Alferov](mailto:vasily.v.alferov@gmail.com) [@vasalf](https://github.com/vasalf)+* [Piotr Gawryś](mailto:pgawrys2@gmail.com) [@Avasil](https://github.com/Avasil)+* [Alexandre Moine](mailto:alexandre@moine.me) [@nobrakal](https://github.com/nobrakal)+* [Joseph Novakovich](mailto:jrn@bluefarm.ca) [@jitwit](https://github.com/jitwit)+* [Adithya Obilisetty](mailto:adi.obilisetty@gmail.com) [@adithyaov](https://github.com/adithyaov)+* [Armando Santos](mailto:armandoifsantos@gmail.com) [@bolt12](https://github.com/bolt12)++If you are not on this list, it's not because your contributions are not+appreciated, but because I didn't want to add your name and contact details+without your consent. Please fix this by sending a PR, keeping the list+alphabetical (sorted by last and then first name).++Also see the autogenerated yet still possibly incomplete+[list of contributors](https://github.com/snowleopard/alga/graphs/contributors).++Thank you all for your help!+Andrey

@@ -1,5 +1,28 @@ # Change log +## 0.5++* #217, #224, #227, #234, #235: Add new BFS, DFS, topological sort, and SCC+                                algorithms for adjacency maps.+* #228, #247, #254: Improve algebraic graph fusion.+* #207, #218, #255: Add `Bipartite.Undirected.AdjacencyMap`.+* #220, #237, #255: Add `Algebra.Graph.Undirected`.+* #203, #215, #223: Add `Acyclic.AdjacencyMap`.+* #202, #209, #211: Add `induceJust` and `induceJust1`.+* #172, #245: Stop supporting GHC 7.8.4 and GHC 7.10.3.+* #208: Add `fromNonEmpty` to `NonEmpty.AdjacencyMap`.+* #208: Add `fromAdjacencyMap` to `AdjacencyIntMap`.+* #208: Drop `Internal` modules for `AdjacencyIntMap`, `AdjacencyMap`,+        `Labelled.AdjacencyMap`, `NonEmpty.AdjacencyMap`, `Relation` and+        `Relation.Symmetric`.+* #206: Add `Algebra.Graph.AdjacencyMap.box`.+* #205: Drop dependencies on `base-compat` and `base-orphans`.+* #205: Remove `Algebra.Graph.Fold`.+* #151: Remove `ToGraph.size`. Demote `ToGraph.adjacencyMap`,+        `ToGraph.adjacencyIntMap`, `ToGraph.adjacencyMapTranspose` and+        `ToGraph.adjacencyIntMapTranspose` to functions.+* #204: Derive `Generic` and `NFData` for `Algebra.Graph` and `Algebra.Graph.Labelled`.+ ## 0.4  * #174: Add `Symmetric.Relation`.

@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2016-2018 Andrey Mokhov+Copyright (c) 2016-2020 Andrey Mokhov  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -1,5 +1,6 @@+cabal-version: 2.2 name:          algebraic-graphs-version:       0.4+version:       0.5 synopsis:      A library for algebraic graph construction and transformation license:       MIT license-file:  LICENSE@@ -10,13 +11,11 @@ homepage:      https://github.com/snowleopard/alga category:      Algebra, Algorithms, Data Structures, Graphs build-type:    Simple-cabal-version: 1.18-tested-with:   GHC==7.8.4,-               GHC==7.10.3,-               GHC==8.0.2,-               GHC==8.2.2,-               GHC==8.4.3,-               GHC==8.6.4+tested-with:   GHC == 8.0.2,+               GHC == 8.2.2,+               GHC == 8.4.4,+               GHC == 8.6.5,+               GHC == 8.8.1 stability:     experimental description:     <https://github.com/snowleopard/alga Alga> is a library for algebraic construction and@@ -50,15 +49,14 @@     <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 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.+    can be used for polymorphic construction and manipulation of 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     <https://github.com/snowleopard/alga/issues discussions on the library API>.  extra-doc-files:+    AUTHORS.md     CHANGES.md     README.md @@ -66,122 +64,97 @@     type:     git     location: https://github.com/snowleopard/alga.git +common common-settings+    build-depends:      array        >= 0.4     && < 0.6,+                        base         >= 4.7     && < 5,+                        containers   >= 0.5.5.1 && < 0.8,+                        deepseq      >= 1.3.0.1 && < 1.5,+                        mtl          >= 2.1     && < 2.3,+                        transformers >= 0.4     && < 0.6+    default-language:   Haskell2010+    default-extensions: FlexibleContexts+                        FlexibleInstances+                        GeneralizedNewtypeDeriving+                        ScopedTypeVariables+                        TupleSections+                        TypeApplications+                        TypeFamilies+    other-extensions:   CPP+                        DeriveFunctor+                        OverloadedStrings+                        RankNTypes+                        RecordWildCards+    GHC-options:        -Wall+                        -Wcompat+                        -Wincomplete-record-updates+                        -Wincomplete-uni-patterns+                        -Wredundant-constraints+                        -fno-warn-name-shadowing+                        -fspec-constr+ library+    import:             common-settings     hs-source-dirs:     src     exposed-modules:    Algebra.Graph,+                        Algebra.Graph.Undirected,+                        Algebra.Graph.Acyclic.AdjacencyMap,                         Algebra.Graph.AdjacencyIntMap,                         Algebra.Graph.AdjacencyIntMap.Algorithm,-                        Algebra.Graph.AdjacencyIntMap.Internal,                         Algebra.Graph.AdjacencyMap,                         Algebra.Graph.AdjacencyMap.Algorithm,-                        Algebra.Graph.AdjacencyMap.Internal,+                        Algebra.Graph.Bipartite.Undirected.AdjacencyMap,                         Algebra.Graph.Class,                         Algebra.Graph.Export,                         Algebra.Graph.Export.Dot,-                        Algebra.Graph.Fold,                         Algebra.Graph.HigherKinded.Class,                         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,                         Algebra.Graph.Relation.Preorder,                         Algebra.Graph.Relation.Reflexive,                         Algebra.Graph.Relation.Symmetric,-                        Algebra.Graph.Relation.Symmetric.Internal,                         Algebra.Graph.Relation.Transitive,                         Algebra.Graph.ToGraph,                         Data.Graph.Typed-    build-depends:      array       >= 0.4     && < 0.6,-                        base        >= 4.7     && < 5,-                        base-compat >= 0.9.1   && < 0.11,-                        containers  >= 0.5.5.1 && < 0.8,-                        deepseq     >= 1.3.0.1 && < 1.5,-                        mtl         >= 2.1     && < 2.3-    if !impl(ghc >= 8.0)-        build-depends:  semigroups  >= 0.18.3  && < 0.18.4-    if !impl(ghc >= 7.10)-        build-depends:  bifunctors  >= 5       && < 5.6-    default-language:   Haskell2010-    default-extensions: FlexibleContexts-                        FlexibleInstances-                        GeneralizedNewtypeDeriving-                        ScopedTypeVariables-                        TupleSections-                        TypeFamilies-    other-extensions:   CPP-                        DeriveFunctor-                        OverloadedStrings-                        RecordWildCards-    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  test-suite test-alga+    import:             common-settings     hs-source-dirs:     test     type:               exitcode-stdio-1.0     main-is:            Main.hs     other-modules:      Algebra.Graph.Test,                         Algebra.Graph.Test.API,+                        Algebra.Graph.Test.Acyclic.AdjacencyMap,                         Algebra.Graph.Test.AdjacencyIntMap,                         Algebra.Graph.Test.AdjacencyMap,                         Algebra.Graph.Test.Arbitrary,+                        Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap,                         Algebra.Graph.Test.Export,-                        Algebra.Graph.Test.Fold,                         Algebra.Graph.Test.Generic,                         Algebra.Graph.Test.Graph,+                        Algebra.Graph.Test.Undirected,                         Algebra.Graph.Test.Internal,+                        Algebra.Graph.Test.Label,                         Algebra.Graph.Test.Labelled.AdjacencyMap,                         Algebra.Graph.Test.Labelled.Graph,                         Algebra.Graph.Test.NonEmpty.AdjacencyMap,                         Algebra.Graph.Test.NonEmpty.Graph,                         Algebra.Graph.Test.Relation,                         Algebra.Graph.Test.Relation.SymmetricRelation,+                        Algebra.Graph.Test.RewriteRules,                         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,-                        base-compat  >= 0.9.1   && < 0.11,-                        base-orphans >= 0.5.4   && < 0.9,-                        containers   >= 0.5.5.1 && < 0.8,-                        extra        >= 1.5     && < 2,-                        QuickCheck   >= 2.9     && < 2.14-    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-                        ScopedTypeVariables-                        TupleSections-                        TypeFamilies+                        extra              >= 1.4     && < 2,+                        inspection-testing >= 0.4.2.2 && < 0.5,+                        QuickCheck         >= 2.10    && < 2.14     other-extensions:   ConstrainedClassMethods                         ConstraintKinds-                        RankNTypes+                        MultiParamTypeClasses+                        TemplateHaskell                         ViewPatterns

@@ -1,8 +1,8 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveGeneric, RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -26,7 +26,7 @@     empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,      -- * Graph folding-    foldg,+    foldg, buildg,      -- * Relations on graphs     isSubgraphOf, (===),@@ -41,7 +41,7 @@      -- * Graph transformation     removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex,-    transpose, induce, simplify, sparsify, sparsifyKL,+    transpose, induce, induceJust, simplify, sparsify, sparsifyKL,      -- * Graph composition     compose, box,@@ -50,17 +50,15 @@     Context (..), context     ) where -import Prelude ()-import Prelude.Compat- import Control.Applicative (Alternative)-import Control.DeepSeq (NFData (..))-import Control.Monad.Compat+import Control.DeepSeq+import Control.Monad (MonadPlus (..)) import Control.Monad.State (runState, get, put) import Data.Foldable (toList) import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import Data.Tree+import GHC.Generics  import Algebra.Graph.Internal @@ -175,12 +173,16 @@ @'empty' <= x x     <= x + y x + y <= x * y@++Deforestation (fusion) is implemented for some functions in this module. This means+that when a function tagged as a \"good producer\" is composed with a \"good consumer\",+the intermediate structure will not be built. -} data Graph a = Empty              | Vertex a              | Overlay (Graph a) (Graph a)              | Connect (Graph a) (Graph a)-             deriving (Show)+             deriving (Show, Generic)  {- Note [Functions for rewrite rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -211,12 +213,10 @@ creating our own intermediate functions for guiding rewrite rules when needed. -} +-- | 'fmap' is a good consumer and producer. instance Functor Graph where-    fmap = fmapR--fmapR :: (a -> b) -> Graph a -> Graph b-fmapR f g = bindR g (vertex . f)-{-# INLINE fmapR #-}+    fmap f g = g >>= (vertex . f)+    {-# INLINE fmap #-}  instance NFData a => NFData (Graph a) where     rnf Empty         = ()@@ -234,9 +234,11 @@     abs         = id     negate      = id +-- | `==` is a good consumer of both arguments. instance Ord a => Eq (Graph a) where     (==) = eqR +-- | 'compare' is a good consumer of both arguments. instance Ord a => Ord (Graph a) where     compare = ordR @@ -244,39 +246,40 @@ -- 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 #-}+{-# INLINE [2] eqR #-} {-# RULES "eqR/Int" eqR = eqIntR #-}  -- Like 'eqR' but specialised for graphs with vertices of type 'Int'. eqIntR :: Graph Int -> Graph Int -> Bool eqIntR x y = toAdjacencyIntMap x == toAdjacencyIntMap y+{-# INLINE eqIntR #-}  -- 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 #-}+{-# INLINE [2] 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)+{-# INLINE ordIntR #-} +-- TODO: It should be a good consumer of its second argument too.+-- | `<*>` is a good consumer of its first agument and producer. instance Applicative Graph where-    pure  = Vertex-    (<*>) = apR--apR :: Graph (a -> b) -> Graph a -> Graph b-apR f x = bindR f (<$> x)-{-# INLINE apR #-}+    pure    = Vertex+    f <*> x = buildg $ \e v o c ->+      foldg e (\w -> foldg e (v . w) o c x) o c f+    {-# INLINE (<*>) #-} +-- | `>>=` is a good consumer and producer. instance Monad Graph where     return = pure-    (>>=)  = bindR--bindR :: Graph a -> (a -> Graph b) -> Graph b-bindR g f = foldg Empty f Overlay Connect g-{-# INLINE [0] bindR #-}+    g >>= f  = buildg $ \e v o c ->+      foldg e (composeR (foldg e v o c) f) o c g+    {-# INLINE (>>=) #-}  instance Alternative Graph where     empty = Empty@@ -306,7 +309,7 @@ -- -- @ -- 'isEmpty'     (vertex x) == False--- 'hasVertex' x (vertex x) == True+-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount'   (vertex x) == 0 -- 'size'        (vertex x) == 1@@ -327,6 +330,7 @@ -- @ edge :: a -> a -> Graph a edge x y = connect (vertex x) (vertex y)+{-# INLINE edge #-}  -- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a -- commutative, associative and idempotent operation with the identity 'empty'.@@ -371,10 +375,15 @@ connect = Connect {-# INLINE connect #-} +-- TODO: Simplifiy the definition to `overlays . map vertex` while presreving+-- goodness properties (which is not trivial since overlays is only a good+-- consumer of lists and not of lists of graphs). -- | 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. --+-- Good consumer of lists and producer of graphs.+-- -- @ -- vertices []            == 'empty' -- vertices [x]           == 'vertex' x@@ -383,25 +392,32 @@ -- 'vertexSet'   . vertices == Set.'Set.fromList' -- @ vertices :: [a] -> Graph a-vertices = overlays . map vertex+vertices xs = buildg $ \e v o _ -> combineR e o v xs {-# INLINE vertices #-}  -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. --+-- Good consumer of lists and producer of graphs.+-- -- @ -- edges []          == 'empty' -- edges [(x,y)]     == 'edge' x y+-- edges             == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: [(a, a)] -> Graph a-edges = overlays . map (uncurry edge)+edges xs = buildg $ \e v o c ->+  combineR e o (\e -> c (v (fst e)) (v (snd e))) xs+{-# INLINE edges #-}  -- | 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. --+-- Good consumer of lists and producer of graphs.+-- -- @ -- overlays []        == 'empty' -- overlays [x]       == x@@ -410,13 +426,15 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [Graph a] -> Graph a-overlays = fromMaybe empty . foldr1Safe overlay-{-# INLINE [1] overlays #-}+overlays xs = buildg $ \e v o c -> combineR e o (foldg e v o c) xs+{-# INLINE overlays #-}  -- | Connect 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. --+-- Good consumer of lists and producer of graphs.+-- -- @ -- connects []        == 'empty' -- connects [x]       == x@@ -425,15 +443,23 @@ -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: [Graph a] -> Graph a-connects = fromMaybe empty . foldr1Safe connect-{-# INLINE [1] connects #-}+connects xs = buildg $ \e v o c -> combineR e c (foldg e v o c) xs+{-# INLINE connects #-} +-- Safe version of foldr with a map (the composition is optimized)+-- This is a good consumer of lists.+combineR :: c -> (c -> c -> c) -> (a -> c) -> [a] -> c+combineR e o f = fromMaybe e . foldr1Safe o . map f+{-# INLINE combineR #-}+ -- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying -- the provided functions to the leaves and internal nodes of the expression. -- The order of arguments is: empty, vertex, overlay and connect. -- Complexity: /O(s)/ applications of given functions. As an example, the -- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. --+-- Good consumer.+-- -- @ -- foldg 'empty' 'vertex'        'overlay' 'connect'        == id -- foldg 'empty' 'vertex'        'overlay' ('flip' 'connect') == 'transpose'@@ -459,18 +485,34 @@     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)  #-} +-- | Build a graph given an interpretation of the four graph construction primitives 'empty',+-- 'vertex', 'overlay' and 'connect', in this order. See examples for further clarification.+--+-- Functions expressed with 'buildg' are good producers.+--+-- @+-- buildg f                                                   == f 'empty' 'vertex' 'overlay' 'connect'+-- buildg (\\e _ _ _ -> e)                                     == 'empty'+-- buildg (\\_ v _ _ -> v x)                                   == 'vertex' x+-- buildg (\\e v o c -> o ('foldg' e v o c x) ('foldg' e v o c y)) == 'overlay' x y+-- buildg (\\e v o c -> c ('foldg' e v o c x) ('foldg' e v o c y)) == 'connect' x y+-- buildg (\\e v o _ -> 'foldr' o e ('map' v xs))                  == 'vertices' xs+-- buildg (\\e v o c -> 'foldg' e v o ('flip' c) g)                == 'transpose' g+-- 'foldg' e v o c (buildg f)                                   == f e v o c+-- @+buildg :: (forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b) -> Graph a+buildg f = f Empty Vertex Overlay Connect+{-# INLINE [1] buildg #-}+ -- | 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/. --+-- Good consumer of both arguments.+-- -- @ -- isSubgraphOf 'empty'         x             ==  True -- isSubgraphOf ('vertex' x)    'empty'         ==  False@@ -481,12 +523,13 @@ -- @ isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool isSubgraphOf x y = AM.isSubgraphOf (toAdjacencyMap x) (toAdjacencyMap y)-{-# NOINLINE [1] isSubgraphOf #-}+{-# INLINE [2] isSubgraphOf #-} {-# RULES "isSubgraphOf/Int" isSubgraphOf = isSubgraphOfIntR #-}  -- Like 'isSubgraphOf' but specialised for graphs with vertices of type 'Int'. isSubgraphOfIntR :: Graph Int -> Graph Int -> Bool isSubgraphOfIntR x y = AIM.isSubgraphOf (toAdjacencyIntMap x) (toAdjacencyIntMap y)+{-# INLINE isSubgraphOfIntR #-}  -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time.@@ -508,9 +551,11 @@  infix 4 === --- | Check if a graph is empty. A convenient alias for 'null'.+-- | Check if a graph is empty. -- Complexity: /O(s)/ time. --+-- Good consumer.+-- -- @ -- isEmpty 'empty'                       == True -- isEmpty ('overlay' 'empty' 'empty')       == True@@ -520,11 +565,14 @@ -- @ isEmpty :: Graph a -> Bool isEmpty = foldg True (const False) (&&) (&&)+{-# INLINE isEmpty #-}  -- | The /size/ of a graph, i.e. the number of leaves of the expression -- including 'empty' leaves. -- Complexity: /O(s)/ time. --+-- Good consumer.+-- -- @ -- size 'empty'         == 1 -- size ('vertex' x)    == 1@@ -535,23 +583,46 @@ -- @ size :: Graph a -> Int size = foldg 1 (const 1) (+) (+)+{-# INLINE size #-}  -- | Check if a graph contains a given vertex. -- Complexity: /O(s)/ time. --+-- Good consumer.+-- -- @ -- hasVertex x 'empty'            == False--- hasVertex x ('vertex' x)       == True--- hasVertex 1 ('vertex' 2)       == False+-- hasVertex x ('vertex' y)       == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Eq a => a -> Graph a -> Bool hasVertex x = foldg False (==x) (||) (||)+{-# INLINE hasVertex #-} {-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} +{- Note [The implementation of hasEdge]++We fold a graph into a function of type Int -> Int where the Int stands for the+number of vertices of the specified edge that have been matched so far. The edge+belongs to the graph if we reach the number 2. Note that this algorithm can be+generalised to algebraic graphs of higher dimensions, e.g. we can similarly find+3-edges (triangles), 4-edges (tetrahedra) and k-edges in O(s) time.++The four graph constructors are interpreted as follows:++  * Empty       : the matching number is unchanged;+  * Vertex x    : if x matches the next vertex, the number is incremented;+  * Overlay x y : pick the best match in the two subexpressions;+  * Connect x y : match the subexpressions one after another.++Note that in the last two cases we can (and do) shortcircuit the computation as+soon as the edge is fully matched in one of the subexpressions.+-} -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. --+-- Good consumer.+-- -- @ -- hasEdge x y 'empty'            == False -- hasEdge x y ('vertex' z)       == False@@ -560,23 +631,23 @@ -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Eq a => a -> a -> Graph a -> Bool-hasEdge s t g = hit g == Edge+hasEdge s t g = foldg id v o c g 0 == 2   where-    hit Empty         = Miss-    hit (Vertex x   ) = if x == s then Tail else Miss-    hit (Overlay x y) = case hit x of-        Miss -> hit y-        Tail -> max Tail (hit y)-        Edge -> Edge-    hit (Connect x y) = case hit x of-        Miss -> hit y-        Tail -> if hasVertex t y then Edge else Tail-        Edge -> Edge+    v x 0   = if x == s then 1 else 0+    v x _   = if x == t then 2 else 1+    o x y a = case x a of+        0 -> y a+        1 -> if y a == 2 then 2 else 1+        _ -> 2 :: Int+    c x y a = case x a of { 2 -> 2; res -> y res }+{-# INLINE hasEdge #-} {-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-}  -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. --+-- Good consumer.+-- -- @ -- vertexCount 'empty'             ==  0 -- vertexCount ('vertex' x)        ==  1@@ -585,17 +656,20 @@ -- @ vertexCount :: Ord a => Graph a -> Int vertexCount = Set.size . vertexSet-{-# INLINE [1] vertexCount #-}+{-# INLINE [2] vertexCount #-} {-# RULES "vertexCount/Int" vertexCount = vertexIntCountR #-}  -- Like 'vertexCount' but specialised for graphs with vertices of type 'Int'. vertexIntCountR :: Graph Int -> Int vertexIntCountR = IntSet.size . vertexIntSetR+{-# INLINE vertexIntCountR #-}  -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a -- graph can be quadratic with respect to the expression size /s/. --+-- Good consumer.+-- -- @ -- edgeCount 'empty'      == 0 -- edgeCount ('vertex' x) == 0@@ -604,16 +678,19 @@ -- @ edgeCount :: Ord a => Graph a -> Int edgeCount = AM.edgeCount . toAdjacencyMap-{-# INLINE [1] edgeCount #-}+{-# INLINE [2] edgeCount #-} {-# RULES "edgeCount/Int" edgeCount = edgeCountIntR #-}  -- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. edgeCountIntR :: Graph Int -> Int edgeCountIntR = AIM.edgeCount . toAdjacencyIntMap+{-# INLINE edgeCountIntR #-}  -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --+-- Good consumer of graphs and producer of lists.+-- -- @ -- vertexList 'empty'      == [] -- vertexList ('vertex' x) == [x]@@ -621,17 +698,20 @@ -- @ vertexList :: Ord a => Graph a -> [a] vertexList = Set.toAscList . vertexSet-{-# INLINE [1] vertexList #-}+{-# INLINE [2] vertexList #-} {-# RULES "vertexList/Int" vertexList = vertexIntListR #-}  -- Like 'vertexList' but specialised for graphs with vertices of type 'Int'. vertexIntListR :: Graph Int -> [Int] vertexIntListR = IntSet.toList . vertexIntSetR+{-# INLINE vertexIntListR #-}  -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of -- edges /m/ of a graph can be quadratic with respect to the expression size /s/. --+-- Good consumer of graphs and producer of lists.+-- -- @ -- edgeList 'empty'          == [] -- edgeList ('vertex' x)     == []@@ -642,16 +722,19 @@ -- @ edgeList :: Ord a => Graph a -> [(a, a)] edgeList = AM.edgeList . toAdjacencyMap-{-# INLINE [1] edgeList #-}+{-# INLINE [2] edgeList #-} {-# RULES "edgeList/Int" edgeList = edgeIntListR #-}  -- Like 'edgeList' but specialised for graphs with vertices of type 'Int'. edgeIntListR :: Graph Int -> [(Int, Int)] edgeIntListR = AIM.edgeList . toAdjacencyIntMap+{-# INLINE edgeIntListR #-}  -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --+-- Good consumer.+-- -- @ -- vertexSet 'empty'      == Set.'Set.empty' -- vertexSet . 'vertex'   == Set.'Set.singleton'@@ -659,14 +742,18 @@ -- @ vertexSet :: Ord a => Graph a -> Set.Set a vertexSet = foldg Set.empty Set.singleton Set.union Set.union+{-# INLINE vertexSet #-}  -- 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+{-# INLINE vertexIntSetR #-}  -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. --+-- Good consumer.+-- -- @ -- edgeSet 'empty'      == Set.'Set.empty' -- edgeSet ('vertex' x) == Set.'Set.empty'@@ -675,16 +762,19 @@ -- @ edgeSet :: Ord a => Graph a -> Set.Set (a, a) edgeSet = AM.edgeSet . toAdjacencyMap-{-# INLINE [1] edgeSet #-}+{-# INLINE [2] edgeSet #-} {-# RULES "edgeSet/Int" edgeSet = edgeIntSetR #-}  -- Like 'edgeSet' but specialised for graphs with vertices of type 'Int'. edgeIntSetR :: Graph Int -> Set.Set (Int,Int) edgeIntSetR = AIM.edgeSet . toAdjacencyIntMap+{-# INLINE edgeIntSetR #-}  -- | The sorted /adjacency list/ of a graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory. --+-- Good consumer.+-- -- @ -- adjacencyList 'empty'          == [] -- adjacencyList ('vertex' x)     == [(x, [])]@@ -694,6 +784,7 @@ -- @ adjacencyList :: Ord a => Graph a -> [(a, [a])] adjacencyList = AM.adjacencyList . toAdjacencyMap+{-# INLINE adjacencyList #-} {-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-}  -- TODO: This is a very inefficient implementation. Find a way to construct an@@ -702,15 +793,21 @@ -- Convert a graph to 'AM.AdjacencyMap'. toAdjacencyMap :: Ord a => Graph a -> AM.AdjacencyMap a toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect+{-# INLINE toAdjacencyMap #-}  -- 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+{-# INLINE toAdjacencyIntMap #-} +-- TODO: Make path a good consumer of lists, that is, express it with foldr.+-- This is not straightforward if we want to preserve efficiency. -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. --+-- Good producer.+-- -- @ -- path []        == 'empty' -- path [x]       == 'vertex' x@@ -718,14 +815,21 @@ -- path . 'reverse' == 'transpose' . path -- @ path :: [a] -> Graph a-path xs = case xs of []     -> empty-                     [x]    -> vertex x-                     (_:ys) -> edges (zip xs ys)+path xs = buildg $ \e v o c ->+  case xs of+    []     -> e+    [x]    -> v x+    (_:ys) -> foldg e v o c $ edges (zip xs ys)+{-# INLINE path #-} +-- TODO: Make circuit a good consumer of lists, that is, express it with foldr.+-- This is not straightforward if we want to preserve efficiency. -- | The /circuit/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. --+-- Good producer.+-- -- @ -- circuit []        == 'empty' -- circuit [x]       == 'edge' x x@@ -733,13 +837,18 @@ -- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: [a] -> Graph a-circuit []     = empty-circuit (x:xs) = path $ [x] ++ xs ++ [x]+circuit xs = buildg $ \e v o c ->+  case xs of+    [] -> e+    (x:xs) -> foldg e v o c $ path $ [x] ++ xs ++ [x]+{-# INLINE circuit #-}  -- | The /clique/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. --+-- Good consumer of lists and producer of graphs.+-- -- @ -- clique []         == 'empty' -- clique [x]        == 'vertex' x@@ -749,13 +858,15 @@ -- clique . 'reverse'  == 'transpose' . clique -- @ clique :: [a] -> Graph a-clique = connects . map vertex-{-# INLINE [1] clique #-}+clique xs = buildg $ \e v _ c -> combineR e c v xs+{-# INLINE clique #-}  -- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. --+-- Good consumer of both arguments and producer of graphs.+-- -- @ -- biclique []      []      == 'empty' -- biclique [x]     []      == 'vertex' x@@ -764,14 +875,21 @@ -- biclique xs      ys      == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [a] -> [a] -> Graph a-biclique xs [] = vertices xs-biclique [] ys = vertices ys-biclique xs ys = connect (vertices xs) (vertices ys)+biclique xs ys = buildg $ \e v o c ->+  case foldr1Safe o (map v xs) of+    Nothing -> foldg e v o c $ vertices ys+    Just xs ->+      case foldr1Safe o (map v ys) of+        Nothing -> xs+        Just ys -> c xs ys+{-# INLINE biclique #-}  -- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. --+-- Good consumer of lists and good producer of graphs.+-- -- @ -- star x []    == 'vertex' x -- star x [y]   == 'edge' x y@@ -779,8 +897,10 @@ -- star x ys    == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: a -> [a] -> Graph a-star x [] = vertex x-star x ys = connect (vertex x) (vertices ys)+star x ys = buildg $ \_ v o c ->+  case foldr1Safe o (map v ys) of+    Nothing -> v x+    Just vertices  -> c (v x) vertices {-# INLINE star #-}  -- | The /stars/ formed by overlaying a list of 'star's. An inverse of@@ -788,6 +908,8 @@ -- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the -- input. --+-- Good consumer of lists and producer of graphs.+-- -- @ -- stars []                      == 'empty' -- stars [(x, [])]               == 'vertex' x@@ -798,7 +920,8 @@ -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: [(a, [a])] -> Graph a-stars = overlays . map (uncurry star)+stars xs = buildg $ \e v o c ->+  combineR e o (foldg e v o c . uncurry star) xs {-# INLINE stars #-}  -- | The /tree graph/ constructed from a given 'Tree.Tree' data structure.@@ -901,6 +1024,8 @@ -- | Remove a vertex from a given graph. -- Complexity: /O(s)/ time, memory and size. --+-- Good consumer and producer.+-- -- @ -- removeVertex x ('vertex' x)       == 'empty' -- removeVertex 1 ('vertex' 2)       == 'vertex' 2@@ -940,6 +1065,8 @@ -- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O(s)/ time, memory and size. --+-- Good consumer and producer.+-- -- @ -- replaceVertex x x            == id -- replaceVertex x y ('vertex' x) == 'vertex' y@@ -947,12 +1074,15 @@ -- @ replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex u v = fmap $ \w -> if w == u then v else w+{-# INLINE replaceVertex #-} {-# 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. --+-- Good consumer and producer.+-- -- @ -- mergeVertices ('const' False) x    == id -- mergeVertices (== x) y           == 'replaceVertex' x y@@ -961,12 +1091,15 @@ -- @ mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a mergeVertices p v = fmap $ \w -> if p w then v else w+{-# INLINE mergeVertices #-}  -- | Split a vertex into a list of vertices with the same connectivity. -- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of -- occurrences of the vertex in the expression and /L/ is the length of the -- given list. --+-- Good consumer of lists and producer of graphs.+-- -- @ -- splitVertex x []                  == 'removeVertex' x -- splitVertex x [x]                 == id@@ -974,12 +1107,17 @@ -- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @ splitVertex :: Eq a => a -> [a] -> Graph a -> Graph a-splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w+splitVertex x us g = buildg $ \e v o c ->+  let gus = foldg e v o c (vertices us) in+  foldg e (\w -> if w == x then gus else v w) o c g+{-# INLINE splitVertex #-} {-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-}  -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. --+-- Good consumer and producer.+-- -- @ -- transpose 'empty'       == 'empty' -- transpose ('vertex' x)  == 'vertex' x@@ -989,14 +1127,17 @@ -- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Graph a -> Graph a-transpose = foldg Empty Vertex Overlay (flip Connect)+transpose g = buildg $ \e v o c -> foldg e v o (flip c) g {-# INLINE transpose #-} +-- TODO: Implement via 'induceJust' to reduce code duplication. -- | 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. --+-- Good consumer and producer.+-- -- @ -- induce ('const' True ) x      == x -- induce ('const' False) x      == 'empty'@@ -1005,13 +1146,37 @@ -- 'isSubgraphOf' (induce p x) x == True -- @ induce :: (a -> Bool) -> Graph a -> Graph a-induce p = foldg Empty (\x -> if p x then Vertex x else Empty) (k Overlay) (k Connect)+induce p g = buildg $ \e v o c -> fromMaybe e $+  foldg Nothing (\x -> if p x then Just (v x) else Nothing) (k o) (k c) g   where-    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 #-}+    k _ x        Nothing  = x -- Constant folding to get rid of Empty leaves+    k _ Nothing  y        = y+    k f (Just x) (Just y) = Just (f x y)+{-# INLINE induce #-} +-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'.+-- Complexity: /O(s)/ time, memory and size.+--+-- Good consumer and producer.+--+-- @+-- induceJust ('vertex' 'Nothing')                               == 'empty'+-- induceJust ('edge' ('Just' x) 'Nothing')                        == 'vertex' x+-- induceJust . 'fmap' 'Just'                                    == 'id'+-- induceJust . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p+-- @+induceJust :: Graph (Maybe a) -> Graph a+induceJust g = buildg $ \e v o c -> fromMaybe e $+  foldg Nothing (fmap v) (k o) (k c) g+  where+    k _ x        Nothing  = x -- Constant folding to get rid of Empty leaves+    k _ Nothing  y        = y+    k f (Just x) (Just y) = Just (f x y)+{-# INLINE induceJust #-}++-- NB: This is not a good producer since it requires an Eq instance on the+-- produced structure. -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra. -- The function does not compute the simplest possible expression,@@ -1019,6 +1184,8 @@ -- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed -- that the size of the result does not exceed the size of the given expression. --+-- Good consumer.+-- -- @ -- simplify              == id -- 'size' (simplify x)     <= 'size' x@@ -1030,6 +1197,7 @@ -- @ simplify :: Ord a => Graph a -> Graph a simplify = foldg Empty Vertex (simple Overlay) (simple Connect)+{-# INLINE simplify #-} {-# SPECIALISE simplify :: Graph Int -> Graph Int #-}  simple :: Eq g => (g -> g -> g) -> g -> g -> g@@ -1054,6 +1222,8 @@ -- quadratic, i.e. /m = O(m1 * m2)/, but the algebraic representation requires -- only /O(m1 + m2)/ operations to list them. --+-- Good consumer of both arguments and good producer.+-- -- @ -- compose 'empty'            x                == 'empty' -- compose x                'empty'            == 'empty'@@ -1068,14 +1238,16 @@ -- '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) ]+compose x y = buildg $ \e v o c -> fromMaybe e $+  foldr1Safe o+    [ foldg e v o c (biclique xs ys)+    | ve <- Set.toList (AM.vertexSet mx `Set.union` AM.vertexSet my)+    , let xs = Set.toList (AM.postSet ve mx), not (null xs)+    , let ys = Set.toList (AM.postSet ve my), not (null ys) ]   where     mx = toAdjacencyMap (transpose x)     my = toAdjacencyMap y+{-# INLINE compose #-}  -- | Compute the /Cartesian product/ of graphs. -- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the@@ -1170,81 +1342,44 @@ 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.+* All concerned expressions are inlined to allow the compiler to apply the main+  rule: "foldg/buildg".+  This rule states that the composition of a good producer (expressed via buildg)+  and a good consumer (expressed via foldg) can be fused to remove the construction+  of the intermediate structure. -  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.+* If this inlining is made blindlessly, it can lead to unneeded operations. They+  are optimized via the "foldg/id" rule. -* composeR and matchR are here to remember the original function after applying-  a "buildR/f" rule. These functions are higher-order functions and therefore+* composeR is here to allow further optimization. As an high-order function, it   benefit from inlining in the final phase. -* The "bindR/bindR" rule optimises compositions of multiple bindR's.+* The "composeR/composeR" rule optimises compositions of multiple composeR'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/bindR" forall f g.-    bindR g f = buildR (\e v o c -> foldg e (composeR (foldg e v o c) 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)- #-}+{-# INLINE [1] composeR #-}  -- 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 a foldg followed by a buildg.+"foldg/buildg" forall e v o c (g :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b).+    foldg e v o c (buildg g) = g e v o c --- Fuse composeR's. This occurs when two adjacent 'bindR' were rewritted into--- their buildR form.-"bindR/bindR" forall c f g.-    composeR (composeR c f) g = composeR c (f.g)+-- Fuse composeR's (from bind's definition).+"composeR/composeR" forall c f g.+    composeR (composeR c f) g = composeR c (f . g) --- Rewrite identity (which can appear in the rewriting of bindR) to a much efficient one+-- Rewrite identity (which can appear in the inlining of 'buildg') to a more efficient one. "foldg/id"     foldg Empty Vertex Overlay Connect = id  #-} --- 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+{-# INLINE focus #-}  -- | 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@@ -1257,6 +1392,8 @@ -- | Extract the 'Context' of a subgraph specified by a given predicate. Returns -- @Nothing@ if the specified subgraph is empty. --+-- Good consumer.+-- -- @ -- context ('const' False) x                   == Nothing -- context (== 1)        ('edge' 1 2)          == Just ('Context' [   ] [2  ])@@ -1269,3 +1406,4 @@             | otherwise = Nothing   where     f = focus p g+{-# INLINE context #-}

@@ -0,0 +1,543 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Acyclic.AdjacencyMap+-- Copyright  : (c) Andrey Mokhov 2016-2019+-- 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 and for acyclic graphs, as+-- well as associated operations and algorithms. To avoid name clashes with+-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified:+--+-- @+-- import qualified Algebra.Graph.Acyclic.AdjacencyMap as Acyclic+-- @+-----------------------------------------------------------------------------+module Algebra.Graph.Acyclic.AdjacencyMap (+    -- * Data structure+    AdjacencyMap, fromAcyclic,++    -- * Basic graph construction primitives+    empty, vertex, vertices, union, join,++    -- * Relations on graphs+    isSubgraphOf,++    -- * Graph properties+    isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList,+    adjacencyList, vertexSet, edgeSet, preSet, postSet,++    -- * Graph transformation+    removeVertex, removeEdge, transpose, induce, induceJust,++    -- * Graph composition+    box,++    -- * Relational operations+    transitiveClosure,++    -- * Algorithms+    topSort, scc,++    -- * Conversion to acyclic graphs+    toAcyclic, toAcyclicOrd, shrink,++    -- * Miscellaneous+    consistent+    ) where++import Data.Set (Set)+import Data.Coerce (coerce)++import qualified Algebra.Graph.AdjacencyMap           as AM+import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM+import qualified Algebra.Graph.NonEmpty.AdjacencyMap  as NAM+import qualified Data.List.NonEmpty                   as NonEmpty+import qualified Data.Map                             as Map+import qualified Data.Set                             as Set++{-| The 'AdjacencyMap' data type represents an acyclic graph by a map of+vertices to their adjacency sets. Although the internal representation allows+for cycles, the methods provided by this module cannot be used to construct a+graph with cycles.++The 'Show' instance is defined using basic graph construction primitives where+possible, falling back to 'toAcyclic' and "Algebra.Graph.AdjacencyMap"+otherwise:++@+show empty                == "empty"+show (shrink 1)           == "vertex 1"+show (shrink $ 1 + 2)     == "vertices [1,2]"+show (shrink $ 1 * 2)     == "(fromJust . toAcyclic) (edge 1 2)"+show (shrink $ 1 * 2 * 3) == "(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])"+show (shrink $ 1 * 2 + 3) == "(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))"+@++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.++Note that the resulting order refines the 'isSubgraphOf' relation:++@'isSubgraphOf' x y ==> x <= y@+-}++-- TODO: Improve the Show instance.+newtype AdjacencyMap a = AAM {+    -- | Extract the underlying acyclic "Algebra.Graph.AdjacencyMap".+    -- Complexity: /O(1)/ time and memory.+    --+    -- @+    -- fromAcyclic 'empty'                == 'AM.empty'+    -- fromAcyclic . 'vertex'             == 'AM.vertex'+    -- fromAcyclic (shrink $ 1 * 3 + 2) == 1 * 3 + 2+    -- 'AM.vertexCount' . fromAcyclic        == 'vertexCount'+    -- 'AM.edgeCount'   . fromAcyclic        == 'edgeCount'+    -- 'AM.isAcyclic'   . fromAcyclic        == 'const' True+    -- @+    fromAcyclic :: AM.AdjacencyMap a+    } deriving (Eq, Ord)++instance (Ord a, Show a) => Show (AdjacencyMap a) where+    showsPrec p aam@(AAM am)+        | null vs    = showString "empty"+        | null es    = showParen (p > 10) $ vshow vs+        | otherwise  = showParen (p > 10) $ showString "(fromJust . toAcyclic) ("+                     . shows am . showString ")"+      where+        vs             = vertexList aam+        es             = edgeList aam+        vshow [x]      = showString "vertex "   . showsPrec 11 x+        vshow xs       = showString "vertices " . showsPrec 11 xs++-- | 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 = coerce AM.empty++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'isEmpty'     (vertex x) == False+-- 'hasVertex' x (vertex y) == (x == y)+-- 'vertexCount' (vertex x) == 1+-- 'edgeCount'   (vertex x) == 0+-- @+vertex :: a -> AdjacencyMap a+vertex = coerce AM.vertex++-- | 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 a+vertices = coerce AM.vertices++-- | Construct the disjoint /union/ of two graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'vertexSet' (union x y) == Set.'Set.unions' [ Set.'Set.map' 'Left'  ('vertexSet' x)+--                                     , Set.'Set.map' 'Right' ('vertexSet' y) ]+--+-- 'edgeSet'   (union x y) == Set.'Set.unions' [ Set.'Set.map' ('Data.Bifunctor.bimap' 'Left'  'Left' ) ('edgeSet' x)+--                                     , Set.'Set.map' ('Data.Bifunctor.bimap' 'Right' 'Right') ('edgeSet' y) ]+-- @+union :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (Either a b)+union (AAM x) (AAM y) = AAM $ AM.overlay (AM.gmap Left x) (AM.gmap Right y)++-- | Construct the /join/ of two graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'vertexSet' (join x y) == Set.'Set.unions' [ Set.'Set.map' 'Left'  ('vertexSet' x)+--                                    , Set.'Set.map' 'Right' ('vertexSet' y) ]+--+-- 'edgeSet'   (join x y) == Set.'Set.unions' [ Set.'Set.map' ('Data.Bifunctor.bimap' 'Left'  'Left' ) ('edgeSet' x)+--                                    , Set.'Set.map' ('Data.Bifunctor.bimap' 'Right' 'Right') ('edgeSet' y)+--                                    , Set.'Set.map' ('Data.Bifunctor.bimap' 'Left'  'Right') (Set.'Set.cartesianProduct' ('vertexSet' x) ('vertexSet' y)) ]+-- @+join :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (Either a b)+join (AAM a) (AAM b) = AAM $ AM.connect (AM.gmap Left a) (AM.gmap Right b)++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- isSubgraphOf 'empty'        x                     ==  True+-- isSubgraphOf ('vertex' x)   'empty'                 ==  False+-- isSubgraphOf ('induce' p x) x                     ==  True+-- isSubgraphOf x            ('transitiveClosure' x) ==  True+-- isSubgraphOf x y                                ==> x <= y+-- @+isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool+isSubgraphOf = coerce AM.isSubgraphOf++-- | Check if a graph is empty.+-- Complexity: /O(1)/ time.+--+-- @+-- isEmpty 'empty'                             == True+-- isEmpty ('vertex' x)                        == False+-- isEmpty ('removeVertex' x $ 'vertex' x)       == True+-- isEmpty ('removeEdge' 1 2 $ shrink $ 1 * 2) == False+-- @+isEmpty :: AdjacencyMap a -> Bool+isEmpty = coerce AM.isEmpty++-- | Check if a graph contains a given vertex.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasVertex x 'empty'            == False+-- hasVertex x ('vertex' y)       == (x == y)+-- hasVertex x . 'removeVertex' x == 'const' False+-- @+hasVertex :: Ord a => a -> AdjacencyMap a -> Bool+hasVertex = coerce AM.hasVertex++-- | 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 1 2 (shrink $ 1 * 2) == 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 = coerce AM.hasEdge++-- | 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 a -> Int+vertexCount = coerce AM.vertexCount++-- | The number of edges in a graph.+-- Complexity: /O(n)/ time.+--+-- @+-- edgeCount 'empty'            == 0+-- edgeCount ('vertex' x)       == 0+-- edgeCount (shrink $ 1 * 2) == 1+-- edgeCount                  == 'length' . 'edgeList'+-- @+edgeCount :: AdjacencyMap a -> Int+edgeCount = coerce AM.edgeCount++-- | 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 a -> [a]+vertexList = coerce AM.vertexList++-- | The sorted list of edges of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeList 'empty'            == []+-- edgeList ('vertex' x)       == []+-- edgeList (shrink $ 2 * 1) == [(2,1)]+-- edgeList . 'transpose'      == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList+-- @+edgeList :: AdjacencyMap a -> [(a, a)]+edgeList = coerce AM.edgeList++-- | The sorted /adjacency list/ of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- adjacencyList 'empty'            == []+-- adjacencyList ('vertex' x)       == [(x, [])]+-- adjacencyList (shrink $ 1 * 2) == [(1, [2]), (2, [])]+-- @+adjacencyList :: AdjacencyMap a -> [(a, [a])]+adjacencyList = coerce AM.adjacencyList++-- | 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 a -> Set a+vertexSet = coerce AM.vertexSet++-- | The set of edges of a given graph.+-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.+--+-- @+-- edgeSet 'empty'            == Set.'Set.empty'+-- edgeSet ('vertex' x)       == Set.'Set.empty'+-- edgeSet (shrink $ 1 * 2) == Set.'Set.singleton' (1,2)+-- @+edgeSet :: Eq a => AdjacencyMap a -> Set (a, a)+edgeSet = coerce AM.edgeSet++-- | 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 (shrink $ 1 * 2) == Set.'Set.empty'+-- preSet 2 (shrink $ 1 * 2) == Set.'Set.fromList' [1]+-- Set.'Set.member' x . preSet x   == 'const' False+-- @+preSet :: Ord a => a -> AdjacencyMap a -> Set a+preSet = coerce AM.preSet++-- | 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 1 (shrink $ 1 * 2) == Set.'Set.fromList' [2]+-- postSet 2 (shrink $ 1 * 2) == Set.'Set.empty'+-- Set.'Set.member' x . postSet x   == 'const' False+-- @+postSet :: Ord a => a -> AdjacencyMap a -> Set a+postSet = coerce AM.postSet++-- | Remove a vertex from a given acyclic graph.+-- Complexity: /O(n*log(n))/ time.+--+-- @+-- removeVertex x ('vertex' x)       == 'empty'+-- removeVertex 1 ('vertex' 2)       == 'vertex' 2+-- removeVertex 1 (shrink $ 1 * 2) == 'vertex' 2+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a+removeVertex = coerce AM.removeVertex++-- | Remove an edge from a given acyclic graph.+-- Complexity: /O(log(n))/ time.+--+-- @+-- removeEdge 1 2 (shrink $ 1 * 2)     == 'vertices' [1,2]+-- removeEdge x y . removeEdge x y     == removeEdge x y+-- removeEdge x y . 'removeVertex' x     == 'removeVertex' x+-- removeEdge 1 2 (shrink $ 1 * 2 * 3) == shrink ((1 + 2) * 3)+-- @+removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+removeEdge = coerce AM.removeEdge++-- | Transpose a given acyclic graph.+-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory.+--+-- @+-- transpose 'empty'       == 'empty'+-- transpose ('vertex' x)  == 'vertex' x+-- transpose . transpose == id+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList'+-- @+transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a+transpose = coerce AM.transpose++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(n + 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 a -> AdjacencyMap a+induce = coerce AM.induce++-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'.+-- Complexity: /O(n + m)/ time.+--+-- @+-- induceJust ('vertex' 'Nothing') == 'empty'+-- induceJust . 'vertex' . 'Just'  == 'vertex'+-- @+induceJust :: Ord a => AdjacencyMap (Maybe a) -> AdjacencyMap a+induceJust = coerce AM.induceJust++-- | Compute the /Cartesian product/ of graphs.+-- Complexity: /O(n * m * log(n)^2)/ time.+--+-- @+-- 'edgeList' (box (shrink $ 1 * 2) (shrink $ 10 * 20)) == [ ((1,10), (1,20))+--                                                       , ((1,10), (2,10))+--                                                       , ((1,20), (2,20))+--                                                       , ((2,10), (2,20)) ]+-- @+--+-- Up to an isomorphism between the resulting vertex types, this operation+-- is /commutative/ and /associative/, 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 ('vertex' ())     ~~ x+-- box x 'empty'           ~~ 'empty'+-- 'transpose'   (box x y) == box ('transpose' x) ('transpose' y)+-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y+-- @+box :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (a, b)+box = coerce AM.box++-- | Compute the /transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time.+--+-- @+-- transitiveClosure 'empty'                    == 'empty'+-- transitiveClosure ('vertex' x)               == 'vertex' x+-- transitiveClosure (shrink $ 1 * 2 + 2 * 3) == shrink (1 * 2 + 1 * 3 + 2 * 3)+-- transitiveClosure . transitiveClosure      == transitiveClosure+-- @+transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+transitiveClosure = coerce AM.transitiveClosure++-- | Compute a /topological sort/ of an acyclic graph.+--+-- @+-- topSort 'empty'                          == []+-- topSort ('vertex' x)                     == [x]+-- topSort (shrink $ 1 * (2 + 4) + 3 * 4) == [1, 2, 3, 4]+-- topSort ('join' x y)                     == 'fmap' 'Left' (topSort x) ++ 'fmap' 'Right' (topSort y)+-- 'Right' . topSort                        == 'AM.topSort' . 'fromAcyclic'+-- @+topSort :: Ord a => AdjacencyMap a -> [a]+topSort g = case AM.topSort (coerce g) of+  Right vs -> vs+  Left _ -> error "Internal error: the acyclicity invariant is violated in topSort"++-- | Compute the acyclic /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 'AM.empty'               == 'empty'+--            scc ('AM.vertex' x)          == 'vertex' (NonEmpty.'NonEmpty.vertex' x)+--            scc ('AM.edge' 1 1)          == 'vertex' (NonEmpty.'NonEmpty.edge' 1 1)+-- 'edgeList' $ scc ('AM.edge' 1 2)          == [ (NonEmpty.'NonEmpty.vertex' 1       , NonEmpty.'NonEmpty.vertex' 2       ) ]+-- 'edgeList' $ scc (3 * 1 * 4 * 1 * 5) == [ (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       ) ]+-- @+scc :: (Ord a) => AM.AdjacencyMap a -> AdjacencyMap (NAM.AdjacencyMap a)+scc = coerce AM.scc++-- | Construct an acyclic graph from a given adjacency map, or return 'Nothing'+-- if the input contains cycles.+--+-- @+-- toAcyclic ('AM.path'    [1,2,3]) == 'Just' (shrink $ 1 * 2 + 2 * 3)+-- toAcyclic ('AM.clique'  [3,2,1]) == 'Just' ('transpose' (shrink $ 1 * 2 * 3))+-- toAcyclic ('AM.circuit' [1,2,3]) == 'Nothing'+-- toAcyclic . 'fromAcyclic'     == 'Just'+-- @+toAcyclic :: Ord a => AM.AdjacencyMap a -> Maybe (AdjacencyMap a)+toAcyclic x = if AM.isAcyclic x then Just (AAM x) else Nothing++-- | Construct an acyclic graph from a given adjacency map, keeping only edges+-- @(x,y)@ where @x < y@ according to the supplied 'Ord' @a@ instance.+--+-- @+-- toAcyclicOrd 'empty'       == 'empty'+-- toAcyclicOrd . 'vertex'    == 'vertex'+-- toAcyclicOrd (1 + 2)     == shrink (1 + 2)+-- toAcyclicOrd (1 * 2)     == shrink (1 * 2)+-- toAcyclicOrd (2 * 1)     == shrink (1 + 2)+-- toAcyclicOrd (1 * 2 * 1) == shrink (1 * 2)+-- toAcyclicOrd (1 * 2 * 3) == shrink (1 * 2 * 3)+-- @+toAcyclicOrd :: Ord a => AM.AdjacencyMap a -> AdjacencyMap a+toAcyclicOrd = AAM . filterEdges (<)++-- TODO: Add time complexity+-- TODO: Change Arbitrary instance of Acyclic and Labelled Acyclic graph+-- | Construct an acyclic graph from a given adjacency map using 'scc'.+-- If the graph is acyclic in nature, the same graph is returned as an acyclic graph.+-- If the graph is cyclic, then a representative for every strongly connected+-- component in its condensation graph is chosen an these representatives are+-- used to build an acyclic graph.+--+-- @+-- shrink . 'AM.vertex'      == 'vertex'+-- shrink . 'AM.vertices'    == 'vertices'+-- shrink . 'fromAcyclic' == 'id'+-- @+shrink :: Ord a => AM.AdjacencyMap a -> AdjacencyMap a+shrink = AAM . AM.gmap (NonEmpty.head . NAM.vertexList1) . AM.scc++-- TODO: Provide a faster equivalent in "Algebra.Graph.AdjacencyMap".+-- Keep only the edges that satisfy a given predicate.+filterEdges :: Ord a => (a -> a -> Bool) -> AM.AdjacencyMap a -> AM.AdjacencyMap a+filterEdges p m = AM.fromAdjacencySets+    [ (a, Set.filter (p a) bs) | (a, bs) <- Map.toList (AM.adjacencyMap m) ]++-- | Check if the internal representation of an acyclic graph is consistent,+-- i.e. that all edges refer to existing vertices and the graph is acyclic. It+-- should be impossible to create an inconsistent 'AdjacencyMap'.+--+-- @+-- consistent 'empty'                 == True+-- consistent ('vertex' x)            == True+-- consistent ('vertices' xs)         == True+-- consistent ('union' x y)           == True+-- consistent ('join' x y)            == True+-- consistent ('transpose' x)         == True+-- consistent ('box' x y)             == True+-- consistent ('transitiveClosure' x) == True+-- consistent ('scc' x)               == True+-- 'fmap' consistent ('toAcyclic' x)    /= False+-- consistent ('toAcyclicOrd' x)      == True+-- @+consistent :: Ord a => AdjacencyMap a -> Bool+consistent (AAM m) = AM.consistent m && AM.isAcyclic m

@@ -1,7 +1,8 @@+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.AdjacencyIntMap--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -18,7 +19,7 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyIntMap (     -- * Data structure-    AdjacencyIntMap, adjacencyIntMap,+    AdjacencyIntMap, adjacencyIntMap, fromAdjacencyMap,      -- * Basic graph construction primitives     empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,@@ -39,21 +40,182 @@     induce,      -- * Relational operations-    compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure+    compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure,++    -- * Miscellaneous+    consistent     ) where -import Data.Foldable (foldMap)+import Control.DeepSeq+import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet)-import Data.Monoid+import Data.List ((\\))+import Data.Monoid (Sum (..)) import Data.Set (Set) import Data.Tree--import Algebra.Graph.AdjacencyIntMap.Internal+import GHC.Generics  import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet        as IntSet+import qualified Data.Map.Strict    as Map import qualified Data.Set           as Set +import qualified Algebra.Graph.AdjacencyMap as AM++{-| The 'AdjacencyIntMap' data type represents a graph by a map of vertices to+their adjacency sets. We define a 'Num' instance as a convenient notation for+working with graphs:++    > 0           == vertex 0+    > 1 + 2       == overlay (vertex 1) (vertex 2)+    > 1 * 2       == connect (vertex 1) (vertex 2)+    > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))+    > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))++__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"+show (1         :: AdjacencyIntMap Int) == "vertex 1"+show (1 + 2     :: AdjacencyIntMap Int) == "vertices [1,2]"+show (1 * 2     :: AdjacencyIntMap Int) == "edge 1 2"+show (1 * 2 * 3 :: AdjacencyIntMap Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: AdjacencyIntMap Int) == "overlay (vertex 3) (edge 1 2)"@++The 'Eq' instance satisfies all axioms of algebraic graphs:++    * 'overlay' is commutative and associative:++        >       x + y == y + x+        > x + (y + z) == (x + y) + z++    * 'connect' is associative and has 'empty' as the identity:++        >   x * empty == x+        >   empty * x == x+        > x * (y * z) == (x * y) * z++    * 'connect' distributes over 'overlay':++        > x * (y + z) == x * y + x * z+        > (x + y) * z == x * z + y * z++    * 'connect' can be decomposed:++        > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++    * 'overlay' has 'empty' as the identity and is idempotent:++        >   x + empty == x+        >   empty + x == x+        >       x + x == x++    * Absorption and saturation of 'connect':++        > x * y + x + y == x * y+        >     x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ and /m/+will denote the number of vertices and edges in the graph, respectively.++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 AdjacencyIntMap = AM {+    -- | 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'+    -- adjacencyIntMap ('vertex' x) == IntMap.'IntMap.singleton' x IntSet.'IntSet.empty'+    -- adjacencyIntMap ('edge' 1 1) == IntMap.'IntMap.singleton' 1 (IntSet.'IntSet.singleton' 1)+    -- adjacencyIntMap ('edge' 1 2) == IntMap.'IntMap.fromList' [(1,IntSet.'IntSet.singleton' 2), (2,IntSet.'IntSet.empty')]+    -- @+    adjacencyIntMap :: IntMap IntSet } deriving (Eq, Generic)++instance Show AdjacencyIntMap where+    showsPrec p am@(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             = vertexList am+        es             = edgeList am+        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)++instance Ord AdjacencyIntMap where+    compare x y = mconcat+        [ compare (vertexCount  x) (vertexCount  y)+        , compare (vertexIntSet x) (vertexIntSet y)+        , compare (edgeCount    x) (edgeCount    y)+        , compare (edgeSet      x) (edgeSet      y) ]++-- | __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++instance NFData AdjacencyIntMap where+    rnf (AM a) = rnf a++-- | Construct an 'AdjacencyIntMap' from an 'AM.AdjacencyMap' with vertices of+-- type 'Int'.+-- Complexity: /O(n + m)/ time and memory.+--+-- @+-- fromAdjacencyMap == 'stars' . AdjacencyMap.'AM.adjacencyList'+-- @+fromAdjacencyMap :: AM.AdjacencyMap Int -> AdjacencyIntMap+fromAdjacencyMap = AM+                 . IntMap.fromAscList+                 . map (fmap $ IntSet.fromAscList . Set.toAscList)+                 . Map.toAscList+                 . AM.adjacencyMap+ -- | Construct the /empty graph/. -- Complexity: /O(1)/ time and memory. --@@ -72,7 +234,7 @@ -- -- @ -- 'isEmpty'     (vertex x) == False--- 'hasVertex' x (vertex x) == True+-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount'   (vertex x) == 0 -- @@@ -109,14 +271,14 @@ -- 'edgeCount'   (overlay 1 2) == 0 -- @ overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap-overlay x y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y)+overlay (AM x) (AM y) = AM $ IntMap.unionWith IntSet.union x 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)/.+-- 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@@ -131,8 +293,8 @@ -- '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) ]+connect (AM x) (AM y) = AM $ IntMap.unionsWith IntSet.union+    [ x, y, IntMap.fromSet (const $ IntMap.keysSet y) (IntMap.keysSet x) ] {-# NOINLINE [1] connect #-}  -- | Construct the graph comprising a given list of isolated vertices.@@ -156,6 +318,7 @@ -- @ -- edges []          == 'empty' -- edges [(x,y)]     == 'edge' x y+-- edges             == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges  == 'Data.List.nub' . 'Data.List.sort' -- @@@ -203,7 +366,7 @@ -- isSubgraphOf x y                         ==> x <= y -- @ isSubgraphOf :: AdjacencyIntMap -> AdjacencyIntMap -> Bool-isSubgraphOf x y = IntMap.isSubmapOfBy IntSet.isSubsetOf (adjacencyIntMap x) (adjacencyIntMap y)+isSubgraphOf (AM x) (AM y) = IntMap.isSubmapOfBy IntSet.isSubsetOf x y  -- | Check if a graph is empty. -- Complexity: /O(1)/ time.@@ -223,8 +386,7 @@ -- -- @ -- hasVertex x 'empty'            == False--- hasVertex x ('vertex' x)       == True--- hasVertex 1 ('vertex' 2)       == False+-- hasVertex x ('vertex' y)       == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Int -> AdjacencyIntMap -> Bool@@ -241,7 +403,7 @@ -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Int -> Int -> AdjacencyIntMap -> Bool-hasEdge u v a = case IntMap.lookup u (adjacencyIntMap a) of+hasEdge u v (AM m) = case IntMap.lookup u m of     Nothing -> False     Just vs -> IntSet.member v vs @@ -293,6 +455,7 @@ -- @ edgeList :: AdjacencyIntMap -> [(Int, Int)] edgeList (AM m) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ]+{-# INLINE edgeList #-}  -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory.@@ -592,7 +755,7 @@  -- | 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+-- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to -- be evaluated. -- -- @@@ -694,3 +857,24 @@     | otherwise  = transitiveClosure new   where     new = overlay old (old `compose` old)++-- | Check that 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.+--+-- @+-- consistent 'empty'         == True+-- consistent ('vertex' x)    == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('edge' x y)    == True+-- consistent ('edges' xs)    == True+-- consistent ('stars' xs)    == True+-- @+consistent :: AdjacencyIntMap -> Bool+consistent (AM m) = referredToVertexSet m `IntSet.isSubsetOf` IntMap.keysSet m++-- The set of vertices that are referred to by the edges+referredToVertexSet :: IntMap IntSet -> IntSet+referredToVertexSet m = IntSet.fromList $ concat+    [ [x, y] | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ]

@@ -1,3 +1,5 @@+{-# language LambdaCase #-}+ ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.AdjacencyIntMap.Algorithm@@ -12,29 +14,107 @@ -- -- This module provides basic graph algorithms, such as /depth-first search/, -- implemented for the "Algebra.Graph.AdjacencyIntMap" data type.+--+-- Some of the worst-case complexities include the term /min(n,W)/.+-- Following 'IntSet.IntSet' and 'IntMap.IntMap', the /W/ stands for+-- word size (usually 32 or 64 bits). ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyIntMap.Algorithm (     -- * Algorithms-    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic,-+    bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable,+    topSort, isAcyclic,+         -- * Correctness properties-    isDfsForestOf, isTopSortOf+    isDfsForestOf, isTopSortOf,++    -- * Type synonyms+    Cycle     ) where  import Control.Monad-import Data.Maybe+import Control.Monad.Cont+import Control.Monad.State.Strict+import Data.Either+import Data.List.NonEmpty (NonEmpty(..),(<|)) import Data.Tree  import Algebra.Graph.AdjacencyIntMap -import qualified Data.Graph.Typed   as Typed+import qualified Data.List          as List 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.+-- | Compute the /breadth-first search/ forest of a graph, such that+--   adjacent vertices are explored in increasing order with respect+--   to their 'Ord' instance. The search is seeded by a list of+--   argument vertices that will be the roots of the resulting+--   forest. Duplicates in the list will have their first occurrence+--   expanded and subsequent ones ignored. Argument vertices not in+--   the graph are also ignored.  --+--   Let /L/ be the number of seed vertices. Complexity:+--   /O((L+m)*min(n,W))/ time and /O(n)/ space.+-- -- @+-- 'forest' (bfsForest [1,2] $ 'edge' 1 2)      == 'vertices' [1,2]+-- 'forest' (bfsForest [2]   $ 'edge' 1 2)      == 'vertex' 2+-- 'forest' (bfsForest [3]   $ 'edge' 1 2)      == 'empty'+-- 'forest' (bfsForest [2,1] $ 'edge' 1 2)      == 'vertices' [1,2]+-- 'isSubgraphOf' ('forest' $ bfsForest vs x) x == True+-- bfsForest ('vertexList' g) g               == 'map' (\v -> Node v []) ('nub' $ 'vertexList' g)+-- bfsForest [] x                           == []+-- bfsForest [1,4] (3 * (1 + 4) * (1 + 5))  == [ Node { rootLabel = 1+--                                                    , subForest = [ Node { rootLabel = 5+--                                                                         , subForest = [] }]}+--                                             , Node { rootLabel = 4+--                                                    , subForest = [] }]+-- 'forest' (bfsForest [3] ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [3,2,1] + 'path' [3,4,5]+-- +-- @+bfsForest :: [Int] -> AdjacencyIntMap -> Forest Int+bfsForest vs g = evalState (explore [ v | v <- vs, hasVertex v g ]) IntSet.empty where+  explore = unfoldForestM_BF walk <=< filterM discovered+  walk v = (v,) <$> adjacentM v+  adjacentM v = filterM discovered $ IntSet.toList (postIntSet v g)+  discovered v = do new <- gets (not . IntSet.member v)+                    when new $ modify' (IntSet.insert v)+                    return new++-- | This is 'bfsForest' with the resulting forest converted to a+--   level structure. Adjacent vertices are explored in increasing+--   order with respect to their 'Ord' instance. Flattening the result+--   via @'concat' . 'bfs' vs@ gives an enumeration of vertices+--   reachable from @vs@ in breadth first order.+--+--   Let /L/ be the number of seed vertices. Complexity:+--   /O((L+m)*min(n,W))/ time and /O(n)/ space.+-- +-- @+-- bfs vs 'empty'                                         == []+-- bfs [] g                                             == []+-- bfs [1]   ('edge' 1 1)                                 == [[1]]+-- bfs [1]   ('edge' 1 2)                                 == [[1],[2]]+-- bfs [2]   ('edge' 1 2)                                 == [[2]]+-- bfs [1,2] ('edge' 1 2)                                 == [[1,2]]+-- bfs [2,1] ('edge' 1 2)                                 == [[2,1]]+-- bfs [3]   ('edge' 1 2)                                 == []+-- bfs [1,2] ( (1*2) + (3*4) + (5*6) )                  == [[1,2]]+-- bfs [1,3] ( (1*2) + (3*4) + (5*6) )                  == [[1,3],[2,4]]+-- bfs [3] (3 * (1 + 4) * (1 + 5))                      == [[3],[1,4,5]]+-- bfs [2] ('circuit' [1..5] + 'circuit' [5,4..1])          == [[2],[1,3],[5,4]]+-- 'concat' (bfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == [3,2,4,1,5]+-- bfs vs == 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' vs+-- @+bfs :: [Int] -> AdjacencyIntMap -> [[Int]]+bfs vs = map concat . List.transpose . map levels . bfsForest vs++-- | Compute the /depth-first search/ forest of a graph, where+--   adjacent vertices are expanded in increasing order with respect+--   to their 'Ord' instance.+--+--   Complexity: /O((n+m)*min(n,W))/ time and /O(n)/ space.+--+-- @ -- dfsForest 'empty'                       == [] -- 'forest' (dfsForest $ 'edge' 1 1)         == 'vertex' 1 -- 'forest' (dfsForest $ 'edge' 1 2)         == 'edge' 1 2@@ -50,13 +130,20 @@ --                                          , Node { rootLabel = 3 --                                                 , subForest = [ Node { rootLabel = 4 --                                                                      , subForest = [] }]}]+-- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5] -- @ dfsForest :: AdjacencyIntMap -> Forest Int-dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap+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.+-- | Compute the /depth-first search/ forest of a graph from the given+--   vertices, where adjacent vertices are expanded in increasing+--   order with respect to to their 'Ord' instance. Note that the+--   resulting forest does not necessarily span the whole graph, as+--   some vertices may be unreachable. Any of the given vertices which+--   are not in the graph are ignored.+-- +--   Let /L/ be the number of seed vertices. Complexity:+--   /O((L+m)*min(n,W))/ time and /O(n)/ space. -- -- @ -- dfsForestFrom vs 'empty'                           == []@@ -75,12 +162,29 @@ --                                                                                 , subForest = [] } --                                                     , Node { rootLabel = 4 --                                                            , subForest = [] }]+-- 'forest' (dfsForestFrom [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [3,2,1,5,4] -- @ dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int-dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap+dfsForestFrom vs g = dfsForestFrom' [ v | v <- vs, hasVertex v g ] g --- | Compute the list of vertices visited by the /depth-first search/ in a graph,--- when searching from each of the given vertices in order.+dfsForestFrom' :: [Int] -> AdjacencyIntMap -> Forest Int+dfsForestFrom' vs g = evalState (explore vs) IntSet.empty where+  explore (v:vs) = discovered v >>= \case+    True -> (:) <$> walk v <*> explore vs+    False -> explore vs+  explore [] = return []+  walk v = Node v <$> explore (adjacent v)+  adjacent v = IntSet.toList (postIntSet v g)+  discovered v = do new <- gets (not . IntSet.member v)+                    when new $ modify' (IntSet.insert v)+                    return new++-- | Compute the vertices visited by /depth-first search/ in a graph+--   from the given vertices. Adjacent vertices are explored in+--   increasing order with respect to their 'Ord' instance.+-- +--   Let /L/ be the number of seed vertices. Complexity:+--   /O((L+m)*min(n,W))/ time and /O(n)/ space. -- -- @ -- dfs vs    $ 'empty'                    == []@@ -93,14 +197,17 @@ -- dfs []    $ x                        == [] -- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4] -- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True+-- dfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1] == [3,2,1,5,4] -- @ dfs :: [Int] -> AdjacencyIntMap -> [Int]-dfs vs = concatMap flatten . dfsForestFrom vs+dfs vs = dfsForestFrom vs >=> flatten --- | 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/.+-- | Compute the list of vertices that are /reachable/ from a given+--   source vertex in a graph. The vertices in the resulting list+--   appear in /depth-first order/. --+--   Complexity: /O(m*min(n,W))/ time and /O(n)/ space.+--  -- @ -- reachable x $ 'empty'                       == [] -- reachable 1 $ 'vertex' 1                    == [1]@@ -115,30 +222,83 @@ reachable :: Int -> AdjacencyIntMap -> [Int] reachable x = dfs [x] --- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph--- is cyclic.+type Cycle = NonEmpty+data NodeState = Entered | Exited+data S = S { parent :: IntMap.IntMap Int+           , entry  :: IntMap.IntMap NodeState+           , order  :: [Int] }++topSort' :: (MonadState S m, MonadCont m)+         => AdjacencyIntMap -> m (Either (Cycle Int) [Int])+topSort' g = callCC $ \cyclic ->+  do let vertices = map fst $ IntMap.toDescList $ adjacencyIntMap g+         adjacent = IntSet.toDescList . flip postIntSet g+         dfsRoot x = nodeState x >>= \case+           Nothing -> enterRoot x >> dfs x >> exit x+           _       -> return ()+         dfs x = forM_ (adjacent x) $ \y ->+                   nodeState y >>= \case+                     Nothing      -> enter x y >> dfs y >> exit y+                     Just Exited  -> return ()+                     Just Entered -> cyclic . Left . retrace x y =<< gets parent+     forM_ vertices dfsRoot+     Right <$> gets order+  where+    nodeState v = gets (IntMap.lookup v . entry)+    enter u v = modify' (\(S m n vs) -> S (IntMap.insert v u m)+                                          (IntMap.insert v Entered n)+                                          vs)+    enterRoot v = modify' (\(S m n vs) -> S m (IntMap.insert v Entered n) vs)+    exit v = modify' (\(S m n vs) -> S m (IntMap.alter (fmap leave) v n) (v:vs))+      where leave = \case+              Entered -> Exited+              Exited  -> error "Internal error: dfs search order violated"+    retrace curr head parent = aux (curr :| []) where+      aux xs@(curr :| _)+        | head == curr = xs+        | otherwise = aux (parent IntMap.! curr <| xs)++-- | Compute a topological sort of a DAG or discover a cycle. --+--   Vertices are expanded in decreasing order with respect to their+--   'Ord' instance. This gives the lexicographically smallest+--   topological ordering in the case of success. In the case of+--   failure, the cycle is characterized by being the+--   lexicographically smallest up to rotation with respect to @Ord+--   (Dual Int)@ in the first connected component of the graph+--   containing a cycle, where the connected components are ordered by+--   their largest vertex with respect to @Ord a@.+--+--   Complexity: /O((n+m)*min(n,W))/ time and /O(n)/ space.+-- -- @--- 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 (1 * 2 + 3 * 1)                    == Right [3,1,2]+-- topSort ('path' [1..5])                      == Right [1..5]+-- topSort (3 * (1 * 4 + 2 * 5))              == Right [3,1,2,4,5]+-- topSort (1 * 2 + 2 * 1)                    == Left (2 ':|' [1])+-- topSort ('path' [5,4..1] + 'edge' 2 4)         == Left (4 ':|' [3,2])+-- topSort ('circuit' [1..3])                   == Left (3 ':|' [1,2])+-- topSort ('circuit' [1..3] + 'circuit' [3,2,1]) == Left (3 ':|' [2])+-- topSort (1*2 + 2*1 + 3*4 + 4*3 + 5*1)      == Left (1 ':|' [2])+-- fmap ('flip' 'isTopSortOf' x) (topSort x)      /= Right False+-- topSort . 'vertices'                         == Right . 'nub' . 'sort' -- @-topSort :: AdjacencyIntMap -> Maybe [Int]-topSort m = if isTopSortOf result m then Just result else Nothing-  where-    result = Typed.topSort (Typed.fromAdjacencyIntMap m)+topSort :: AdjacencyIntMap -> Either (Cycle Int) [Int]+topSort g = runContT (evalStateT (topSort' g) initialState) id where+  initialState = S IntMap.empty IntMap.empty []  -- | Check if a given graph is /acyclic/. --+--   Complexity: /O((n+m)*min(n,W))/ time and /O(n)/ space.+-- -- @ -- isAcyclic (1 * 2 + 3 * 1) == True -- isAcyclic (1 * 2 + 2 * 1) == False -- isAcyclic . 'circuit'       == 'null'--- isAcyclic                 == 'isJust' . 'topSort'+-- isAcyclic                 == 'isRight' . 'topSort' -- @ isAcyclic :: AdjacencyIntMap -> Bool-isAcyclic = isJust . topSort+isAcyclic = isRight . 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

@@ -1,206 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module     : Algebra.Graph.AdjacencyIntMap.Internal--- Copyright  : (c) Andrey Mokhov 2016-2018--- License    : MIT (see the file LICENSE)--- Maintainer : andrey.mokhov@gmail.com--- Stability  : unstable------ This module exposes the implementation of adjacency maps. The API is unstable--- and unsafe, and is exposed only for documentation. You should use the--- non-internal module "Algebra.Graph.AdjacencyIntMap" instead.-------------------------------------------------------------------------------module Algebra.Graph.AdjacencyIntMap.Internal (-    -- * Adjacency map implementation-    AdjacencyIntMap (..), 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-import GHC.Generics--import Control.DeepSeq (NFData (..))--import qualified Data.IntMap.Strict as IntMap-import qualified Data.IntSet        as IntSet--{-| The 'AdjacencyIntMap' data type represents a graph by a map of vertices to-their adjacency sets. We define a 'Num' instance as a convenient notation for-working with graphs:--    > 0           == vertex 0-    > 1 + 2       == overlay (vertex 1) (vertex 2)-    > 1 * 2       == connect (vertex 1) (vertex 2)-    > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))-    > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))--__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"-show (1         :: AdjacencyIntMap Int) == "vertex 1"-show (1 + 2     :: AdjacencyIntMap Int) == "vertices [1,2]"-show (1 * 2     :: AdjacencyIntMap Int) == "edge 1 2"-show (1 * 2 * 3 :: AdjacencyIntMap Int) == "edges [(1,2),(1,3),(2,3)]"-show (1 * 2 + 3 :: AdjacencyIntMap Int) == "overlay (vertex 3) (edge 1 2)"@--The 'Eq' instance satisfies all axioms of algebraic graphs:--    * 'Algebra.Graph.AdjacencyIntMap.overlay' is commutative and associative:--        >       x + y == y + x-        > x + (y + z) == (x + y) + z--    * 'Algebra.Graph.AdjacencyIntMap.connect' is associative and has-    'Algebra.Graph.AdjacencyIntMap.empty' as the identity:--        >   x * empty == x-        >   empty * x == x-        > x * (y * z) == (x * y) * z--    * 'Algebra.Graph.AdjacencyIntMap.connect' distributes over-    'Algebra.Graph.AdjacencyIntMap.overlay':--        > x * (y + z) == x * y + x * z-        > (x + y) * z == x * z + y * z--    * 'Algebra.Graph.AdjacencyIntMap.connect' can be decomposed:--        > x * y * z == x * y + x * z + y * z--The following useful theorems can be proved from the above set of axioms.--    * 'Algebra.Graph.AdjacencyIntMap.overlay' has-    'Algebra.Graph.AdjacencyIntMap.empty' as the identity and is idempotent:--        >   x + empty == x-        >   empty + x == x-        >       x + x == x--    * Absorption and saturation of 'Algebra.Graph.AdjacencyIntMap.connect':--        > x * y + x + y == x * y-        >     x * x * x == x * x--When specifying the time and memory complexity of graph algorithms, /n/ and /m/-will denote the number of vertices and edges in the graph, respectively.--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 a graph: each vertex is associated with a set of-    -- its direct successors. Complexity: /O(1)/ time and memory.-    ---    -- @-    -- adjacencyIntMap 'empty'      == IntMap.'IntMap.empty'-    -- adjacencyIntMap ('vertex' x) == IntMap.'IntMap.singleton' x IntSet.'IntSet.empty'-    -- adjacencyIntMap ('Algebra.Graph.AdjacencyIntMap.edge' 1 1) == IntMap.'IntMap.singleton' 1 (IntSet.'IntSet.singleton' 1)-    -- adjacencyIntMap ('Algebra.Graph.AdjacencyIntMap.edge' 1 2) == IntMap.'IntMap.fromList' [(1,IntSet.'IntSet.singleton' 2), (2,IntSet.'IntSet.empty')]-    -- @-    adjacencyIntMap :: IntMap IntSet } deriving (Eq, Generic)--instance Show AdjacencyIntMap where-    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]      = 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)--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 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---- | Check if the internal graph representation is consistent, i.e. that all--- edges refer to existing vertices. It should be impossible to create an--- inconsistent adjacency map, and we use this function in testing.--- /Note: this function is for internal use only/.------ @--- consistent 'Algebra.Graph.AdjacencyIntMap.empty'         == True--- consistent ('Algebra.Graph.AdjacencyIntMap.vertex' x)    == True--- consistent ('Algebra.Graph.AdjacencyIntMap.overlay' x y) == True--- consistent ('Algebra.Graph.AdjacencyIntMap.connect' x y) == True--- consistent ('Algebra.Graph.AdjacencyIntMap.edge' x y)    == True--- consistent ('Algebra.Graph.AdjacencyIntMap.edges' xs)    == True--- consistent ('Algebra.Graph.AdjacencyIntMap.stars' xs)    == True--- @-consistent :: AdjacencyIntMap -> Bool-consistent (AM m) = referredToVertexSet m `IntSet.isSubsetOf` keysSet m---- The set of vertices that are referred to by the edges-referredToVertexSet :: IntMap IntSet -> IntSet-referredToVertexSet = IntSet.fromList . uncurry (++) . unzip . internalEdgeList---- The list of edges in adjacency map-internalEdgeList :: IntMap IntSet -> [(Int, Int)]-internalEdgeList m = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ]

@@ -1,7 +1,8 @@+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.AdjacencyMap--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -37,22 +38,170 @@      -- * Graph transformation     removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,-    induce,+    induce, induceJust, +    -- * Graph composition+    compose, box,+     -- * Relational operations-    compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure+    closure, reflexiveClosure, symmetricClosure, transitiveClosure,++    -- * Miscellaneous+    consistent     ) where -import Data.Foldable (foldMap)+import Control.DeepSeq+import Data.List ((\\))+import Data.Map.Strict (Map) import Data.Monoid import Data.Set (Set) import Data.Tree--import Algebra.Graph.AdjacencyMap.Internal+import GHC.Generics  import qualified Data.Map.Strict as Map+import qualified Data.Maybe      as Maybe import qualified Data.Set        as Set +{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to+their adjacency sets. We define a 'Num' instance as a convenient notation for+working with graphs:++    > 0           == vertex 0+    > 1 + 2       == overlay (vertex 1) (vertex 2)+    > 1 * 2       == connect (vertex 1) (vertex 2)+    > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))+    > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))++__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"+show (1         :: AdjacencyMap Int) == "vertex 1"+show (1 + 2     :: AdjacencyMap Int) == "vertices [1,2]"+show (1 * 2     :: AdjacencyMap Int) == "edge 1 2"+show (1 * 2 * 3 :: AdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@++The 'Eq' instance satisfies all axioms of algebraic graphs:++    * 'overlay' is commutative and associative:++        >       x + y == y + x+        > x + (y + z) == (x + y) + z++    * 'connect' is associative and has 'empty' as the identity:++        >   x * empty == x+        >   empty * x == x+        > x * (y * z) == (x * y) * z++    * 'connect' distributes over 'overlay':++        > x * (y + z) == x * y + x * z+        > (x + y) * z == x * z + y * z++    * 'connect' can be decomposed:++        > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++    * 'overlay' has 'empty' as the identity and is idempotent:++        >   x + empty == x+        >   empty + x == x+        >       x + x == x++    * Absorption and saturation of 'connect':++        > x * y + x + y == x * y+        >     x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ and /m/+will denote the number of vertices and edges in the graph, respectively.++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 AdjacencyMap a = AM {+    -- | 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 ('edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1)+    -- adjacencyMap ('edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')]+    -- @+    adjacencyMap :: Map a (Set a) } deriving (Eq, Generic)++instance Ord a => Ord (AdjacencyMap a) where+    compare x y = mconcat+        [ compare (vertexCount x) (vertexCount  y)+        , compare (vertexSet   x) (vertexSet    y)+        , compare (edgeCount   x) (edgeCount    y)+        , compare (edgeSet     x) (edgeSet      y) ]++instance (Ord a, Show a) => Show (AdjacencyMap a) where+    showsPrec p am@(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             = vertexList am+        es             = edgeList am+        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)++-- | __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++instance NFData a => NFData (AdjacencyMap a) where+    rnf (AM a) = rnf a+ -- | Construct the /empty graph/. -- Complexity: /O(1)/ time and memory. --@@ -71,7 +220,7 @@ -- -- @ -- 'isEmpty'     (vertex x) == False--- 'hasVertex' x (vertex x) == True+-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount'   (vertex x) == 0 -- @@@ -108,7 +257,7 @@ -- '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)+overlay (AM x) (AM y) = AM $ Map.unionWith Set.union x y {-# NOINLINE [1] overlay #-}  -- | /Connect/ two graphs. This is an associative operation with the identity@@ -130,8 +279,8 @@ -- 'edgeCount'   (connect 1 2) == 1 -- @ connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a-connect x y = AM $ Map.unionsWith Set.union $ adjacencyMap x : adjacencyMap y :-    [ Map.fromSet (const . Map.keysSet $ adjacencyMap y) (Map.keysSet $ adjacencyMap x) ]+connect (AM x) (AM y) = AM $ Map.unionsWith Set.union $+    [ x, y, Map.fromSet (const $ Map.keysSet y) (Map.keysSet x) ] {-# NOINLINE [1] connect #-}  -- | Construct the graph comprising a given list of isolated vertices.@@ -155,6 +304,7 @@ -- @ -- edges []          == 'empty' -- edges [(x,y)]     == 'edge' x y+-- edges             == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges  == 'Data.List.nub' . 'Data.List.sort' -- @@@ -202,7 +352,7 @@ -- isSubgraphOf x y                         ==> x <= y -- @ isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool-isSubgraphOf x y = Map.isSubmapOfBy Set.isSubsetOf (adjacencyMap x) (adjacencyMap y)+isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy Set.isSubsetOf x y  -- | Check if a graph is empty. -- Complexity: /O(1)/ time.@@ -222,8 +372,7 @@ -- -- @ -- hasVertex x 'empty'            == False--- hasVertex x ('vertex' x)       == True--- hasVertex 1 ('vertex' 2)       == False+-- hasVertex x ('vertex' y)       == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool@@ -240,7 +389,7 @@ -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool-hasEdge u v a = case Map.lookup u (adjacencyMap a) of+hasEdge u v (AM m) = case Map.lookup u m of     Nothing -> False     Just vs -> Set.member v vs @@ -292,6 +441,7 @@ -- @ edgeList :: AdjacencyMap a -> [(a, a)] edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]+{-# INLINE edgeList #-}  -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory.@@ -338,7 +488,7 @@ -- 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 :: Ord a => a -> AdjacencyMap a -> Set a preSet x = Set.fromAscList . map fst . filter p  . Map.toAscList . adjacencyMap   where     p (_, set) = x `Set.member` set@@ -589,7 +739,7 @@  -- | 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+-- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to -- be evaluated. -- -- @@@ -602,6 +752,22 @@ induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a induce p = AM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap +-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'.+-- Complexity: /O(n + m)/ time.+--+-- @+-- induceJust ('vertex' 'Nothing')                               == 'empty'+-- induceJust ('edge' ('Just' x) 'Nothing')                        == 'vertex' x+-- induceJust . 'gmap' 'Just'                                    == 'id'+-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p+-- @+induceJust :: Ord a => AdjacencyMap (Maybe a) -> AdjacencyMap a+induceJust = AM . Map.map catMaybesSet . catMaybesMap . adjacencyMap+    where+      catMaybesSet = Set.mapMonotonic     Maybe.fromJust . Set.delete Nothing+      catMaybesMap = Map.mapKeysMonotonic Maybe.fromJust . Map.delete Nothing+ -- | 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@@ -630,6 +796,41 @@     tx = transpose x     vs = vertexSet x `Set.union` vertexSet y +-- | Compute the /Cartesian product/ of graphs.+-- Complexity: /O(n * m * log(n)^2)/ time.+--+-- @+-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\'))+--                                       , ((0,\'a\'), (1,\'a\'))+--                                       , ((0,\'b\'), (1,\'b\'))+--                                       , ((1,\'a\'), (1,\'b\')) ]+-- @+--+-- Up to an isomorphism between the resulting vertex types, this operation+-- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton+-- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@+-- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@.+--+-- @+-- box x y               ~~ box y x+-- box x (box y z)       ~~ box (box x y) z+-- box x ('overlay' y z)   == 'overlay' (box x y) (box x z)+-- box x ('vertex' ())     ~~ x+-- box x 'empty'           ~~ 'empty'+-- 'transpose'   (box x y) == box ('transpose' x) ('transpose' y)+-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y+-- @+box :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (a, b)+box (AM x) (AM y) = overlay (AM $ Map.fromAscList xs) (AM $ Map.fromAscList ys)+  where+    xs = do (a, as) <- Map.toAscList x+            b       <- Set.toAscList (Map.keysSet y)+            return ((a, b), Set.mapMonotonic (,b) as)+    ys = do a       <- Set.toAscList (Map.keysSet x)+            (b, bs) <- Map.toAscList y+            return ((a, b), Set.mapMonotonic (a,) bs)+ -- | Compute the /reflexive and transitive closure/ of a graph. -- Complexity: /O(n * m * log(n)^2)/ time. --@@ -691,3 +892,24 @@     | otherwise  = transitiveClosure new   where     new = overlay old (old `compose` old)++-- | Check that 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.+--+-- @+-- consistent 'empty'         == True+-- consistent ('vertex' x)    == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('edge' x y)    == True+-- consistent ('edges' xs)    == True+-- consistent ('stars' xs)    == True+-- @+consistent :: Ord a => AdjacencyMap a -> Bool+consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` Map.keysSet m++-- The set of vertices that are referred to by the edges of an adjacency map.+referredToVertexSet :: Ord a => Map a (Set a) -> Set a+referredToVertexSet m = Set.fromList $ concat+    [ [x, y] | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]

@@ -1,3 +1,5 @@+{-# language LambdaCase #-}+ ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.AdjacencyMap.Algorithm@@ -15,30 +17,104 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap.Algorithm (     -- * Algorithms-    dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc,+    bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable,+    topSort, isAcyclic, scc,      -- * Correctness properties-    isDfsForestOf, isTopSortOf+    isDfsForestOf, isTopSortOf,++    -- * Type synonyms+    Cycle     ) where  import Control.Monad-import Data.Foldable (toList)+import Control.Monad.Cont+import Control.Monad.State.Strict+import Data.Either+import Data.List.NonEmpty (NonEmpty(..),(<|)) import Data.Maybe import Data.Tree  import Algebra.Graph.AdjacencyMap+import Algebra.Graph.Internal -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.Array                          as Array+import qualified Data.List                           as List 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.+-- | Compute the /breadth-first search/ forest of a graph, such that+--   adjacent vertices are explored in increasing order with respect+--   to their 'Ord' instance. The search is seeded by a list of+--   argument vertices that will be the roots of the resulting+--   forest. Duplicates in the list will have their first occurrence+--   expanded and subsequent ones ignored. Argument vertices not in+--   the graph are also ignored. --+--   Let /L/ be the number of seed vertices. Complexity:+--   /O((L+m)*log n)/ time and /O(n)/ space.+-- -- @+-- 'forest' (bfsForest [1,2] $ 'edge' 1 2)      == 'vertices' [1,2]+-- 'forest' (bfsForest [2]   $ 'edge' 1 2)      == 'vertex' 2+-- 'forest' (bfsForest [3]   $ 'edge' 1 2)      == 'empty'+-- 'forest' (bfsForest [2,1] $ 'edge' 1 2)      == 'vertices' [1,2]+-- 'isSubgraphOf' ('forest' $ bfsForest vs x) x == True+-- bfsForest ('vertexList' g) g               == 'map' (\v -> Node v []) ('nub' $ 'vertexList' g)+-- bfsForest [] x                           == []+-- bfsForest [1,4] (3 * (1 + 4) * (1 + 5))  == [ Node { rootLabel = 1+--                                                    , subForest = [ Node { rootLabel = 5+--                                                                         , subForest = [] }]}+--                                             , Node { rootLabel = 4+--                                                    , subForest = [] }]+-- 'forest' (bfsForest [3] ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [3,2,1] + 'path' [3,4,5]+--+-- @+bfsForest :: Ord a => [a] -> AdjacencyMap a -> Forest a+bfsForest vs g = evalState (explore [ v | v <- vs, hasVertex v g ]) Set.empty where+  explore = unfoldForestM_BF walk <=< filterM discovered+  walk v = (v,) <$> adjacentM v+  adjacentM v = filterM discovered $ Set.toList (postSet v g)+  discovered v = do new <- gets (not . Set.member v)+                    when new $ modify' (Set.insert v)+                    return new++-- | This is 'bfsForest' with the resulting forest converted to a+--   level structure. Adjacent vertices are explored in increasing+--   order with respect to their 'Ord' instance. Flattening the result+--   via @'concat' . 'bfs' vs@ gives an enumeration of vertices+--   reachable from @vs@ in breadth first order.+--+--   Let /L/ be the number of seed vertices. Complexity:+--   /O((L+m)*log n)/ time and /O(n)/ space.+--+-- @+-- bfs vs 'empty'                                         == []+-- bfs [] g                                             == []+-- bfs [1]   ('edge' 1 1)                                 == [[1]]+-- bfs [1]   ('edge' 1 2)                                 == [[1],[2]]+-- bfs [2]   ('edge' 1 2)                                 == [[2]]+-- bfs [1,2] ('edge' 1 2)                                 == [[1,2]]+-- bfs [2,1] ('edge' 1 2)                                 == [[2,1]]+-- bfs [3]   ('edge' 1 2)                                 == []+-- bfs [1,2] ( (1*2) + (3*4) + (5*6) )                  == [[1,2]]+-- bfs [1,3] ( (1*2) + (3*4) + (5*6) )                  == [[1,3],[2,4]]+-- bfs [3] (3 * (1 + 4) * (1 + 5))                      == [[3],[1,4,5]]+-- bfs [2] ('circuit' [1..5] + 'circuit' [5,4..1])          == [[2],[1,3],[5,4]]+-- 'concat' (bfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == [3,2,4,1,5]+-- bfs vs == 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' vs+-- @+bfs :: Ord a => [a] -> AdjacencyMap a -> [[a]]+bfs vs = map concat . List.transpose . map levels . bfsForest vs++-- | Compute the /depth-first search/ forest of a graph, where+--   adjacent vertices are expanded in increasing order with respect+--   to their 'Ord' instance.+--+--   Complexity: /O((n+m)*log n)/ time and /O(n)/ space.+--+-- @ -- dfsForest 'empty'                       == [] -- 'forest' (dfsForest $ 'edge' 1 1)         == 'vertex' 1 -- 'forest' (dfsForest $ 'edge' 1 2)         == 'edge' 1 2@@ -54,14 +130,21 @@ --                                          , Node { rootLabel = 3 --                                                 , subForest = [ Node { rootLabel = 4 --                                                                      , subForest = [] }]}]+-- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5] -- @ dfsForest :: Ord a => AdjacencyMap a -> Forest a-dfsForest g = dfsForestFrom (vertexList g) g+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.+-- | Compute the /depth-first search/ forest of a graph from the given+--   vertices, where adjacent vertices are expanded in increasing+--   order with respect to their 'Ord' instance. Note that the+--   resulting forest does not necessarily span the whole graph, as+--   some vertices may be unreachable. Any of the given vertices which+--   are not in the graph are ignored. --+--   Let /L/ be the number of seed vertices. Complexity: /O((L+m)*log n)/+--   time and /O(n)/ space.+-- -- @ -- dfsForestFrom vs 'empty'                           == [] -- 'forest' (dfsForestFrom [1]   $ 'edge' 1 1)          == 'vertex' 1@@ -79,13 +162,30 @@ --                                                                                 , subForest = [] } --                                                     , Node { rootLabel = 4 --                                                            , subForest = [] }]+--  'forest' (dfsForestFrom [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [3,2,1,5,4] -- @ dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a-dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap+dfsForestFrom vs g = dfsForestFrom' [ v | v <- vs, hasVertex v g ] g --- | Compute the list of vertices visited by the /depth-first search/ in a--- graph, when searching from each of the given vertices in order.+dfsForestFrom' :: Ord a => [a] -> AdjacencyMap a -> Forest a+dfsForestFrom' vs g = evalState (explore vs) Set.empty where+  explore (v:vs) = discovered v >>= \case+    True -> (:) <$> walk v <*> explore vs+    False -> explore vs+  explore [] = return []+  walk v = Node v <$> explore (adjacent v)+  adjacent v = Set.toList (postSet v g)+  discovered v = do new <- gets (not . Set.member v)+                    when new $ modify' (Set.insert v)+                    return new++-- | Compute the vertices visited by /depth-first search/ in a graph+--   from the given vertices. Adjacent vertices are expanded in+--   increasing order with respect to their 'Ord' instance. --+--   Let /L/ be the number of seed vertices. Complexity: /O((L+m)*log n)/+--   time and /O(n)/ space.+-- -- @ -- dfs vs    $ 'empty'                    == [] -- dfs [1]   $ 'edge' 1 1                 == [1]@@ -97,14 +197,17 @@ -- dfs []    $ x                        == [] -- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4] -- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True+-- dfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1] == [3,2,1,5,4] -- @ dfs :: Ord a => [a] -> AdjacencyMap a -> [a]-dfs vs = concatMap flatten . dfsForestFrom vs+dfs vs = dfsForestFrom vs >=> flatten --- | 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/.+-- | Compute the list of vertices that are /reachable/ from a given+--   source vertex in a graph. The vertices in the resulting list+--   appear in /depth-first order/. --+--   Complexity: /O(m*log n)/ time and /O(n)/ space.+-- -- @ -- reachable x $ 'empty'                       == [] -- reachable 1 $ 'vertex' 1                    == [1]@@ -119,40 +222,99 @@ 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.+type Cycle = NonEmpty+data NodeState = Entered | Exited+data S a = S { parent :: Map.Map a a+             , entry  :: Map.Map a NodeState+             , order  :: [a] }++topSort' :: (Ord a, MonadState (S a) m, MonadCont m)+         => AdjacencyMap a -> m (Either (Cycle a) [a])+topSort' g = callCC $ \cyclic ->+  do let vertices = map fst $ Map.toDescList $ adjacencyMap g+         adjacent = Set.toDescList . flip postSet g+         dfsRoot x = nodeState x >>= \case+           Nothing -> enterRoot x >> dfs x >> exit x+           _       -> return ()+         dfs x = forM_ (adjacent x) $ \y ->+                   nodeState y >>= \case+                     Nothing      -> enter x y >> dfs y >> exit y+                     Just Exited  -> return ()+                     Just Entered -> cyclic . Left . retrace x y =<< gets parent+     forM_ vertices dfsRoot+     Right <$> gets order+  where+    nodeState v = gets (Map.lookup v . entry)+    enter u v = modify' (\(S m n vs) -> S (Map.insert v u m)+                                          (Map.insert v Entered n)+                                          vs)+    enterRoot v = modify' (\(S m n vs) -> S m (Map.insert v Entered n) vs)+    exit v = modify' (\(S m n vs) -> S m (Map.alter (fmap leave) v n) (v:vs))+      where leave = \case+              Entered -> Exited+              Exited  -> error "Internal error: dfs search order violated"+    retrace curr head parent = aux (curr :| []) where+      aux xs@(curr :| _)+        | head == curr = xs+        | otherwise = aux (parent Map.! curr <| xs)++-- | Compute a topological sort of a DAG or discover a cycle. --+--   Vertices are expanded in decreasing order with respect to their+--   'Ord' instance. This gives the lexicographically smallest+--   topological ordering in the case of success. In the case of+--   failure, the cycle is characterized by being the+--   lexicographically smallest up to rotation with respect to @Ord+--   (Dual a)@ in the first connected component of the graph+--   containing a cycle, where the connected components are ordered by+--   their largest vertex with respect to @Ord a@.+--+--   Complexity: /O((n+m)*log n)/ time and /O(n)/ space.+-- -- @--- 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 (1 * 2 + 3 * 1)                    == Right [3,1,2]+-- topSort ('path' [1..5])                      == Right [1..5]+-- topSort (3 * (1 * 4 + 2 * 5))              == Right [3,1,2,4,5]+-- topSort (1 * 2 + 2 * 1)                    == Left (2 ':|' [1])+-- topSort ('path' [5,4..1] + 'edge' 2 4)         == Left (4 ':|' [3,2])+-- topSort ('circuit' [1..3])                   == Left (3 ':|' [1,2])+-- topSort ('circuit' [1..3] + 'circuit' [3,2,1]) == Left (3 ':|' [2])+-- topSort (1*2 + 2*1 + 3*4 + 4*3 + 5*1)      == Left (1 ':|' [2])+-- fmap ('flip' 'isTopSortOf' x) (topSort x)      /= Right False+-- 'isRight' . topSort                          == 'isAcyclic'+-- topSort . 'vertices'                         == Right . 'nub' . 'sort' -- @-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)+topSort :: Ord a => AdjacencyMap a -> Either (Cycle a) [a]+topSort g = runContT (evalStateT (topSort' g) initialState) id where+  initialState = S Map.empty Map.empty []  -- | Check if a given graph is /acyclic/. --+--   Complexity: /O((n+m)*log n)/ time and /O(n)/ space.+-- -- @ -- isAcyclic (1 * 2 + 3 * 1) == True -- isAcyclic (1 * 2 + 2 * 1) == False -- isAcyclic . 'circuit'       == 'null'--- isAcyclic                 == 'isJust' . 'topSort'+-- isAcyclic                 == 'isRight' . 'topSort' -- @ isAcyclic :: Ord a => AdjacencyMap a -> Bool-isAcyclic = isJust . topSort+isAcyclic = isRight . 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". --+-- Details about the implementation can be found at+-- <https://github.com/jitwit/alga-notes/blob/master/gabow.org gabow-notes>.+--+-- Complexity: /O((n+m)*log n)/ time and /O(n+m)/ space.+-- -- @ -- scc 'empty'               == 'empty' -- scc ('vertex' x)          == 'vertex' (NonEmpty.'NonEmpty.vertex' x)+-- scc ('vertices' xs)       == 'vertices' ('map' 'NonEmpty.vertex' xs) -- 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))@@ -163,19 +325,99 @@ -- '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+scc g = condense g $ execState (gabowSCC g) initialState where+  initialState = SCC 0 0 [] [] Map.empty Map.empty [] [] []++data StateSCC a+  = SCC { preorder      :: {-# unpack #-} !Int+        , component     :: {-# unpack #-} !Int+        , boundaryStack :: [(Int,a)]+        , pathStack     :: [a]+        , preorders     :: Map.Map a Int+        , components    :: Map.Map a Int+        , innerGraphs   :: [AdjacencyMap a]+        , innerEdges    :: [(Int,(a,a))]+        , outerEdges    :: [(a,a)]+        } deriving (Show)++gabowSCC :: Ord a => AdjacencyMap a -> State (StateSCC a) ()+gabowSCC g =+  do let dfs u = do p_u <- enter u+                    forEach (postSet u g) $ \v -> do+                      preorderId v >>= \case+                        Nothing  -> do+                          updated <- dfs v+                          if updated then outedge (u,v) else inedge (p_u,(u,v))+                        Just p_v -> do+                          scc_v <- hasComponent v+                          if scc_v+                            then outedge (u,v)+                            else popBoundary p_v >> inedge (p_u,(u,v))+                    exit u+     forM_ (vertexList g) $ \v -> do+       assigned <- hasPreorderId v+       unless assigned $ void $ dfs v   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)+    -- called when visiting vertex v. assigns preorder number to v,+    -- adds the (id, v) pair to the boundary stack b, and adds v to+    -- the path stack s.+    enter v = do SCC pre scc bnd pth pres sccs gs es_i es_o <- get+                 let pre' = pre+1+                     bnd' = (pre,v):bnd+                     pth' = v:pth+                     pres' = Map.insert v pre pres+                 put $! SCC pre' scc bnd' pth' pres' sccs gs es_i es_o+                 return pre --- 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)+    -- called on back edges. pops the boundary stack while the top+    -- vertex has a larger preorder number than p_v.+    popBoundary p_v = modify'+      (\(SCC pre scc bnd pth pres sccs gs es_i es_o) ->+         SCC pre scc (dropWhile ((>p_v).fst) bnd) pth pres sccs gs es_i es_o)++    -- called when exiting vertex v. if v is the bottom of a scc+    -- boundary, we add a new SCC, otherwise v is part of a larger scc+    -- being constructed and we continue.+    exit v = do newComponent <- (v==).snd.head <$> gets boundaryStack+                when newComponent $ insertComponent v+                return newComponent++    insertComponent v = modify'+      (\(SCC pre scc bnd pth pres sccs gs es_i es_o) ->+         let (curr,v_pth') = span (/=v) pth+             pth' = tail v_pth' -- Here we know that v_pth' starts with v+             (es,es_i') = span ((>=p_v).fst) es_i+             g_i | null es = vertex v+                 | otherwise = edges (snd <$> es)+             p_v = fst $ head bnd+             scc' = scc + 1+             bnd' = tail bnd+             sccs' = List.foldl' (\sccs x -> Map.insert x scc sccs) sccs (v:curr)+             gs' = g_i:gs+          in SCC pre scc' bnd' pth' pres sccs' gs' es_i' es_o)++    inedge uv = modify'+      (\(SCC pre scc bnd pth pres sccs gs es_i es_o) ->+         SCC pre scc bnd pth pres sccs gs (uv:es_i) es_o)++    outedge uv = modify'+      (\(SCC pre scc bnd pth pres sccs gs es_i es_o) ->+         SCC pre scc bnd pth pres sccs gs es_i (uv:es_o))++    hasPreorderId v = gets (Map.member v . preorders)+    preorderId    v = gets (Map.lookup v . preorders)+    hasComponent  v = gets (Map.member v . components)++condense :: Ord a => AdjacencyMap a -> StateSCC a -> AdjacencyMap (NonEmpty.AdjacencyMap a)+condense g (SCC _ n _ _ _ assignment inner _ outer)+  | n == 1 = vertex $ convert g+  | otherwise = gmap (\c -> inner' Array.! (n-1-c)) outer'+  where inner' = Array.listArray (0,n-1) (convert <$> inner)+        outer' = es `overlay` vs+        vs = vertices [0..n-1]+        es = edges [ (sccid x, sccid y) | (x,y) <- outer ]+        sccid v = assignment Map.! v+        convert = fromJust . NonEmpty.toNonEmpty  -- | 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

@@ -1,207 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module     : Algebra.Graph.AdjacencyMap.Internal--- Copyright  : (c) Andrey Mokhov 2016-2018--- License    : MIT (see the file LICENSE)--- Maintainer : andrey.mokhov@gmail.com--- Stability  : unstable------ This module exposes the implementation of adjacency maps. The API is unstable--- and unsafe, and is exposed only for documentation. You should use the--- non-internal module "Algebra.Graph.AdjacencyMap" instead.-------------------------------------------------------------------------------module Algebra.Graph.AdjacencyMap.Internal (-    -- * Adjacency map implementation-    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 GHC.Generics--import qualified Data.Map.Strict as Map-import qualified Data.Set        as Set--{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to-their adjacency sets. We define a 'Num' instance as a convenient notation for-working with graphs:--    > 0           == vertex 0-    > 1 + 2       == overlay (vertex 1) (vertex 2)-    > 1 * 2       == connect (vertex 1) (vertex 2)-    > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))-    > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))--__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"-show (1         :: AdjacencyMap Int) == "vertex 1"-show (1 + 2     :: AdjacencyMap Int) == "vertices [1,2]"-show (1 * 2     :: AdjacencyMap Int) == "edge 1 2"-show (1 * 2 * 3 :: AdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]"-show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@--The 'Eq' instance satisfies all axioms of algebraic graphs:--    * 'Algebra.Graph.AdjacencyMap.overlay' is commutative and associative:--        >       x + y == y + x-        > x + (y + z) == (x + y) + z--    * 'Algebra.Graph.AdjacencyMap.connect' is associative and has-    'Algebra.Graph.AdjacencyMap.empty' as the identity:--        >   x * empty == x-        >   empty * x == x-        > x * (y * z) == (x * y) * z--    * 'Algebra.Graph.AdjacencyMap.connect' distributes over-    'Algebra.Graph.AdjacencyMap.overlay':--        > x * (y + z) == x * y + x * z-        > (x + y) * z == x * z + y * z--    * 'Algebra.Graph.AdjacencyMap.connect' can be decomposed:--        > x * y * z == x * y + x * z + y * z--The following useful theorems can be proved from the above set of axioms.--    * 'Algebra.Graph.AdjacencyMap.overlay' has 'Algebra.Graph.AdjacencyMap.empty'-    as the identity and is idempotent:--        >   x + empty == x-        >   empty + x == x-        >       x + x == x--    * Absorption and saturation of 'Algebra.Graph.AdjacencyMap.connect':--        > x * y + x + y == x * y-        >     x * x * x == x * x--When specifying the time and memory complexity of graph algorithms, /n/ and /m/-will denote the number of vertices and edges in the graph, respectively.--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 a graph: each vertex is associated with a set of-    -- its direct successors. Complexity: /O(1)/ time and memory.-    ---    -- @-    -- 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, Generic)--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-    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]      = 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)---- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap'--- for more details.-instance (Ord a, Num a) => Num (AdjacencyMap a) where-    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---- | Check if the internal graph representation is consistent, i.e. that all--- edges refer to existing vertices. It should be impossible to create an--- inconsistent adjacency map, and we use this function in testing.--- /Note: this function is for internal use only/.------ @--- consistent 'Algebra.Graph.AdjacencyMap.empty'         == True--- consistent ('Algebra.Graph.AdjacencyMap.vertex' x)    == True--- consistent ('Algebra.Graph.AdjacencyMap.overlay' x y) == True--- consistent ('Algebra.Graph.AdjacencyMap.connect' x y) == True--- consistent ('Algebra.Graph.AdjacencyMap.edge' x y)    == True--- consistent ('Algebra.Graph.AdjacencyMap.edges' xs)    == True--- consistent ('Algebra.Graph.AdjacencyMap.stars' xs)    == True--- @-consistent :: Ord a => AdjacencyMap a -> Bool-consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` keysSet m---- | 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

@@ -0,0 +1,836 @@+{-# LANGUAGE DeriveGeneric #-}+----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Bipartite.Undirected.AdjacencyMap+-- Copyright  : (c) Andrey Mokhov 2016-2020+-- 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 undirected bipartite+-- graphs and associated functions. To avoid name clashes with+-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified:+--+-- @+-- import qualified Algebra.Graph.Bipartite.Undirected.AdjacencyMap as Bipartite+-- @+----------------------------------------------------------------------------+module Algebra.Graph.Bipartite.Undirected.AdjacencyMap (+    -- * Data structure+    AdjacencyMap, leftAdjacencyMap, rightAdjacencyMap,++    -- * Basic graph construction primitives+    empty, leftVertex, rightVertex, vertex, edge, overlay, connect, vertices,+    edges, overlays, connects, swap,++    -- * Conversion functions+    toBipartite, toBipartiteWith, fromBipartite, fromBipartiteWith,++    -- * Graph properties+    isEmpty, hasLeftVertex, hasRightVertex, hasVertex, hasEdge, leftVertexCount,+    rightVertexCount, vertexCount, edgeCount, leftVertexList, rightVertexList,+    vertexList, edgeList, leftVertexSet, rightVertexSet, vertexSet, edgeSet,++    -- * Standard families of graphs+    circuit, biclique,++    -- * Algorithms+    OddCycle, detectParts,++    -- * Miscellaneous+    consistent+    ) where++import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.State+import Data.Either+import Data.Foldable+import Data.List+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Set (Set)+import GHC.Generics++import qualified Algebra.Graph.AdjacencyMap as AM++import qualified Data.Map.Strict as Map+import qualified Data.Set        as Set+import qualified Data.Tuple++{-| The 'Bipartite.AdjacencyMap' data type represents an undirected bipartite+graph. The two type parameteters define the types of identifiers of the vertices+of each part.++__Note:__ even if the identifiers and their types for two vertices of different+parts are equal, these vertices are considered to be different. See examples for+more details.++We define a 'Num' instance as a convenient notation for working with bipartite+graphs:++@+0                     == rightVertex 0+'swap' 1                == leftVertex 1+'swap' 1 + 2            == vertices [1] [2]+'swap' 1 * 2            == edge 1 2+'swap' 1 + 2 * 'swap' 3   == overlay (leftVertex 1) (edge 3 2)+'swap' 1 * (2 + 'swap' 3) == connect (leftVertex 1) (vertices [3] [2])+@++__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                 == "empty"+show 1                     == "rightVertex 1"+show ('swap' 2)              == "leftVertex 2"+show (1 + 2)               == "vertices [] [1,2]"+show ('swap' (1 + 2))        == "vertices [1,2] []"+show ('swap' 1 * 2)          == "edge 1 2"+show ('swap' 1 * 2 * 'swap' 3) == "edges [(1,2),(3,2)]"+show ('swap' 1 * 2 + 'swap' 3) == "overlay (leftVertex 3) (edge 1 2)"+@++The 'Eq' instance satisfies all axioms of algebraic graphs:++    * 'overlay' is commutative and associative:++        >       x + y == y + x+        > x + (y + z) == (x + y) + z++    * 'connect' is commutative, associative and has 'empty' as the identity:++        >   x * empty == x+        >   empty * x == x+        >       x * y == y * x+        > x * (y * z) == (x * y) * z++    * 'connect' distributes over 'overlay':++        > x * (y + z) == x * y + x * z+        > (x + y) * z == x * z + y * z++    * 'connect' can be decomposed:++        > x * y * z == x * y + x * z + y * z++    * 'connect' has the same effect as 'overlay' on vertices of one part:++        >  leftVertex x * leftVertex y  ==  leftVertex x + leftVertex y+        > rightVertex x * rightVertex y == rightVertex x + rightVertex y++The following useful theorems can be proved from the above set of axioms.++    * 'overlay' has 'empty' as the identity and is idempotent:++        > x + empty == x+        > empty + x == x+        >     x + x == x++    * Absorption and saturation of 'connect':++        > x * y + x + y == x * y+        >     x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ and /m/+will denote the number of vertices and edges in the graph, respectively. In+addition, /l/ and /r/ will denote the number of vertices in the left and in the+right part of graph, respectively.+-}+data AdjacencyMap a b = BAM {+    -- | The /adjacency map/ of the left part of the graph: each left vertex is+    -- associated with a set of its right neighbours.+    -- Complexity: /O(1)/ time and memory.+    --+    -- @+    -- leftAdjacencyMap 'empty'           == Map.'Map.empty'+    -- leftAdjacencyMap ('leftVertex' x)  == Map.'Map.singleton' x Set.'Set.empty'+    -- leftAdjacencyMap ('rightVertex' x) == Map.'Map.empty'+    -- leftAdjacencyMap ('edge' x y)      == Map.'Map.singleton' x (Set.'Set.singleton' y)+    -- @+    leftAdjacencyMap :: Map a (Set b),++    -- | The /adjacency map/ of the right part of the graph: each right vertex+    -- is associated with a set of left neighbours.+    -- Complexity: /O(1)/ time and memory.+    --+    -- @+    -- rightAdjacencyMap 'empty'           == Map.'Map.empty'+    -- rightAdjacencyMap ('leftVertex' x)  == Map.'Map.empty'+    -- rightAdjacencyMap ('rightVertex' x) == Map.'Map.singleton' x Set.'Set.empty'+    -- rightAdjacencyMap ('edge' x y)      == Map.'Map.singleton' y (Set.'Set.singleton' x)+    -- @+    rightAdjacencyMap :: Map b (Set a)+    } deriving Generic++-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap'+-- for more details.+instance (Ord a, Ord b, Num b) => Num (AdjacencyMap a b) where+    fromInteger = rightVertex . fromInteger+    (+)         = overlay+    (*)         = connect+    signum      = const empty+    abs         = id+    negate      = id++instance (Ord a, Ord b) => Eq (AdjacencyMap a b) where+    BAM lr1 rl1 == BAM lr2 rl2 = lr1 == lr2 && Map.keysSet rl1 == Map.keysSet rl2++instance (Ord a, Ord b) => Ord (AdjacencyMap a b) where+    compare x y = mconcat+        [ compare (vertexCount x) (vertexCount  y)+        , compare (vertexSet   x) (vertexSet    y)+        , compare (edgeCount   x) (edgeCount    y)+        , compare (edgeSet     x) (edgeSet      y) ]++instance (Ord a, Ord b, Show a, Show b) => Show (AdjacencyMap a b) where+    showsPrec p bam+        | null lvs && null rvs             = showString "empty"+        | null es                          = showParen (p > 10) $ vshow lvs rvs+        | (lvs == lused) && (rvs == rused) = showParen (p > 10) $ eshow es+        | otherwise                        = showParen (p > 10)+                                           $ showString "overlay ("+                                           . veshow (vs \\ used)+                                           . showString ") ("+                                           . eshow es+                                           . showString ")"+      where+        lvs = leftVertexList bam+        rvs = rightVertexList bam+        vs  = vertexList bam+        es  = edgeList bam+        vshow [x] [] = showString "leftVertex " . showsPrec 11 x+        vshow [] [x] = showString "rightVertex " . showsPrec 11 x+        vshow xs ys  = showString "vertices " . showsPrec 11 xs+                     . showString " " . showsPrec 11 ys+        veshow xs      = vshow (lefts xs) (rights xs)+        eshow [(x, y)] = showString "edge " . showsPrec 11 x+                       . showString " " . showsPrec 11 y+        eshow es       = showString "edges " . showsPrec 11 es+        lused = Set.toAscList $ Set.fromAscList [ u | (u, _) <- edgeList bam ]+        rused = Set.toAscList $ Set.fromList    [ v | (_, v) <- edgeList bam ]+        used  = map Left lused ++ map Right rused++-- | Construct the /empty graph/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'isEmpty' empty           == True+-- 'leftAdjacencyMap' empty  == Map.'Map.empty'+-- 'rightAdjacencyMap' empty == Map.'Map.empty'+-- 'hasVertex' x empty       == False+-- @+empty :: AdjacencyMap a b+empty = BAM Map.empty Map.empty++-- | Construct the bipartite graph comprising /a single isolated vertex/ in+-- the left part.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'leftAdjacencyMap' (leftVertex x)  == Map.'Map.singleton' x Set.'Set.empty'+-- 'rightAdjacencyMap' (leftVertex x) == Map.'Map.empty'+-- 'hasLeftVertex' x (leftVertex y)   == (x == y)+-- 'hasRightVertex' x (leftVertex y)  == False+-- 'hasEdge' x y (leftVertex z)       == False+-- @+leftVertex :: a -> AdjacencyMap a b+leftVertex x = BAM (Map.singleton x Set.empty) Map.empty++-- | Construct the bipartite graph comprising /a single isolated vertex/ in+-- the right part.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'leftAdjacencyMap' (rightVertex x)  == Map.'Map.empty'+-- 'rightAdjacencyMap' (rightVertex x) == Map.'Map.singleton' x Set.'Set.empty'+-- 'hasLeftVertex' x (rightVertex y)   == False+-- 'hasRightVertex' x (rightVertex y)  == (x == y)+-- 'hasEdge' x y (rightVertex z)       == False+-- @+rightVertex :: b -> AdjacencyMap a b+rightVertex y = BAM Map.empty (Map.singleton y Set.empty)++-- | Construct the bipartite graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- vertex . Left  == 'leftVertex'+-- vertex . Right == 'rightVertex'+-- @+vertex :: Either a b -> AdjacencyMap a b+vertex (Left x)  = leftVertex x+vertex (Right y) = rightVertex y++-- | Construct the bipartite graph comprising /a single edge/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- edge x y                     == 'connect' ('leftVertex' x) ('rightVertex' y)+-- 'leftAdjacencyMap' (edge x y)  == Map.'Map.singleton' x (Set.'Set.singleton' y)+-- 'rightAdjacencyMap' (edge x y) == Map.'Map.singleton' y (Set.'Set.singleton' x)+-- 'hasEdge' x y (edge x y)       == True+-- 'hasEdge' 1 2 (edge 2 1)       == False+-- @+edge :: a -> b -> AdjacencyMap a b+edge x y =+    BAM (Map.singleton x (Set.singleton y)) (Map.singleton y (Set.singleton x))++-- | /Overlay/ two bipartite 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+-- @+overlay :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b+overlay (BAM lr1 rl1) (BAM lr2 rl2) =+    BAM (Map.unionWith Set.union lr1 lr2) (Map.unionWith Set.union rl1 rl2)++-- | /Connect/ two bipartite graphs, not adding the edges between vertices in+-- the same part. This is a commutative and 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 in the arguments: /O(m1 + m2 + l1 * r2 + l2 * r1)/.+--+-- @+-- connect ('leftVertex' x)     ('leftVertex' y)     == 'vertices' [x,y] []+-- connect ('leftVertex' x)     ('rightVertex' y)    == 'edge' x y+-- connect ('rightVertex' x)    ('leftVertex' y)     == 'edge' y x+-- connect ('rightVertex' x)    ('rightVertex' y)    == 'vertices' [] [x,y]+-- connect ('vertices' xs1 ys1) ('vertices' xs2 ys2) == 'overlay' ('biclique' xs1 ys2) ('biclique' xs2 ys1)+-- '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)                     >= 'leftVertexCount' x * 'rightVertexCount' y+-- 'edgeCount'   (connect x y)                     <= 'leftVertexCount' x * 'rightVertexCount' y + 'rightVertexCount' x * 'leftVertexCount' y + 'edgeCount' x + 'edgeCount' y+-- @+connect :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b+connect (BAM lr1 rl1) (BAM lr2 rl2) = BAM lr rl+  where+    l1 = Map.keysSet lr1+    l2 = Map.keysSet lr2+    r1 = Map.keysSet rl1+    r2 = Map.keysSet rl2+    lr = Map.unionsWith Set.union+        [ lr1, lr2, Map.fromSet (const r2) l1, Map.fromSet (const r1) l2 ]+    rl = Map.unionsWith Set.union+        [ rl1, rl2, Map.fromSet (const l2) r1, Map.fromSet (const l1) r2 ]++-- | Construct the graph comprising two given lists of isolated vertices for+-- each part.+-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the total+-- length of two lists.+--+-- @+-- vertices [] []                    == 'empty'+-- vertices [x] []                   == 'leftVertex' x+-- vertices [] [x]                   == 'rightVertex' x+-- 'hasLeftVertex'  x (vertices xs ys) == 'elem' x xs+-- 'hasRightVertex' y (vertices xs ys) == 'elem' y ys+-- @+vertices :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b+vertices ls rs = BAM (Map.fromList [ (l, Set.empty) | l <- ls ])+                     (Map.fromList [ (r, Set.empty) | r <- rs ])++-- | Construct the graph from a list of edges.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- edges []            == 'empty'+-- edges [(x,y)]       == 'edge' x y+-- edges               == 'overlays' . 'map' ('uncurry' 'edge')+-- 'hasEdge' x y . edges == 'elem' (x,y)+-- 'edgeCount'   . edges == 'length' . 'nub'+-- @+edges :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b+edges es = BAM (Map.fromListWith Set.union [ (x, Set.singleton y) | (x, y) <- es ])+               (Map.fromListWith Set.union [ (y, Set.singleton x) | (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 :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b+overlays ams = BAM (Map.unionsWith Set.union (map leftAdjacencyMap  ams))+                   (Map.unionsWith Set.union (map rightAdjacencyMap ams))++-- | Connect a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- connects []        == 'empty'+-- connects [x]       == x+-- connects [x,y]     == connect x y+-- connects           == 'foldr' 'connect' 'empty'+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b+connects = foldr connect empty++-- | Swap parts of a given graph.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- swap 'empty'            == 'empty'+-- swap . 'leftVertex'     == 'rightVertex'+-- swap ('vertices' xs ys) == 'vertices' ys xs+-- swap ('edge' x y)       == 'edge' y x+-- swap . 'edges'          == 'edges' . 'map' Data.Tuple.'Data.Tuple.swap'+-- swap . swap           == 'id'+-- @+swap :: AdjacencyMap a b -> AdjacencyMap b a+swap (BAM lr rl) = BAM rl lr++-- | Construct a bipartite 'AdjacencyMap' from an "Algebra.Graph.AdjacencyMap"+-- with given part identifiers, adding all needed edges to make the graph+-- undirected and removing all edges within the same parts.+-- Complexity: /O(m * log(n))/.+--+-- @+-- toBipartite 'Algebra.Graph.AdjacencyMap.empty'                      == 'empty'+-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Left x))          == 'leftVertex' x+-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Right x))         == 'rightVertex' x+-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Left y))   == 'vertices' [x,y] []+-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Right y))  == 'edge' x y+-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Left y))  == 'edge' y x+-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Right y)) == 'vertices' [] [x,y]+-- toBipartite ('Algebra.Graph.AdjacencyMap.clique' xs)                == 'uncurry' 'biclique' ('partitionEithers' xs)+-- toBipartite . 'fromBipartite'            == 'id'+-- @+toBipartite :: (Ord a, Ord b) => AM.AdjacencyMap (Either a b) -> AdjacencyMap a b+toBipartite m = BAM (Map.fromAscList [ (x, setRights ys) | (Left  x, ys) <- symmetricList ])+                    (Map.fromAscList [ (x, setLefts  ys) | (Right x, ys) <- symmetricList ])+  where+    setRights     = Set.fromAscList . rights . Set.toAscList+    setLefts      = Set.fromAscList . lefts  . Set.toAscList+    symmetricList = Map.toAscList $ AM.adjacencyMap $ AM.symmetricClosure m++-- | Construct a bipartite 'AdjacencyMap' from "Algebra.Graph.AdjacencyMap"+-- with part identifiers obtained from a given function, adding all neeeded+-- edges to make the graph undirected and removing all edges within the same+-- parts.+-- Complexity: /O(m * log(n))/.+--+-- @+-- toBipartiteWith f 'Algebra.Graph.AdjacencyMap.empty' == 'empty'+-- toBipartiteWith Left x  == 'vertices' ('vertexList' x) []+-- toBipartiteWith Right x == 'vertices' [] ('vertexList' x)+-- toBipartiteWith f       == 'toBipartite' . 'Algebra.Graph.AdjacencyMap.gmap' f+-- toBipartiteWith id      == 'toBipartite'+-- @+toBipartiteWith :: (Ord a, Ord b, Ord c) => (a -> Either b c) -> AM.AdjacencyMap a -> AdjacencyMap b c+toBipartiteWith f = toBipartite . AM.gmap f++-- | Construct an 'Algrebra.Graph.AdjacencyMap' from a bipartite 'AdjacencyMap'.+-- Complexity: /O(m * log(n))/.+--+-- @+-- fromBipartite 'empty'          == 'Algebra.Graph.AdjacencyMap.empty'+-- fromBipartite ('leftVertex' x) == 'Algebra.Graph.AdjacencyMap.vertex' (Left x)+-- fromBipartite ('edge' x y)     == 'Algebra.Graph.AdjacencyMap.edges' [(Left x, Right y), (Right y, Left x)]+-- 'toBipartite' . fromBipartite  == 'id'+-- @+fromBipartite :: (Ord a, Ord b) => AdjacencyMap a b -> AM.AdjacencyMap (Either a b)+fromBipartite (BAM lr rl) = AM.fromAdjacencySets $+    [ (Left  x, Set.mapMonotonic Right ys) | (x, ys) <- Map.toAscList lr ] +++    [ (Right y, Set.mapMonotonic Left  xs) | (y, xs) <- Map.toAscList rl ]++-- | Construct an 'Algrebra.Graph.AdjacencyMap' from a bipartite 'AdjacencyMap'+-- given a way to inject vertices from different parts into the resulting vertex+-- type.+-- Complexity: /O(m * log(n))/.+--+-- @+-- fromBipartiteWith Left Right             == 'fromBipartite'+-- fromBipartiteWith id id ('vertices' xs ys) == 'Algebra.Graph.AdjacencyMap.vertices' (xs ++ ys)+-- fromBipartiteWith id id . 'edges'          == 'Algebra.Graph.AdjacencyMap.symmetricClosure' . 'Algebra.Graph.AdjacencyMap.edges'+-- @+fromBipartiteWith :: Ord c => (a -> c) -> (b -> c) -> AdjacencyMap a b -> AM.AdjacencyMap c+fromBipartiteWith f g (BAM lr rl) = AM.fromAdjacencySets $+    [ (f x, Set.map g ys) | (x, ys) <- Map.toAscList lr ] +++    [ (g y, Set.map f xs) | (y, xs) <- Map.toAscList rl ]++-- | Check if a graph is empty.+-- Complecity: /O(1)/ time.+--+-- @+-- isEmpty 'empty'                 == True+-- isEmpty ('overlay' 'empty' 'empty') == True+-- isEmpty ('vertex' x)            == False+-- isEmpty                       == (==) 'empty'+-- @+isEmpty :: AdjacencyMap a b -> Bool+isEmpty (BAM lr rl) = Map.null lr && Map.null rl++-- | Check if a graph contains a given vertex in the left part.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasLeftVertex x 'empty'           == False+-- hasLeftVertex x ('leftVertex' y)  == (x == y)+-- hasLeftVertex x ('rightVertex' y) == False+-- @+hasLeftVertex :: Ord a => a -> AdjacencyMap a b -> Bool+hasLeftVertex x (BAM lr _) = Map.member x lr++-- | Check if a graph contains a given vertex in the right part.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasRightVertex x 'empty'           == False+-- hasRightVertex x ('leftVertex' y)  == False+-- hasRightVertex x ('rightVertex' y) == (x == y)+-- @+hasRightVertex :: Ord b => b -> AdjacencyMap a b -> Bool+hasRightVertex y (BAM _ rl) = Map.member y rl++-- | Check if a graph contains a given vertex.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasVertex . Left  == 'hasLeftVertex'+-- hasVertex . Right == 'hasRightVertex'+-- @+hasVertex :: (Ord a, Ord b) => Either a b -> AdjacencyMap a b -> Bool+hasVertex (Left x)  = hasLeftVertex x+hasVertex (Right y) = hasRightVertex y++-- | Check if a graph contains a given edge.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasEdge x y 'empty'      == False+-- hasEdge x y ('vertex' z) == False+-- hasEdge x y ('edge' x y) == True+-- hasEdge x y            == 'elem' (x,y) . 'edgeList'+-- @+hasEdge :: (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> Bool+hasEdge x y (BAM m _) = (Set.member y <$> Map.lookup x m) == Just True++-- | The number of vertices in the left part in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- leftVertexCount 'empty'           == 0+-- leftVertexCount ('leftVertex' x)  == 1+-- leftVertexCount ('rightVertex' x) == 0+-- leftVertexCount ('edge' x y)      == 1+-- leftVertexCount . 'edges'         == 'length' . 'nub' . 'map' 'fst'+-- @+leftVertexCount :: AdjacencyMap a b -> Int+leftVertexCount = Map.size . leftAdjacencyMap++-- | The number of vertices in the right part in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- rightVertexCount 'empty'           == 0+-- rightVertexCount ('leftVertex' x)  == 0+-- rightVertexCount ('rightVertex' x) == 1+-- rightVertexCount ('edge' x y)      == 1+-- rightVertexCount . 'edges'         == 'length' . 'nub' . 'map' 'snd'+-- @+rightVertexCount :: AdjacencyMap a b -> Int+rightVertexCount = Map.size . rightAdjacencyMap++-- | The number of vertices in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexCount 'empty'      == 0+-- vertexCount ('vertex' x) == 1+-- vertexCount ('edge' x y) == 2+-- vertexCount x          == 'leftVertexCount' x + 'rightVertexCount' x+-- @+vertexCount :: AdjacencyMap a b -> Int+vertexCount g = leftVertexCount g + rightVertexCount g++-- | The number of edges in a graph.+-- Complexity: /O(n)/ time.+--+-- @+-- edgeCount 'empty'      == 0+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount . 'edges'    == 'length' . 'nub'+-- @+edgeCount :: AdjacencyMap a b -> Int+edgeCount = Map.foldr ((+) . Set.size) 0 . leftAdjacencyMap++-- | The sorted list of vertices of the left part of a given graph.+-- Complexity: /O(l)/ time and memory.+--+-- @+-- leftVertexList 'empty'              == []+-- leftVertexList ('leftVertex' x)     == [x]+-- leftVertexList ('rightVertex' x)    == []+-- leftVertexList . 'flip' 'vertices' [] == 'nub' . 'sort'+-- @+leftVertexList :: AdjacencyMap a b -> [a]+leftVertexList = Map.keys . leftAdjacencyMap++-- | The sorted list of vertices of the right part of a given graph.+-- Complexity: /O(r)/ time and memory.+--+-- @+-- rightVertexList 'empty'           == []+-- rightVertexList ('leftVertex' x)  == []+-- rightVertexList ('rightVertex' x) == [x]+-- rightVertexList . 'vertices' []   == 'nub' . 'sort'+-- @+rightVertexList :: AdjacencyMap a b -> [b]+rightVertexList = Map.keys . rightAdjacencyMap++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(n)/ time and memory+--+-- @+-- vertexList 'empty'                             == []+-- vertexList ('vertex' x)                        == [x]+-- vertexList ('edge' x y)                        == [Left x, Right y]+-- vertexList ('vertices' ('lefts' xs) ('rights' xs)) == 'nub' ('sort' xs)+-- @+vertexList :: AdjacencyMap a b -> [Either a b]+vertexList g = map Left (leftVertexList g) ++ map Right (rightVertexList g)++-- | The sorted list of edges of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeList 'empty'      == []+-- edgeList ('vertex' x) == []+-- edgeList ('edge' x y) == [(x,y)]+-- edgeList . 'edges'    == 'nub' . 'sort'+-- @+edgeList :: AdjacencyMap a b -> [(a, b)]+edgeList (BAM lr _) = [ (x, y) | (x, ys) <- Map.toAscList lr, y <- Set.toAscList ys ]++-- | The set of vertices of the left part of a given graph.+-- Complexity: /O(l)/ time and memory.+--+-- @+-- leftVertexSet 'empty'              == Set.'Set.empty'+-- leftVertexSet . 'leftVertex'       == Set.'Set.singleton'+-- leftVertexSet . 'rightVertex'      == 'const' Set.'Set.empty'+-- leftVertexSet . 'flip' 'vertices' [] == Set.'Set.fromList'+-- @+leftVertexSet :: AdjacencyMap a b -> Set a+leftVertexSet = Map.keysSet . leftAdjacencyMap++-- | The set of vertices of the right part of a given graph.+-- Complexity: /O(r)/ time and memory.+--+-- @+-- rightVertexSet 'empty'         == Set.'Set.empty'+-- rightVertexSet . 'leftVertex'  == 'const' Set.'Set.empty'+-- rightVertexSet . 'rightVertex' == Set.'Set.singleton'+-- rightVertexSet . 'vertices' [] == Set.'Set.fromList'+-- @+rightVertexSet :: AdjacencyMap a b -> Set b+rightVertexSet = Map.keysSet . rightAdjacencyMap++-- | 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 ('edge' x y)                        == Set.'Set.fromList' [Left x, Right y]+-- vertexSet ('vertices' ('lefts' xs) ('rights' xs)) == Set.'Set.fromList' xs+-- @+vertexSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (Either a b)+vertexSet = Set.fromAscList . vertexList++-- | The set of edges of a given graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeSet 'empty'      == Set.'Data.Set.empty'+-- edgeSet ('vertex' x) == Set.'Data.Set.empty'+-- edgeSet ('edge' x y) == Set.'Data.Set.singleton' (x,y)+-- edgeSet . 'edges'    == Set.'Data.Set.fromList'+-- @+edgeSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (a, b)+edgeSet = Set.fromAscList . edgeList++-- | The /circuit/ on a list of vertices.+-- Complexity: /O(n * log(n))/ time and /O(n)/ memory.+--+-- @+-- circuit []                    == 'empty'+-- circuit [(x,y)]               == 'edge' x y+-- circuit [(1,2), (3,4)]        == 'biclique' [1,3] [2,4]+-- circuit [(1,2), (3,4), (5,6)] == 'edges' [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)]+-- circuit . 'reverse'             == 'swap' . circuit . 'map' Data.Tuple.'Data.Tuple.swap'+-- @+circuit :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b+circuit [] = empty+circuit xs = edges $ xs ++ zip (drop 1 $ cycle as) bs+  where+    (as, bs) = unzip xs++-- | The /biclique/ on two lists of vertices.+-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory.+--+-- @+-- biclique [] [] == 'empty'+-- biclique xs [] == 'vertices' xs []+-- biclique [] ys == 'vertices' [] ys+-- biclique xs ys == 'connect' ('vertices' xs []) ('vertices' [] ys)+-- @+biclique :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b+biclique xs ys = BAM (Map.fromSet (const sys) sxs) (Map.fromSet (const sxs) sys)+  where+    sxs = Set.fromList xs+    sys = Set.fromList ys++data Part = LeftPart | RightPart deriving (Show, Eq)++otherPart :: Part -> Part+otherPart LeftPart  = RightPart+otherPart RightPart = LeftPart++-- | An cycle of odd length. For example, @[1, 2, 3]@ represents the cycle+-- @1 -> 2 -> 3 -> 1@.+type OddCycle a = [a] -- TODO: Make this representation type-safe++-- | Test the bipartiteness of given graph. In case of success, return an+-- 'AdjacencyMap' with the same set of edges and each vertex marked with the+-- part it belongs to. In case of failure, return any cycle of odd length in the+-- graph.+--+-- The returned partition is lexicographically minimal. That is, consider the+-- string of part identifiers for each vertex in ascending order. Then,+-- considering that the identifier of the left part is less then the identifier+-- of the right part, this string is lexicographically minimal of all such+-- strings for all partitions.+--+-- The returned cycle is optimal in the following way: there exists a path that+-- is either empty or ends in a vertex adjacent to the first vertex in the+-- cycle, such that all vertices in @path ++ cycle@ are distinct and+-- @path ++ cycle@ is lexicographically minimal among all such pairs of paths+-- and cycles.+--+-- /Note/: since 'AdjacencyMap' represents __undirected__ bipartite graphs, all+-- edges in the input graph are treated as undirected. See the examples and the+-- correctness property for a clarification.+--+-- It is advised to use 'leftVertexList' and 'rightVertexList' to obtain the+-- partition of the vertices and 'hasLeftVertex' and 'hasRightVertex' to check+-- whether a vertex belongs to a part.+--+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- detectParts 'Algebra.Graph.AdjacencyMap.empty'                                       == Right 'empty'+-- detectParts ('Algebra.Graph.AdjacencyMap.vertex' x)                                  == Right ('leftVertex' x)+-- detectParts ('Algebra.Graph.AdjacencyMap.edge' x x)                                  == Left [x]+-- detectParts ('Algebra.Graph.AdjacencyMap.edge' 1 2)                                  == Right ('edge' 1 2)+-- detectParts (1 * (2 + 3))                               == Right ('edges' [(1,2), (1,3)])+-- detectParts (1 * 2 * 3)                                 == Left [1, 2, 3]+-- detectParts ((1 + 3) * (2 + 4) + 6 * 5)                 == Right ('swap' (1 + 3) * (2 + 4) + 'swap' 5 * 6)+-- detectParts ((1 * 3 * 4) + 2 * (1 + 2))                 == Left [2]+-- detectParts ('Algebra.Graph.AdjacencyMap.clique' [1..10])                            == Left [1, 2, 3]+-- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..10])                           == Right ('circuit' [(x, x + 1) | x <- [1,3,5,7,9]])+-- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..11])                           == Left [1..11]+-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' [] xs)                            == Right ('vertices' xs [])+-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' ('map' Left (x:xs)) ('map' Right ys)) == Right ('biclique' ('map' Left (x:xs)) ('map' Right ys))+-- 'isRight' (detectParts ('Algebra.Graph.AdjacencyMap.star' x ys))                       == 'notElem' x ys+-- 'isRight' (detectParts ('fromBipartite' ('toBipartite' x)))   == True+-- @+--+-- The correctness of 'detectParts' can be expressed by the following property:+--+-- @+-- let undirected = 'Algebra.Graph.AdjacencyMap.symmetricClosure' input in+-- case detectParts input of+--     Left cycle -> 'mod' (length cycle) 2 == 1 && 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.circuit' cycle) undirected+--     Right result -> 'Algebra.Graph.AdjacencyMap.gmap' 'Data.Either.Extra.fromEither' ('fromBipartite' result) == undirected+-- @+detectParts :: Ord a => AM.AdjacencyMap a -> Either (OddCycle a) (AdjacencyMap a a)+detectParts x = case runState (runMaybeT dfs) Map.empty of+    (Nothing, m) -> Right $ toBipartiteWith (toEither m) g+    (Just c,  _) -> Left  $ oddCycle c+  where+    -- g :: AM.AdjacencyMap a+    g = AM.symmetricClosure x++    -- type PartMap a = Map a Part+    -- type PartMonad a = MaybeT (State (PartMap a)) [a]+    -- dfs :: PartMonad a+    dfs = asum [ processVertex v | v <- AM.vertexList g ]++    -- processVertex :: a -> PartMonad a+    processVertex v = do m <- get+                         guard (Map.notMember v m)+                         inVertex LeftPart v++    -- inVertex :: Part -> a -> PartMonad a+    inVertex p v = ((:) v) <$> do modify (Map.insert v p)+                                  let q = otherPart p+                                  asum [ onEdge q u | u <- Set.toAscList (AM.postSet v g) ]++    {-# INLINE onEdge #-}+    -- onEdge :: Part -> a -> PartMonad a+    onEdge p v = do m <- get+                    case Map.lookup v m of+                        Nothing -> inVertex p v+                        Just q  -> do guard (p /= q)+                                      return [v]++    -- toEither :: PartMap a -> a -> Either a a+    toEither m v = case fromJust (Map.lookup v m) of+                       LeftPart  -> Left  v+                       RightPart -> Right v++    -- oddCycle :: [a] -> [a]+    oddCycle c = init $ dropWhile (/= last c) c++-- | Check that the internal graph representation is consistent, i.e. that all+-- edges that are present in the 'leftAdjacencyMap' are also present in the+-- 'rightAdjacencyMap' map. It should be impossible to create an inconsistent+-- adjacency map, and we use this function in testing.+--+-- @+-- consistent 'empty'           == True+-- consistent ('vertex' x)      == True+-- consistent ('edge' x y)      == True+-- consistent ('edges' x)       == True+-- consistent ('toBipartite' x) == True+-- consistent ('swap' x)        == True+-- consistent ('circuit' x)     == True+-- consistent ('biclique' x y)  == True+-- @+consistent :: (Ord a, Ord b) => AdjacencyMap a b -> Bool+consistent (BAM lr rl) = edgeList lr == sort (map Data.Tuple.swap $ edgeList rl)+  where+    edgeList lr = [ (u, v) | (u, vs) <- Map.toAscList lr, v <- Set.toAscList vs ]

@@ -15,8 +15,7 @@ -- implemented fully polymorphically and require the use of an intermediate data -- type are not included. For example, to compute the number of vertices in a -- 'Graph' expression you will need to use a concrete data type, such as--- "Algebra.Graph.Fold". Other useful 'Graph' instances are defined in--- "Algebra.Graph", "Algebra.Graph.AdjacencyMap" and "Algebra.Graph.Relation".+-- "Algebra.Graph.Graph" or "Algebra.Graph.AdjacencyMap". -- -- See "Algebra.Graph.HigherKinded.Class" for the higher-kinded version of the -- core graph type class.@@ -47,18 +46,15 @@     path, circuit, clique, biclique, star, tree, forest     ) where -import Prelude ()-import Prelude.Compat- import Data.Tree  import Algebra.Graph.Label (Dioid, one)  import qualified Algebra.Graph                       as G+import qualified Algebra.Graph.Undirected            as UG 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 import qualified Algebra.Graph.Relation.Symmetric    as RS@@ -129,19 +125,21 @@     overlay = G.overlay     connect = G.connect +instance Graph (UG.Graph a) where+    type Vertex (UG.Graph a) = a+    empty = UG.empty+    vertex = UG.vertex+    overlay = UG.overlay+    connect = UG.connect++instance Undirected (UG.Graph a)+ instance Ord a => Graph (AM.AdjacencyMap a) where     type Vertex (AM.AdjacencyMap a) = a     empty   = AM.empty     vertex  = AM.vertex     overlay = AM.overlay     connect = AM.connect--instance Graph (F.Fold a) where-    type Vertex (F.Fold a) = a-    empty   = F.empty-    vertex  = F.vertex-    overlay = F.overlay-    connect = F.connect  instance Graph AIM.AdjacencyIntMap where     type Vertex AIM.AdjacencyIntMap = Int

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Export--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -23,14 +23,12 @@      -- * Generic graph export     export-  ) where--import Prelude ()-import Prelude.Compat hiding (unlines)+    ) where  import Data.Foldable (fold) import Data.Semigroup import Data.String hiding (unlines)+import Prelude hiding (unlines)  import Algebra.Graph.ToGraph (ToGraph, ToVertex, toAdjacencyMap) import Algebra.Graph.AdjacencyMap (vertexList, edgeList)

@@ -19,7 +19,7 @@      -- * Export functions     export, exportAsIs, exportViaShow-  ) where+    ) where  import Data.List hiding (unlines) import Data.Monoid

@@ -1,736 +0,0 @@-{-# LANGUAGE RankNTypes #-}--------------------------------------------------------------------------------- |--- Module     : Algebra.Graph.Fold--- 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 'Fold' data type -- the Boehm-Berarducci encoding of--- algebraic graphs, which is used for generalised graph folding and for the--- implementation of polymorphic graph construction and transformation algorithms.--- 'Fold' is an instance of type classes defined in modules "Algebra.Graph.Class"--- and "Algebra.Graph.HigherKinded.Class", which can be used for polymorphic--- graph construction and manipulation.-------------------------------------------------------------------------------module Algebra.Graph.Fold (-    -- * Boehm-Berarducci encoding of algebraic graphs-    Fold,--    -- * Basic graph construction primitives-    empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,--    -- * Graph folding-    foldg,--    -- * Relations on graphs-    isSubgraphOf,--    -- * Graph properties-    isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList,-    edgeList, vertexSet, edgeSet, adjacencyList,--    -- * Standard families of graphs-    path, circuit, clique, biclique, star, stars,--    -- * Graph transformation-    removeVertex, removeEdge, transpose, induce, simplify,-    ) where--import Prelude ()-import Prelude.Compat--import Control.Applicative (Alternative)-import Control.Monad.Compat (MonadPlus (..), ap)-import Data.Function--import Control.DeepSeq (NFData (..))--import Algebra.Graph.ToGraph (ToGraph, ToVertex, toGraph)--import qualified Algebra.Graph              as G-import qualified Algebra.Graph.AdjacencyMap as AM-import qualified Algebra.Graph.ToGraph      as T-import qualified Control.Applicative        as Ap-import qualified Data.Set                   as Set--{-| The 'Fold' data type is the Boehm-Berarducci encoding of the core graph-construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a-'Num' instance as a convenient notation for working with graphs:--    > 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:__ 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"-show (1         :: Fold Int) == "vertex 1"-show (1 + 2     :: Fold Int) == "vertices [1,2]"-show (1 * 2     :: Fold Int) == "edge 1 2"-show (1 * 2 * 3 :: Fold Int) == "edges [(1,2),(1,3),(2,3)]"-show (1 * 2 + 3 :: Fold Int) == "overlay (vertex 3) (edge 1 2)"@--The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the-/canonical graph representation/ and satisfies all axioms of algebraic graphs:--    * 'overlay' is commutative and associative:--        >       x + y == y + x-        > x + (y + z) == (x + y) + z--    * 'connect' is associative and has 'empty' as the identity:--        >   x * empty == x-        >   empty * x == x-        > x * (y * z) == (x * y) * z--    * 'connect' distributes over 'overlay':--        > x * (y + z) == x * y + x * z-        > (x + y) * z == x * z + y * z--    * 'connect' can be decomposed:--        > x * y * z == x * y + x * z + y * z--The following useful theorems can be proved from the above set of axioms.--    * 'overlay' has 'empty' as the identity and is idempotent:--        >   x + empty == x-        >   empty + x == x-        >       x + x == x--    * Absorption and saturation of 'connect':--        > x * y + x + y == x * y-        >     x * x * x == x * x--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-graph expression. For example, if g is a 'Fold' then /n/, /m/ and /s/ can be-computed as follows:--@n == 'vertexCount' g-m == 'edgeCount' g-s == 'size' g@--Note that 'size' counts all leaves of the expression:--@'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-    showsPrec p = showsPrec p . foldg AM.empty AM.vertex AM.overlay AM.connect--instance Ord a => Eq (Fold a) where-    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-    (*)         = connect-    signum      = const empty-    abs         = id-    negate      = id--instance Functor Fold where-    fmap f = foldg empty (vertex . f) overlay connect--instance Applicative Fold where-    pure  = vertex-    (<*>) = ap--instance Alternative Fold where-    empty = empty-    (<|>) = overlay--instance MonadPlus Fold where-    mzero = empty-    mplus = overlay--instance Monad Fold where-    return = vertex-    g >>=f = foldg empty f overlay connect g--instance ToGraph (Fold a) where-    type ToVertex (Fold a) = a-    foldg = foldg---- | Construct the /empty graph/.--- Complexity: /O(1)/ time, memory and size.------ @--- 'isEmpty'     empty == True--- 'hasVertex' x empty == False--- 'vertexCount' empty == 0--- 'edgeCount'   empty == 0--- 'size'        empty == 1--- @-empty :: Fold a-empty = Fold $ \e _ _ _ -> e-{-# NOINLINE [1] empty #-}---- | Construct the graph comprising /a single isolated vertex/.--- Complexity: /O(1)/ time, memory and size.------ @--- 'isEmpty'     (vertex x) == False--- 'hasVertex' x (vertex x) == True--- 'vertexCount' (vertex x) == 1--- 'edgeCount'   (vertex x) == 0--- 'size'        (vertex x) == 1--- @-vertex :: a -> Fold a-vertex x = Fold $ \_ v _ _ -> v x-{-# NOINLINE [1] vertex #-}---- | Construct the graph comprising /a single edge/.--- Complexity: /O(1)/ time, memory and size.------ @--- 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 :: a -> a -> Fold a-edge x y = Fold $ \_ v _ c -> v x `c` v y---- | /Overlay/ two graphs. This is a commutative, associative and idempotent--- operation with the identity 'empty'.--- 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--- '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--- 'size'        (overlay x y) == 'size' x        + 'size' y--- 'vertexCount' (overlay 1 2) == 2--- 'edgeCount'   (overlay 1 2) == 0--- @-overlay :: Fold a -> Fold a -> Fold a-overlay x y = Fold $ \e v o c -> runFold x e v o c `o` runFold y e v o c-{-# NOINLINE [1] overlay #-}---- | /Connect/ two graphs. This is an associative operation with the identity--- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.--- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number--- of edges in the resulting graph is quadratic with respect to the number of--- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.------ @--- 'isEmpty'     (connect 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--- 'size'        (connect x y) == 'size' x        + 'size' y--- 'vertexCount' (connect 1 2) == 2--- 'edgeCount'   (connect 1 2) == 1--- @-connect :: Fold a -> Fold a -> Fold a-connect x y = Fold $ \e v o c -> runFold x e v o c `c` runFold y e v o c-{-# NOINLINE [1] connect #-}---- | Construct the graph comprising a given list of isolated vertices.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- 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 :: [a] -> Fold a-vertices = overlays . map vertex-{-# NOINLINE [1] vertices #-}---- | Construct the graph from a list of edges.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- given list.------ @--- edges []          == 'empty'--- edges [(x,y)]     == 'edge' x y--- 'edgeCount' . edges == 'length' . 'Data.List.nub'--- @-edges :: [(a, a)] -> Fold a-edges es = Fold $ \e v o c -> foldr (flip o . uncurry (c `on` v)) e es---- | Overlay a given list of graphs.--- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length--- 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 :: [Fold a] -> Fold a-overlays = foldr overlay empty-{-# INLINE [2] overlays #-}---- | Connect a given list of graphs.--- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length--- of the given list, and /S/ is the sum of sizes of the graphs in the list.------ @--- connects []        == 'empty'--- connects [x]       == x--- connects [x,y]     == 'connect' x y--- connects           == 'foldr' 'connect' 'empty'--- 'isEmpty' . connects == 'all' 'isEmpty'--- @-connects :: [Fold a] -> Fold a-connects = foldr connect empty-{-# INLINE [2] connects #-}---- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying--- the provided functions to the leaves and internal nodes of the expression.--- The order of arguments is: empty, vertex, overlay and connect.--- Complexity: /O(s)/ applications of given functions. As an example, the--- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/.------ @--- foldg 'empty' 'vertex'        'overlay' 'connect'        == id--- 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---- | 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 x y                         ==> x <= y--- @-isSubgraphOf :: Ord a => Fold a -> Fold a -> Bool-isSubgraphOf x y = overlay x y == y---- | Check if a graph is empty. A convenient alias for 'null'.--- Complexity: /O(s)/ time.------ @--- isEmpty 'empty'                       == True--- isEmpty ('overlay' 'empty' 'empty')       == True--- isEmpty ('vertex' x)                  == False--- isEmpty ('removeVertex' x $ 'vertex' x) == True--- isEmpty ('removeEdge' x y $ 'edge' x y) == False--- @-isEmpty :: Fold a -> Bool-isEmpty = T.isEmpty---- | The /size/ of a graph, i.e. the number of leaves of the expression--- including 'empty' leaves.--- Complexity: /O(s)/ time.------ @--- size 'empty'         == 1--- size ('vertex' x)    == 1--- size ('overlay' x y) == size x + size y--- size ('connect' x y) == size x + size y--- size x             >= 1--- size x             >= 'vertexCount' x--- @-size :: Fold a -> Int-size = T.size---- | 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 -> Fold a -> Bool-hasVertex = T.hasVertex---- | 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' x y)       == True--- hasEdge x y . 'removeEdge' x y == 'const' False--- hasEdge x y                  == 'elem' (x,y) . 'edgeList'--- @-hasEdge :: Eq a => a -> a -> Fold a -> Bool-hasEdge = T.hasEdge---- | The number of vertices in a graph.--- Complexity: /O(s * log(n))/ time.------ @--- 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---- | The number of edges in a graph.--- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a--- graph can be quadratic with respect to the expression size /s/.------ @--- edgeCount 'empty'      == 0--- edgeCount ('vertex' x) == 0--- edgeCount ('edge' x y) == 1--- edgeCount            == 'length' . 'edgeList'--- @-edgeCount :: Ord a => Fold a -> Int-edgeCount = T.edgeCount---- | 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 => Fold a -> [a]-vertexList = T.vertexList---- | The sorted list of edges of a graph.--- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of--- edges /m/ of a graph can be quadratic with respect to the expression size /s/.------ @--- edgeList 'empty'          == []--- edgeList ('vertex' x)     == []--- edgeList ('edge' x y)     == [(x,y)]--- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)]--- edgeList . 'edges'        == 'Data.List.nub' . 'Data.List.sort'--- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList--- @-edgeList :: Ord a => Fold a -> [(a, a)]-edgeList = T.edgeList---- | 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 => Fold a -> Set.Set a-vertexSet = T.vertexSet---- | The set of edges of a given graph.--- Complexity: /O(s * log(m))/ time and /O(m)/ memory.------ @--- edgeSet 'empty'      == Set.'Set.empty'--- edgeSet ('vertex' x) == Set.'Set.empty'--- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)--- edgeSet . 'edges'    == Set.'Set.fromList'--- @-edgeSet :: Ord a => Fold a -> Set.Set (a, a)-edgeSet = T.edgeSet---- | The sorted /adjacency list/ of a graph.--- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a--- graph can be quadratic with respect to the expression size /s/.------ @--- adjacencyList 'empty'          == []--- adjacencyList ('vertex' x)     == [(x, [])]--- adjacencyList ('edge' 1 2)     == [(1, [2]), (2, [])]--- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]--- 'stars' . adjacencyList        == id--- @-adjacencyList :: Ord a => Fold a -> [(a, [a])]-adjacencyList = T.adjacencyList---- | The /path/ on a list of vertices.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- given list.------ @--- path []        == 'empty'--- path [x]       == 'vertex' x--- path [x,y]     == 'edge' x y--- path . 'reverse' == 'transpose' . path--- @-path :: [a] -> Fold a-path xs = case xs of []     -> empty-                     [x]    -> vertex x-                     (_:ys) -> edges (zip xs ys)---- | The /circuit/ on a list of vertices.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- given list.------ @--- circuit []        == 'empty'--- circuit [x]       == 'edge' x x--- circuit [x,y]     == 'edges' [(x,y), (y,x)]--- circuit . 'reverse' == 'transpose' . circuit--- @-circuit :: [a] -> Fold a-circuit []     = empty-circuit (x:xs) = path $ [x] ++ xs ++ [x]---- | The /clique/ on a list of vertices.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- given list.------ @--- clique []         == 'empty'--- clique [x]        == 'vertex' x--- clique [x,y]      == 'edge' x y--- clique [x,y,z]    == 'edges' [(x,y), (x,z), (y,z)]--- clique (xs ++ ys) == 'connect' (clique xs) (clique ys)--- clique . 'reverse'  == 'transpose' . clique--- @-clique :: [a] -> Fold a-clique = connects . map vertex-{-# NOINLINE [1] clique #-}---- | The /biclique/ on two lists of vertices.--- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the--- lengths of the given lists.------ @--- biclique []      []      == 'empty'--- biclique [x]     []      == 'vertex' x--- biclique []      [y]     == 'vertex' y--- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]--- biclique xs      ys      == 'connect' ('vertices' xs) ('vertices' ys)--- @-biclique :: [a] -> [a] -> Fold a-biclique xs [] = vertices xs-biclique [] ys = vertices ys-biclique xs ys = connect (vertices xs) (vertices ys)---- | The /star/ formed by a centre vertex connected to a list of leaves.--- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the--- given list.------ @--- star x []    == 'vertex' x--- star x [y]   == 'edge' x y--- star x [y,z] == 'edges' [(x,y), (x,z)]--- star x ys    == 'connect' ('vertex' x) ('vertices' ys)--- @-star :: a -> [a] -> Fold a-star x [] = vertex x-star x ys = connect (vertex x) (vertices ys)-{-# INLINE star #-}---- | The /stars/ formed by overlaying a list of 'star's. An inverse of--- 'adjacencyList'.--- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the--- input.------ @--- stars []                      == 'empty'--- stars [(x, [])]               == 'vertex' x--- stars [(x, [y])]              == 'edge' x y--- stars [(x, ys)]               == 'star' x ys--- stars                         == 'overlays' . 'map' ('uncurry' 'star')--- stars . 'adjacencyList'         == id--- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys)--- @-stars :: [(a, [a])] -> Fold a-stars = overlays . map (uncurry star)-{-# INLINE stars #-}---- | Remove a vertex from a given graph.--- Complexity: /O(s)/ time, memory and size.------ @--- removeVertex x ('vertex' x)       == 'empty'--- removeVertex 1 ('vertex' 2)       == 'vertex' 2--- removeVertex x ('edge' x x)       == 'empty'--- removeVertex 1 ('edge' 1 2)       == 'vertex' 2--- removeVertex x . removeVertex x == removeVertex x--- @-removeVertex :: Eq a => a -> Fold a -> Fold a-removeVertex v = induce (/= v)---- | Remove an edge from a given graph.--- Complexity: /O(s)/ time, memory and size.------ @--- removeEdge x y ('edge' x y)       == 'vertices' [x,y]--- removeEdge x y . removeEdge x y == removeEdge x y--- removeEdge x y . 'removeVertex' x == 'removeVertex' x--- removeEdge 1 1 (1 * 1 * 2 * 2)  == 1 * 2 * 2--- removeEdge 1 2 (1 * 1 * 2 * 2)  == 1 * 1 + 2 * 2--- 'size' (removeEdge x y z)         <= 3 * 'size' z--- @-removeEdge :: Eq a => a -> a -> Fold a -> Fold a-removeEdge s t = filterContext s (/=s) (/=t)---- TODO: Export--- 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)---- | Transpose a given graph.--- Complexity: /O(s)/ time, memory and size.------ @--- transpose 'empty'       == 'empty'--- transpose ('vertex' x)  == 'vertex' x--- 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'--- @-transpose :: Fold a -> Fold a-transpose = foldg empty vertex overlay (flip connect)-{-# NOINLINE [1] transpose #-}--{-# RULES-"transpose/empty"    transpose empty = empty-"transpose/vertex"   forall x. transpose (vertex x) = vertex x-"transpose/overlay"  forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2)-"transpose/connect"  forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1)--"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs)-"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs))--"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs-"transpose/clique"   forall xs. transpose (clique xs)   = clique (reverse xs)- #-}---- | Construct the /induced subgraph/ of a given graph by removing the--- vertices that do not satisfy a given predicate.--- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes--- /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) -> Fold a -> Fold a-induce p = foldg empty (\x -> if p x then vertex x else empty) (k overlay) (k connect)-  where-    k f x y | isEmpty x = y -- Constant folding to get rid of Empty leaves-            | isEmpty y = x-            | otherwise = f x y---- | Simplify a graph expression. Semantically, this is the identity function,--- but it simplifies a given polymorphic graph expression according to the laws--- of the algebra. The function does not compute the simplest possible expression,--- but uses heuristics to obtain useful simplifications in reasonable time.--- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed--- that the size of the result does not exceed the size of the given expression.--- Below the operator @~>@ denotes the /is simplified to/ relation.------ @--- simplify             == id--- 'size' (simplify x)    <= 'size' x--- simplify 'empty'       ~> 'empty'--- simplify 1           ~> 1--- simplify (1 + 1)     ~> 1--- simplify (1 + 2 + 1) ~> 1 + 2--- simplify (1 * 1 * 1) ~> 1 * 1--- @-simplify :: Ord a => Fold a -> Fold a-simplify = foldg empty vertex (simple overlay) (simple connect)--simple :: Eq g => (g -> g -> g) -> g -> g -> g-simple op x y-    | x == z    = x-    | y == z    = y-    | otherwise = z-  where-    z = op x y

@@ -1,8 +1,7 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.HigherKinded.Class--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -53,15 +52,11 @@     removeVertex, replaceVertex, mergeVertices, splitVertex, induce     ) where -import Prelude ()-import Prelude.Compat- import Control.Applicative (Alternative(empty, (<|>)))-import Control.Monad.Compat (MonadPlus, mfilter)+import Control.Monad (MonadPlus, mfilter) import Data.Tree -import qualified Algebra.Graph      as G-import qualified Algebra.Graph.Fold as F+import qualified Algebra.Graph as G  {-| The core type class for constructing algebraic graphs is defined by introducing@@ -122,19 +117,12 @@ edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' expression. -}-class (-#if !MIN_VERSION_base(4,8,0)-  Alternative g,-#endif-  MonadPlus g) => Graph g where+class MonadPlus g => Graph g where     -- | Connect two graphs.     connect :: g a -> g a -> g a  instance Graph G.Graph where     connect = G.connect--instance Graph F.Fold where-    connect = F.connect  -- | Construct the graph comprising a single isolated vertex. An alias for 'pure'. vertex :: Graph g => a -> g a

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Internal--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2020 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -20,31 +20,32 @@     List (..),      -- * Graph traversal-    Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, Hit (..),-    foldr1Safe, maybeF,+    Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, foldr1Safe,+    maybeF,      -- * Utilities-    setProduct, setProductWith-  ) where--import Prelude ()-import Prelude.Compat+    setProduct, setProductWith, forEach, forEachInt, coerce00, coerce10,+    coerce20, coerce01, coerce11, coerce21+    ) where +import Data.Coerce import Data.Foldable import Data.Semigroup+import Data.IntSet (IntSet) import Data.Set (Set) +import qualified Data.IntSet as IntSet import qualified Data.Set as Set import qualified GHC.Exts as Exts  -- | An abstract list data type with /O(1)/ time concatenation (the current -- implementation uses difference lists). Here @a@ is the type of list elements. -- 'List' @a@ is a 'Monoid': 'mempty' corresponds to the empty list and two lists--- can be concatenated with 'mappend' (or operator 'Data.Monoid.<>'). Singleton+-- can be concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Singleton -- lists can be constructed using the function 'pure' from the 'Applicative' -- instance. 'List' @a@ is also an instance of 'IsList', therefore you can use -- list literals, e.g. @[1,4]@ @::@ 'List' @Int@ is the same as 'pure' @1@--- 'Data.Monoid.<>' 'pure' @4@; note that this requires the @OverloadedLists@+-- 'Data.Semigroup.<>' 'pure' @4@; note that this requires the @OverloadedLists@ -- GHC extension. To extract plain Haskell lists you can use the 'toList' -- function from the 'Foldable' instance. newtype List a = List (Endo [a]) deriving (Monoid, Semigroup)@@ -66,9 +67,7 @@  instance Foldable List where     foldMap f = foldMap f . Exts.toList-#if MIN_VERSION_base(4,8,0)     toList    = Exts.toList-#endif  instance Functor List where     fmap f = Exts.fromList . map f . toList@@ -110,21 +109,10 @@     xs = if ok y then vs x else is x     ys = if ok x then vs y else os y --- | An auxiliary data type for 'hasEdge': when searching for an edge, we can hit--- its 'Tail', i.e. the source vertex, the whole 'Edge', or 'Miss' it entirely.-data Hit = Miss | Tail | Edge deriving (Eq, Ord)- -- | A safe version of 'foldr1'. foldr1Safe :: (a -> a -> a) -> [a] -> Maybe a 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- #-}+{-# INLINE foldr1Safe #-}  -- | 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.@@ -144,3 +132,40 @@ -- 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 ]++-- | Perform an applicative action for each member of a Set.+forEach :: Applicative f => Set a -> (a -> f b) -> f ()+forEach s f = Set.foldr (\a u -> f a *> u) (pure ()) s++-- | Perform an applicative action for each member of an IntSet.+forEachInt :: Applicative f => IntSet -> (Int -> f a) -> f ()+forEachInt s f = IntSet.foldr (\a u -> f a *> u) (pure ()) s++-- TODO: Get rid of this boilerplate.++-- | Help GHC with type inference when direct use of 'coerce' does not compile.+coerce00 :: Coercible f g => f x -> g x+coerce00 = coerce++-- | Help GHC with type inference when direct use of 'coerce' does not compile.+coerce10 :: (Coercible a b, Coercible f g) => (a -> f x) -> (b -> g x)+coerce10 = coerce++-- | Help GHC with type inference when direct use of 'coerce' does not compile.+coerce20 :: (Coercible a b, Coercible c d, Coercible f g)+         => (a -> c -> f x) -> (b -> d -> g x)+coerce20 = coerce++-- | Help GHC with type inference when direct use of 'coerce' does not compile.+coerce01 :: (Coercible a b, Coercible f g) => (f x -> a) -> (g x -> b)+coerce01 = coerce++-- | Help GHC with type inference when direct use of 'coerce' does not compile.+coerce11 :: (Coercible a b, Coercible c d, Coercible f g)+         => (a -> f x -> c) -> (b -> g x -> d)+coerce11 = coerce++-- | Help GHC with type inference when direct use of 'coerce' does not compile.+coerce21 :: (Coercible a b, Coercible c d, Coercible p q, Coercible f g)+         => (a -> c -> f x -> p) -> (b -> d -> g x -> q)+coerce21 = coerce

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Label--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -29,14 +29,12 @@     Optimum (..), ShortestPath, AllShortestPaths, CountShortestPaths, WidestPath     ) where -import Prelude ()-import Prelude.Compat- import Control.Applicative import Control.Monad+import Data.Coerce import Data.Maybe import Data.Monoid (Any (..), Monoid (..), Sum (..))-import Data.Semigroup (Min (..), Max (..), Semigroup (..))+import Data.Semigroup (Max (..), Min (..), Semigroup (..)) import Data.Set (Set) import GHC.Exts (IsList (..)) @@ -135,8 +133,8 @@       where         f = fromInteger x -    (+) = liftA2 (+)-    (*) = liftA2 (*)+    (+) = coerce ((+) :: Extended a -> Extended a -> Extended a)+    (*) = coerce ((*) :: Extended a -> Extended a -> Extended a)      negate _ = error "NonNegative values cannot be negated" @@ -284,12 +282,16 @@ fromExtended (Finite a) = Just a fromExtended Infinite   = Nothing -instance Num a => Num (Extended a) where+-- A type alias for a binary function on Extended.+instance (Num a, Eq a) => Num (Extended a) where     fromInteger = Finite . fromInteger      (+) = liftA2 (+)-    (*) = liftA2 (*) +    Finite 0 * _ = Finite 0+    _ * Finite 0 = Finite 0+    x * y = liftA2 (*) x y+     negate = fmap negate     signum = fmap signum     abs    = fmap abs@@ -297,8 +299,8 @@ -- | If @a@ is a monoid, 'Minimum' @a@ forms the following 'Dioid': -- -- @--- 'zero'  = 'pure' 'mempty'--- 'one'   = 'noMinimum'+-- 'zero'  = 'noMinimum'+-- 'one'   = 'pure' 'mempty' -- ('<+>') = 'liftA2' 'min' -- ('<.>') = 'liftA2' 'mappend' -- @@@ -323,18 +325,19 @@ noMinimum = Minimum Infinite  instance Ord a => Semigroup (Minimum a) where-    (<>) = liftA2 min+    (<>) = min  instance (Monoid a, Ord a) => Monoid (Minimum a) where-    mempty = pure mempty +    mempty  = noMinimum+    mappend = (<>)  instance (Monoid a, Ord a) => Semiring (Minimum a) where-    one = noMinimum+    one   = pure mempty     (<.>) = liftA2 mappend  instance (Monoid a, Ord a) => Dioid (Minimum a) -instance (Num a, Show a) => Show (Minimum a) where+instance Show a => Show (Minimum a) where     show (Minimum Infinite  ) = "one"     show (Minimum (Finite x)) = show x @@ -361,9 +364,6 @@     one                       = PowerSet (Set.singleton mempty)     PowerSet x <.> PowerSet y = PowerSet (setProductWith mappend x y) -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@@ -445,6 +445,7 @@ data Optimum o a = Optimum { getOptimum :: o, getArgument :: a }     deriving (Eq, Ord, Show) +-- TODO: Add tests. -- 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@@ -455,32 +456,40 @@               o = mappend o1 o2               a = if o == o1 then a1 else a2 +-- TODO: Add tests. instance (Eq o, Monoid a, Monoid o) => Monoid (Optimum o a) where     mempty  = Optimum mempty mempty     mappend = (<>) +-- TODO: Add tests. 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) +-- TODO: Add tests. instance (Eq o, StarSemiring a, StarSemiring o) => StarSemiring (Optimum o a) where     star (Optimum o a) = Optimum (star o) (star a) +-- TODO: Add tests. 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/.+-- TODO: Add tests.+-- | The 'Optimum' semiring specialised to+-- /finding the lexicographically smallest shortest path/. type ShortestPath e a = Optimum (Distance e) (Minimum (Path a)) +-- TODO: Add tests. -- | The 'Optimum' semiring specialised to /finding all shortest paths/. type AllShortestPaths e a = Optimum (Distance e) (PowerSet (Path a)) +-- TODO: Add tests. -- | The 'Optimum' semiring specialised to /counting all shortest paths/.-type CountShortestPaths e a = Optimum (Distance e) (Count Integer)+type CountShortestPaths e = Optimum (Distance e) (Count Integer) --- | The 'Optimum' semiring specialised to /finding the lexicographically--- smallest widest path/.+-- TODO: Add tests.+-- | The 'Optimum' semiring specialised to+-- /finding the lexicographically smallest widest path/. type WidestPath e a = Optimum (Capacity e) (Minimum (Path a))

@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveFunctor, FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Labelled--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -15,7 +15,7 @@ -- graphs with edge labels. The API will be expanded in the next release. ----------------------------------------------------------------------------- module Algebra.Graph.Labelled (-    -- * Algebraic data type for edge-labeleld graphs+    -- * Algebraic data type for edge-labelled graphs     Graph (..), empty, vertex, edge, (-<), (>-), overlay, connect, vertices,     edges, overlays, @@ -31,7 +31,7 @@      -- * Graph transformation     removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, emap,-    induce,+    induce, induceJust,      -- * Relational operations     closure, reflexiveClosure, symmetricClosure, transitiveClosure,@@ -43,12 +43,10 @@     Context (..), context     ) where -import Prelude ()-import Prelude.Compat- import Data.Bifunctor-import Data.Monoid (Any (..))-import Data.Semigroup ((<>))+import Data.Monoid+import Control.DeepSeq+import GHC.Generics  import Algebra.Graph.Internal (List (..)) import Algebra.Graph.Label@@ -65,7 +63,7 @@ data Graph e a = Empty                | Vertex a                | Connect e (Graph e a) (Graph e a)-               deriving (Functor, Show)+               deriving (Functor, Show, Generic)  instance (Eq e, Monoid e, Ord a) => Eq (Graph e a) where     x == y = toAdjacencyMap x == toAdjacencyMap y@@ -86,6 +84,11 @@ instance Bifunctor Graph where   bimap f g = foldg Empty (Vertex . g) (Connect . f) +instance (NFData e, NFData a) => NFData (Graph e a) where+    rnf Empty           = ()+    rnf (Vertex  x    ) = rnf x+    rnf (Connect e x y) = e `seq` rnf x `seq` rnf y+ -- TODO: This is a very inefficient implementation. Find a way to construct an -- adjacency map directly, without building intermediate representations for all -- subgraphs.@@ -153,7 +156,7 @@ -- -- @ -- 'isEmpty'     (vertex x) == False--- 'hasVertex' x (vertex x) == True+-- 'hasVertex' x (vertex y) == (x == y) -- 'Algebra.Graph.ToGraph.vertexCount' (vertex x) == 1 -- 'Algebra.Graph.ToGraph.edgeCount'   (vertex x) == 0 -- @@@ -286,7 +289,7 @@ overlays :: Monoid e => [Graph e a] -> Graph e a overlays = foldr overlay empty --- | Check if a graph is empty. A convenient alias for 'null'.+-- | Check if a graph is empty. -- Complexity: /O(s)/ time. -- -- @@@ -319,8 +322,7 @@ -- -- @ -- hasVertex x 'empty'            == False--- hasVertex x ('vertex' x)       == True--- hasVertex 1 ('vertex' 2)       == False+-- hasVertex x ('vertex' y)       == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Eq a => a -> Graph e a -> Bool@@ -488,6 +490,7 @@ emap :: (e -> f) -> Graph e a -> Graph f a emap f = foldg Empty Vertex (Connect . f) +-- TODO: Implement via 'induceJust' to reduce code duplication. -- | 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@@ -502,6 +505,23 @@ -- @ 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++-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- induceJust ('vertex' 'Nothing')                               == 'empty'+-- induceJust ('edge' ('Just' x) 'Nothing')                        == 'vertex' x+-- induceJust . 'fmap' 'Just'                                    == 'id'+-- induceJust . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p+-- @+induceJust :: Graph e (Maybe a) -> Graph e a+induceJust = foldg Empty (maybe Empty Vertex) c   where     c _ x     Empty = x -- Constant folding to get rid of Empty leaves     c _ Empty y     = y

@@ -1,7 +1,8 @@+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Labelled.AdjacencyMap--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -32,29 +33,83 @@      -- * Graph transformation     removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap,-    emap, induce,+    emap, induce, induceJust,      -- * Relational operations-    closure, reflexiveClosure, symmetricClosure, transitiveClosure-  ) where+    closure, reflexiveClosure, symmetricClosure, transitiveClosure, -import Prelude ()-import Prelude.Compat+    -- * Miscellaneous+    consistent+    ) where -import Data.Foldable (foldMap)+import Control.DeepSeq import Data.Maybe import Data.Map (Map)-import Data.Monoid (Monoid, Sum (..))-import Data.Set (Set)+import Data.Monoid (Sum (..))+import Data.Set (Set, (\\))+import GHC.Generics  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+import qualified Algebra.Graph.AdjacencyMap as AM+import qualified Data.Map.Strict            as Map+import qualified Data.Set                   as Set +-- | 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, Generic, NFData)++instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where+    showsPrec p lam@(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   = vertexSet lam+        es   = edgeList lam+        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 x y = mconcat+        [ compare (vertexCount x) (vertexCount y)+        , compare (vertexSet   x) (vertexSet   y)+        , compare (edgeCount   x) (edgeCount   y)+        , compare (eSet        x) (eSet        y)+        , cmp ]+      where+        eSet = Set.map (\(_, x, y) -> (x, y)) . edgeSet+        cmp | x == y               = EQ+            | overlays [x, y] == y = LT+            | otherwise            = compare x y++-- | __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 = vertex . fromInteger+    (+)         = overlay+    (*)         = connect mempty+    signum      = const empty+    abs         = id+    negate      = id+ -- | Construct the /empty graph/. -- Complexity: /O(1)/ time and memory. --@@ -72,7 +127,7 @@ -- -- @ -- 'isEmpty'     (vertex x) == False--- 'hasVertex' x (vertex x) == True+-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount'   (vertex x) == 0 -- @@@ -268,8 +323,7 @@ -- -- @ -- hasVertex x 'empty'            == False--- hasVertex x ('vertex' x)       == True--- hasVertex 1 ('vertex' 2)       == False+-- hasVertex x ('vertex' y)       == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap e a -> Bool@@ -395,14 +449,16 @@ postSet :: Ord a => a -> AdjacencyMap e a -> Set a postSet x = Map.keysSet . Map.findWithDefault Map.empty x . adjacencyMap +-- TODO: Optimise. -- | Convert a graph to the corresponding unlabelled 'AM.AdjacencyMap' by -- forgetting labels on all non-'zero' edges.+-- Complexity: /O((n + m) * log(n))/ time and memory. -- -- @ -- '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)+skeleton :: Ord a => AdjacencyMap e a -> AM.AdjacencyMap a+skeleton (AM m) = AM.fromAdjacencySets $ Map.toAscList $ Map.map Map.keysSet m  -- | Remove a vertex from a given graph. -- Complexity: /O(n*log(n))/ time.@@ -528,7 +584,7 @@  -- | 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+-- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to -- be evaluated. -- -- @@@ -542,6 +598,21 @@ induce p = AM . Map.map (Map.filterWithKey (\k _ -> p k)) .     Map.filterWithKey (\k _ -> p k) . adjacencyMap +-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'.+-- Complexity: /O(n + m)/ time.+--+-- @+-- induceJust ('vertex' 'Nothing')                               == 'empty'+-- induceJust ('edge' ('Just' x) 'Nothing')                        == 'vertex' x+-- induceJust . 'gmap' 'Just'                                    == 'id'+-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p+-- @+induceJust :: Ord a => AdjacencyMap e (Maybe a) -> AdjacencyMap e a+induceJust = AM . Map.map catMaybesMap . catMaybesMap . adjacencyMap+  where+    catMaybesMap = Map.mapKeysMonotonic fromJust . Map.delete Nothing+ -- | Compute the /reflexive and transitive closure/ of a graph over the -- underlying star semiring using the Warshall-Floyd-Kleene algorithm. --@@ -610,3 +681,16 @@         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 ]++-- | Check that 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.+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 ]

@@ -1,115 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- 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 GHC.Generics--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, Generic, 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 ]

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedLists, TypeFamilies #-}+{-# LANGUAGE OverloadedLists, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Labelled.Example.Automaton@@ -24,17 +24,6 @@ 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

@@ -1,8 +1,8 @@-{-# LANGUAGE CPP, DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.NonEmpty--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -47,17 +47,13 @@      -- * Graph transformation     removeVertex1, removeEdge, replaceVertex, mergeVertices, splitVertex1,-    transpose, induce1, simplify, sparsify, sparsifyKL,+    transpose, induce1, induceJust1, simplify, sparsify, sparsifyKL,      -- * Graph composition     box     ) where -import Prelude ()-import Prelude.Compat- import Control.DeepSeq-import Control.Monad.Compat import Control.Monad.State import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup ((<>))@@ -244,7 +240,7 @@ -- Complexity: /O(1)/ time, memory and size. -- -- @--- 'hasVertex' x (vertex x) == True+-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount'   (vertex x) == 0 -- 'size'        (vertex x) == 1@@ -339,6 +335,7 @@ -- -- @ -- edges1 [(x,y)]     == 'edge' x y+-- edges1             == 'overlays1' . 'fmap' ('uncurry' 'edge') -- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @ edges1 :: NonEmpty (a, a) -> Graph a@@ -446,14 +443,13 @@ -- Complexity: /O(s)/ time. -- -- @--- hasVertex x ('vertex' x) == True--- hasVertex 1 ('vertex' 2) == False+-- hasVertex x ('vertex' y) == (x == y) -- @ 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'.+-- See the Note [The implementation of hasEdge] in "Algebra.Graph". -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. --@@ -464,17 +460,15 @@ -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Eq a => a -> a -> Graph a -> Bool-hasEdge s t g = hit g == Edge+hasEdge s t g = foldg1 v o c g 0 == 2   where-    hit (Vertex x   ) = if x == s then Tail else Miss-    hit (Overlay x y) = case hit x of-        Miss -> hit y-        Tail -> max Tail (hit y)-        Edge -> Edge-    hit (Connect x y) = case hit x of-        Miss -> hit y-        Tail -> if hasVertex t y then Edge else Tail-        Edge -> Edge+    v x 0   = if x == s then 1 else 0+    v x _   = if x == t then 2 else 1+    o x y a = case x a of+        0 -> y a+        1 -> if y a == 2 then 2 else 1+        _ -> 2 :: Int+    c x y a = case x a of { 2 -> 2; res -> y res } {-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-}  -- | The number of vertices in a graph.@@ -829,6 +823,7 @@ "transpose/clique1"   forall xs. transpose (clique1 xs) = clique1 (NonEmpty.reverse xs)  #-} +-- TODO: Implement via 'induceJust1' to reduce code duplication. -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. Returns @Nothing@ if the -- resulting graph is empty.@@ -843,13 +838,28 @@ -- @ induce1 :: (a -> Bool) -> Graph a -> Maybe (Graph a) induce1 p = foldg1-  (\x -> if p x then Just (Vertex x) else Nothing)-  (k Overlay)-  (k Connect)+    (\x -> if p x then Just (Vertex x) else Nothing) (k Overlay) (k Connect)   where-    k _ Nothing a = a-    k _ a Nothing = a-    k f (Just a) (Just b) = Just $ f a b+    k _ Nothing  a        = a+    k _ a        Nothing  = a+    k f (Just a) (Just b) = Just (f a b)++-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'. Returns 'Nothing' if the resulting graph is empty.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- induceJust1 ('vertex' 'Nothing')                               == 'Nothing'+-- induceJust1 ('edge' ('Just' x) 'Nothing')                        == 'Just' ('vertex' x)+-- induceJust1 . 'fmap' 'Just'                                    == 'Just'+-- induceJust1 . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce1' p+-- @+induceJust1 :: Graph (Maybe a) -> Maybe (Graph a)+induceJust1 = foldg1 (fmap Vertex) (k Overlay) (k Connect)+  where+    k _ Nothing  a        = a+    k _ a        Nothing  = a+    k f (Just a) (Just b) = Just (f a b)  -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra.

@@ -1,7 +1,8 @@+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.NonEmpty.AdjacencyMap--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -24,7 +25,7 @@ ----------------------------------------------------------------------------- module Algebra.Graph.NonEmpty.AdjacencyMap (     -- * Data structure-    AdjacencyMap, toNonEmpty,+    AdjacencyMap, toNonEmpty, fromNonEmpty,      -- * Basic graph construction primitives     vertex, edge, overlay, connect, vertices1, edges1, overlays1, connects1,@@ -41,38 +42,142 @@      -- * Graph transformation     removeVertex1, removeEdge, replaceVertex, mergeVertices, transpose, gmap,-    induce1,+    induce1, induceJust1,      -- * Graph closure-    closure, reflexiveClosure, symmetricClosure, transitiveClosure+    closure, reflexiveClosure, symmetricClosure, transitiveClosure,++    -- * Miscellaneous+    consistent     ) where  import Prelude hiding (reverse)+import Control.DeepSeq+import Data.Coerce+import Data.List ((\\)) 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 GHC.Generics  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+{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to+their adjacency sets. We define a 'Num' instance as a convenient notation for+working with graphs: --- 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)+    > 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)) --- 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+__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 'Show' instance is defined using basic graph construction primitives:++@show (1         :: AdjacencyMap Int) == "vertex 1"+show (1 + 2     :: AdjacencyMap Int) == "vertices1 [1,2]"+show (1 * 2     :: AdjacencyMap Int) == "edge 1 2"+show (1 * 2 * 3 :: AdjacencyMap Int) == "edges1 [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@++The 'Eq' instance satisfies the following laws of algebraic graphs:++    * 'overlay' is commutative, associative and idempotent:++        >       x + y == y + x+        > x + (y + z) == (x + y) + z+        >       x + x == x++    * 'connect' is associative:++        > x * (y * z) == (x * y) * z++    * 'connect' distributes over 'overlay':++        > x * (y + z) == x * y + x * z+        > (x + y) * z == x * z + y * z++    * 'connect' can be decomposed:++        > x * y * z == x * y + x * z + y * z++    * 'connect' satisfies absorption and saturation:++        > x * y + x + y == x * y+        >     x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ and /m/+will denote the number of vertices and edges in the graph, respectively.++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@++@x     <= x + y+x + y <= x * y@+-}+newtype AdjacencyMap a = NAM { am :: AM.AdjacencyMap a }+    deriving (Eq, Generic, NFData, Ord)++-- | __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      = error "NonEmpty.AdjacencyMap.signum cannot be implemented."+    abs         = id+    negate      = id++instance (Ord a, Show a) => Show (AdjacencyMap a) where+    showsPrec p nam+        | null vs    = error "NonEmpty.AdjacencyMap.Show: Graph is 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             = toList (vertexList1 nam)+        es             = edgeList nam+        vshow [x]      = showString "vertex "    . showsPrec 11 x+        vshow xs       = showString "vertices1 " . showsPrec 11 xs+        eshow [(x, y)] = showString "edge "      . showsPrec 11 x .+                         showString " "          . showsPrec 11 y+        eshow xs       = showString "edges1 "    . showsPrec 11 xs+        used           = Set.toAscList $ Set.fromList $ uncurry (++) $ unzip es+ -- Unsafe creation of a NonEmpty list. unsafeNonEmpty :: [a] -> NonEmpty a unsafeNonEmpty = fromMaybe (error msg) . nonEmpty@@ -84,23 +189,34 @@ -- Complexity: /O(1)/ time, memory and size. -- -- @--- toNonEmpty 'AM.empty'              == Nothing--- toNonEmpty ('Algebra.Graph.ToGraph.toAdjacencyMap' x) == Just (x :: 'AdjacencyMap' a)+-- toNonEmpty 'AM.empty'          == 'Nothing'+-- toNonEmpty . 'fromNonEmpty' == 'Just' -- @ toNonEmpty :: AM.AdjacencyMap a -> Maybe (AdjacencyMap a) toNonEmpty x | AM.isEmpty x = Nothing              | otherwise    = Just (NAM x) +-- | Convert a NonEmpty.'AdjacencyMap' into an 'AM.AdjacencyMap'. The resulting+-- graph is guaranteed to be non-empty.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- 'isEmpty' . fromNonEmpty    == 'const' 'False'+-- 'toNonEmpty' . fromNonEmpty == 'Just'+-- @+fromNonEmpty :: AdjacencyMap a -> AM.AdjacencyMap a+fromNonEmpty = am+ -- | 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+-- 'hasVertex' x (vertex y) == (x == y)+-- 'vertexCount' (vertex x) == 1+-- 'edgeCount'   (vertex x) == 0 -- @ vertex :: a -> AdjacencyMap a-vertex = NAM . AM.vertex+vertex = coerce AM.vertex {-# NOINLINE [1] vertex #-}  -- | /Overlay/ two graphs. This is a commutative, associative and idempotent@@ -117,7 +233,7 @@ -- 'edgeCount'   (overlay 1 2) == 0 -- @ overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a-overlay = via2 AM.overlay+overlay = coerce AM.overlay {-# NOINLINE [1] overlay #-}  -- | /Connect/ two graphs. This is an associative operation with the identity@@ -138,7 +254,7 @@ -- 'edgeCount'   (connect 1 2) == 1 -- @ connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a-connect = via2 AM.connect+connect = coerce AM.connect {-# NOINLINE [1] connect #-}  -- | Construct the graph comprising /a single edge/.@@ -152,7 +268,7 @@ -- 'vertexCount' (edge 1 2) == 2 -- @ edge :: Ord a => a -> a -> AdjacencyMap a-edge x y = NAM (AM.edge x y)+edge = coerce AM.edge  -- | 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@@ -165,7 +281,7 @@ -- 'vertexSet'   . vertices1 == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @ vertices1 :: Ord a => NonEmpty a -> AdjacencyMap a-vertices1 = NAM . AM.vertices . toList+vertices1 = coerce AM.vertices . toList {-# NOINLINE [1] vertices1 #-}  -- | Construct the graph from a list of edges.@@ -173,10 +289,11 @@ -- -- @ -- edges1 [(x,y)]     == 'edge' x y+-- edges1             == 'overlays1' . 'fmap' ('uncurry' 'edge') -- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @ edges1 :: Ord a => NonEmpty (a, a) -> AdjacencyMap a-edges1 = NAM . AM.edges . toList+edges1 = coerce AM.edges . toList  -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.@@ -186,7 +303,7 @@ -- overlays1 [x,y] == 'overlay' x y -- @ overlays1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a-overlays1 = viaL AM.overlays+overlays1 = coerce AM.overlays . toList {-# NOINLINE overlays1 #-}  -- | Connect a given list of graphs.@@ -197,7 +314,7 @@ -- connects1 [x,y] == 'connect' x y -- @ connects1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a-connects1 = viaL AM.connects+connects1 = coerce AM.connects . toList {-# NOINLINE connects1 #-}  -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the@@ -211,17 +328,16 @@ -- isSubgraphOf x y                         ==> x <= y -- @ isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool-isSubgraphOf (NAM x) (NAM y) = AM.isSubgraphOf x y+isSubgraphOf = coerce AM.isSubgraphOf  -- | Check if a graph contains a given vertex. -- Complexity: /O(log(n))/ time. -- -- @--- hasVertex x ('vertex' x) == True--- hasVertex 1 ('vertex' 2) == False+-- hasVertex x ('vertex' y) == (x == y) -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool-hasVertex x = AM.hasVertex x . am+hasVertex = coerce AM.hasVertex  -- | Check if a graph contains a given edge. -- Complexity: /O(log(n))/ time.@@ -233,7 +349,7 @@ -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool-hasEdge x y = AM.hasEdge x y . am+hasEdge = coerce AM.hasEdge  -- | The number of vertices in a graph. -- Complexity: /O(1)/ time.@@ -244,7 +360,7 @@ -- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: AdjacencyMap a -> Int-vertexCount = AM.vertexCount . am+vertexCount = coerce AM.vertexCount  -- | The number of edges in a graph. -- Complexity: /O(n)/ time.@@ -255,7 +371,7 @@ -- edgeCount            == 'length' . 'edgeList' -- @ edgeCount :: AdjacencyMap a -> Int-edgeCount = AM.edgeCount . am+edgeCount = coerce AM.edgeCount  -- | The sorted list of vertices of a given graph. -- Complexity: /O(n)/ time and memory.@@ -265,7 +381,7 @@ -- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' -- @ vertexList1 :: AdjacencyMap a -> NonEmpty a-vertexList1 = unsafeNonEmpty . AM.vertexList . am+vertexList1 = unsafeNonEmpty . coerce AM.vertexList  -- | The sorted list of edges of a graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory.@@ -278,7 +394,7 @@ -- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyMap a -> [(a, a)]-edgeList = AM.edgeList . am+edgeList = coerce AM.edgeList  -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory.@@ -289,7 +405,7 @@ -- vertexSet . 'clique1'   == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @ vertexSet :: AdjacencyMap a -> Set a-vertexSet = AM.vertexSet . am+vertexSet = coerce AM.vertexSet  -- | The set of edges of a given graph. -- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.@@ -300,7 +416,7 @@ -- edgeSet . 'edges'    == Set.'Set.fromList' -- @ edgeSet :: Ord a => AdjacencyMap a -> Set (a, a)-edgeSet = Set.fromAscList . edgeList+edgeSet = coerce AM.edgeSet  -- | The /preset/ of an element @x@ is the set of its /direct predecessors/. -- Complexity: /O(n * log(n))/ time and /O(n)/ memory.@@ -311,7 +427,7 @@ -- preSet y ('edge' x y) == Set.'Set.fromList' [x] -- @ preSet :: Ord a => a -> AdjacencyMap a -> Set.Set a-preSet x = AM.preSet x . am+preSet = coerce AM.preSet  -- | The /postset/ of a vertex is the set of its /direct successors/. -- Complexity: /O(log(n))/ time and /O(1)/ memory.@@ -322,7 +438,7 @@ -- postSet 2 ('edge' 1 2) == Set.'Set.empty' -- @ postSet :: Ord a => a -> AdjacencyMap a -> Set a-postSet x = AM.postSet x . am+postSet = coerce AM.postSet  -- | The /path/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.@@ -333,7 +449,7 @@ -- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 -- @ path1 :: Ord a => NonEmpty a -> AdjacencyMap a-path1 = NAM . AM.path . toList+path1 = coerce AM.path . toList  -- | The /circuit/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.@@ -344,7 +460,7 @@ -- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 -- @ circuit1 :: Ord a => NonEmpty a -> AdjacencyMap a-circuit1 = NAM . AM.circuit . toList+circuit1 = coerce AM.circuit . toList  -- | The /clique/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.@@ -357,7 +473,7 @@ -- clique1 . 'Data.List.NonEmpty.reverse'  == 'transpose' . clique1 -- @ clique1 :: Ord a => NonEmpty a -> AdjacencyMap a-clique1 = NAM . AM.clique . toList+clique1 = coerce AM.clique . toList {-# NOINLINE [1] clique1 #-}  -- | The /biclique/ on two lists of vertices.@@ -368,7 +484,7 @@ -- 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)+biclique1 xs ys = coerce AM.biclique (toList xs) (toList ys)  -- TODO: Optimise. -- | The /star/ formed by a centre vertex connected to a list of leaves.@@ -380,7 +496,7 @@ -- star x [y,z] == 'edges1' [(x,y), (x,z)] -- @ star :: Ord a => a -> [a] -> AdjacencyMap a-star x = NAM . AM.star x+star = coerce AM.star {-# INLINE star #-}  -- | The /stars/ formed by overlaying a list of 'star's. An inverse of@@ -396,7 +512,7 @@ -- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs '<>' ys) -- @ stars1 :: Ord a => NonEmpty (a, [a]) -> AdjacencyMap a-stars1 = NAM . AM.stars . toList+stars1 = coerce 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.@@ -408,7 +524,7 @@ -- 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+tree = coerce AM.tree  -- | Remove a vertex from a given graph. -- Complexity: /O(n*log(n))/ time.@@ -421,7 +537,7 @@ -- removeVertex1 x 'Control.Monad.>=>' removeVertex1 x == removeVertex1 x -- @ removeVertex1 :: Ord a => a -> AdjacencyMap a -> Maybe (AdjacencyMap a)-removeVertex1 x = toNonEmpty . AM.removeVertex x . am+removeVertex1 = fmap toNonEmpty . coerce AM.removeVertex  -- | Remove an edge from a given graph. -- Complexity: /O(log(n))/ time.@@ -433,7 +549,7 @@ -- 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)+removeEdge = coerce AM.removeEdge  -- | 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.@@ -445,7 +561,7 @@ -- replaceVertex x y            == 'mergeVertices' (== x) y -- @ replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a-replaceVertex u v = via (AM.replaceVertex u v)+replaceVertex = coerce AM.replaceVertex  -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes@@ -458,7 +574,7 @@ -- 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)+mergeVertices = coerce AM.mergeVertices  -- | Transpose a given graph. -- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory.@@ -470,7 +586,7 @@ -- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a-transpose = via AM.transpose+transpose = coerce AM.transpose {-# NOINLINE [1] transpose #-}  {-# RULES@@ -497,7 +613,7 @@ -- gmap f . gmap g   == gmap (f . g) -- @ gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b-gmap f = via (AM.gmap f)+gmap = coerce AM.gmap  -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate.@@ -511,8 +627,21 @@ -- 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+induce1 = fmap toNonEmpty . coerce AM.induce +-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'. Returns 'Nothing' if the resulting graph is empty.+-- Complexity: /O(n + m)/ time.+--+-- @+-- induceJust1 ('vertex' 'Nothing')                               == 'Nothing'+-- induceJust1 ('edge' ('Just' x) 'Nothing')                        == 'Just' ('vertex' x)+-- induceJust1 . 'gmap' 'Just'                                    == 'Just'+-- induceJust1 . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce1' p+-- @+induceJust1 :: Ord a => AdjacencyMap (Maybe a) -> Maybe (AdjacencyMap a)+induceJust1 m = toNonEmpty (AM.induceJust (coerce m))+ -- | Compute the /reflexive and transitive closure/ of a graph. -- Complexity: /O(n * m * log(n)^2)/ time. --@@ -527,7 +656,7 @@ -- 'postSet' x (closure y)    == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) -- @ closure :: Ord a => AdjacencyMap a -> AdjacencyMap a-closure = via (AM.closure)+closure = coerce AM.closure  -- | Compute the /reflexive closure/ of a graph by adding a self-loop to every -- vertex.@@ -540,7 +669,7 @@ -- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a-reflexiveClosure = via AM.reflexiveClosure+reflexiveClosure = coerce AM.reflexiveClosure  -- | Compute the /symmetric closure/ of a graph by overlaying it with its own -- transpose.@@ -553,7 +682,7 @@ -- symmetricClosure . symmetricClosure == symmetricClosure -- @ symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a-symmetricClosure = via AM.symmetricClosure+symmetricClosure = coerce AM.symmetricClosure  -- | Compute the /transitive closure/ of a graph. -- Complexity: /O(n * m * log(n)^2)/ time.@@ -565,4 +694,21 @@ -- transitiveClosure . transitiveClosure == transitiveClosure -- @ transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a-transitiveClosure = via AM.transitiveClosure+transitiveClosure = coerce AM.transitiveClosure++-- TODO: Add tests.+-- | Check that the internal graph representation is consistent, i.e. that all+-- edges refer to existing vertices, and the graph is non-empty. It should be+-- impossible to create an inconsistent adjacency map, and we use this function+-- in testing.+--+-- @+-- consistent ('vertex' x)    == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('edge' x y)    == True+-- consistent ('edges' xs)    == True+-- consistent ('stars' xs)    == True+-- @+consistent :: Ord a => AdjacencyMap a -> Bool+consistent (NAM x) = AM.consistent x && not (AM.isEmpty x)

@@ -1,165 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module     : Algebra.Graph.NonEmpty.AdjacencyMap.Internal--- Copyright  : (c) Andrey Mokhov 2016-2018--- License    : MIT (see the file LICENSE)--- Maintainer : andrey.mokhov@gmail.com--- Stability  : experimental------ This module exposes the implementation of non-empty adjacency maps. The API--- is unstable and unsafe, and is exposed only for documentation. You should use--- the non-internal module "Algebra.Graph.NonEmpty.AdjacencyMap" instead.-------------------------------------------------------------------------------module Algebra.Graph.NonEmpty.AdjacencyMap.Internal (-    -- * Adjacency map implementation-    AdjacencyMap (..), consistent-    ) where--import Control.DeepSeq-import Data.List-import GHC.Generics--import qualified Algebra.Graph.AdjacencyMap          as AM-import qualified Algebra.Graph.AdjacencyMap.Internal as AM-import qualified Data.Map.Strict                     as Map-import qualified Data.Set                            as Set--{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to-their adjacency sets. We define a 'Num' instance as a convenient notation for-working with graphs:--    > 0           == vertex 0-    > 1 + 2       == overlay (vertex 1) (vertex 2)-    > 1 * 2       == connect (vertex 1) (vertex 2)-    > 1 + 2 * 3   == overlay (vertex 1) (connect (vertex 2) (vertex 3))-    > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))--__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 'Show' instance is defined using basic graph construction primitives:--@show (1         :: AdjacencyMap Int) == "vertex 1"-show (1 + 2     :: AdjacencyMap Int) == "vertices1 [1,2]"-show (1 * 2     :: AdjacencyMap Int) == "edge 1 2"-show (1 * 2 * 3 :: AdjacencyMap Int) == "edges1 [(1,2),(1,3),(2,3)]"-show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@--The 'Eq' instance satisfies the following laws of algebraic graphs:--    * 'Algebra.Graph.NonEmpty.AdjacencyMap.overlay' is commutative, associative and idempotent:--        >       x + y == y + x-        > x + (y + z) == (x + y) + z-        >       x + x == x--    * 'Algebra.Graph.NonEmpty.AdjacencyMap.connect' is associative:--        > x * (y * z) == (x * y) * z--    * 'Algebra.Graph.NonEmpty.AdjacencyMap.connect' distributes over 'Algebra.Graph.NonEmpty.AdjacencyMap.overlay':--        > x * (y + z) == x * y + x * z-        > (x + y) * z == x * z + y * z--    * 'Algebra.Graph.NonEmpty.AdjacencyMap.connect' can be decomposed:--        > x * y * z == x * y + x * z + y * z--    * 'Algebra.Graph.NonEmpty.AdjacencyMap.connect' satisfies absorption and saturation:--        > x * y + x + y == x * y-        >     x * x * x == x * x--When specifying the time and memory complexity of graph algorithms, /n/ and /m/-will denote the number of vertices and edges in the graph, respectively.--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.NonEmpty.AdjacencyMap.vertex' 1 < 'Algebra.Graph.NonEmpty.AdjacencyMap.vertex' 2-'Algebra.Graph.NonEmpty.AdjacencyMap.vertex' 3 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2-'Algebra.Graph.NonEmpty.AdjacencyMap.vertex' 1 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1-'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2-'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1 + 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 2 2-'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 3@--Note that the resulting order refines the-'Algebra.Graph.NonEmpty.AdjacencyMap.isSubgraphOf' relation and is compatible-with 'Algebra.Graph.NonEmpty.AdjacencyMap.overlay' and-'Algebra.Graph.NonEmpty.AdjacencyMap.connect' operations:--@'Algebra.Graph.NonEmpty.AdjacencyMap.isSubgraphOf' x y ==> x <= y@--@x     <= x + y-x + y <= x * y@--}-newtype AdjacencyMap a = NAM {-    -- | The /adjacency map/ of a graph: each vertex is associated with a set of-    -- its direct successors. Complexity: /O(1)/ time and memory.-    ---    -- @-    -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty'-    -- adjacencyMap ('Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1)-    -- adjacencyMap ('Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')]-    -- @-    am :: AM.AdjacencyMap a } deriving (Eq, Generic, NFData, Ord)---- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' for--- more details.-instance (Ord a, Num a) => Num (AdjacencyMap a) where-    fromInteger   = NAM . AM.vertex . fromInteger-    NAM x + NAM y = NAM (AM.overlay x y)-    NAM x * NAM y = NAM (AM.connect x y)-    signum        = error "NonEmpty.AdjacencyMap.signum cannot be implemented."-    abs           = id-    negate        = id--instance (Ord a, Show a) => Show (AdjacencyMap a) where-    showsPrec p (NAM (AM.AM m))-        | null vs    = error "NonEmpty.AdjacencyMap.Show: Graph is 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 (Map.keysSet m)-        es             = AM.internalEdgeList m-        vshow [x]      = showString "vertex "    . showsPrec 11 x-        vshow xs       = showString "vertices1 " . showsPrec 11 xs-        eshow [(x, y)] = showString "edge "      . showsPrec 11 x .-                         showString " "          . showsPrec 11 y-        eshow xs       = showString "edges1 "    . showsPrec 11 xs-        used           = Set.toAscList (AM.referredToVertexSet m)---- | Check if the internal graph representation is consistent, i.e. that all--- edges refer to existing vertices, and the graph is non-empty. 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 ('vertex' x)    == True--- consistent ('overlay' x y) == True--- consistent ('connect' x y) == True--- consistent ('Algebra.Graph.NonEmpty.AdjacencyMap.edge' x y)    == True--- consistent ('Algebra.Graph.NonEmpty.AdjacencyMap.edges' xs)    == True--- consistent ('Algebra.Graph.NonEmpty.AdjacencyMap.stars' xs)    == True--- @-consistent :: Ord a => AdjacencyMap a -> Bool-consistent (NAM x) = AM.consistent x && not (AM.isEmpty x)

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module     : Algebra.Graph.Relation--- Copyright  : (c) Andrey Mokhov 2016-2018+-- Copyright  : (c) Andrey Mokhov 2016-2019 -- License    : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability  : experimental@@ -32,23 +32,227 @@     path, circuit, clique, biclique, star, stars, tree, forest,      -- * Graph transformation-    removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce,+    removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,+    induce, induceJust,      -- * Relational operations-    compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure-  ) where+    compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure, -import Prelude ()-import Prelude.Compat+    -- * Miscellaneous+    consistent+    ) where +import Control.DeepSeq+import Data.Set (Set, union) import Data.Tree import Data.Tuple -import Algebra.Graph.Relation.Internal+import qualified Data.Maybe as Maybe+import qualified Data.Set   as Set+import qualified Data.Tree  as Tree -import qualified Data.Set    as Set-import qualified Data.Tree   as Tree+import Algebra.Graph.Internal +{-| The 'Relation' data type represents a graph as a /binary relation/. 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))++__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     :: Relation Int) == "empty"+show (1         :: Relation Int) == "vertex 1"+show (1 + 2     :: Relation Int) == "vertices [1,2]"+show (1 * 2     :: Relation Int) == "edge 1 2"+show (1 * 2 * 3 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: Relation Int) == "overlay (vertex 3) (edge 1 2)"@++The 'Eq' instance satisfies all axioms of algebraic graphs:++    * 'overlay' is commutative and associative:++        >       x + y == y + x+        > x + (y + z) == (x + y) + z++    * 'connect' is associative and has 'empty' as the identity:++        >   x * empty == x+        >   empty * x == x+        > x * (y * z) == (x * y) * z++    * 'connect' distributes over 'overlay':++        > x * (y + z) == x * y + x * z+        > (x + y) * z == x * z + y * z++    * 'connect' can be decomposed:++        > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++    * 'overlay' has 'empty' as the+    identity and is idempotent:++        >   x + empty == x+        >   empty + x == x+        >       x + x == x++    * Absorption and saturation of 'connect':++        > x * y + x + y == x * y+        >     x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ and /m/+will denote the number of vertices and edges in the graph, respectively.++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 Relation a = Relation {+    -- | The /domain/ of the relation. Complexity: /O(1)/ time and memory.+    domain :: Set a,+    -- | The set of pairs of elements that are /related/. It is guaranteed that+    -- each element belongs to the domain. Complexity: /O(1)/ time and memory.+    relation :: Set (a, a)+  } deriving Eq++instance (Ord a, Show a) => Show (Relation a) where+    showsPrec p (Relation d r)+        | Set.null d = showString "empty"+        | Set.null r = showParen (p > 10) $ vshow (Set.toAscList d)+        | d == used  = showParen (p > 10) $ eshow (Set.toAscList r)+        | otherwise  = showParen (p > 10) $+                           showString "overlay (" .+                           vshow (Set.toAscList $ Set.difference d used) .+                           showString ") (" . eshow (Set.toAscList r) .+                           showString ")"+      where+        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           = referredToVertexSet r++instance Ord a => Ord (Relation a) where+    compare x y = mconcat+        [ compare (vertexCount x) (vertexCount  y)+        , compare (vertexSet   x) (vertexSet    y)+        , compare (edgeCount   x) (edgeCount    y)+        , compare (edgeSet     x) (edgeSet      y) ]++instance NFData a => NFData (Relation a) where+    rnf (Relation d r) = rnf d `seq` rnf r `seq` ()++-- | __Note:__ this does not satisfy the usual ring laws; see 'Relation' for+-- more details.+instance (Ord a, Num a) => Num (Relation a) where+    fromInteger = vertex . fromInteger+    (+)         = overlay+    (*)         = connect+    signum      = const empty+    abs         = id+    negate      = id++-- | Construct the /empty graph/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'isEmpty'     empty == True+-- 'hasVertex' x empty == False+-- 'vertexCount' empty == 0+-- 'edgeCount'   empty == 0+-- @+empty :: Relation a+empty = Relation Set.empty Set.empty++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'isEmpty'     (vertex x) == False+-- 'hasVertex' x (vertex y) == (x == y)+-- 'vertexCount' (vertex x) == 1+-- 'edgeCount'   (vertex x) == 0+-- @+vertex :: a -> Relation a+vertex x = Relation (Set.singleton x) Set.empty++-- | /Overlay/ two graphs. This is a commutative, associative and idempotent+-- operation with the identity 'empty'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'isEmpty'     (overlay x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (overlay x y) >= 'vertexCount' x+-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (overlay x y) >= 'edgeCount' x+-- 'edgeCount'   (overlay x y) <= 'edgeCount' x   + 'edgeCount' y+-- 'vertexCount' (overlay 1 2) == 2+-- 'edgeCount'   (overlay 1 2) == 0+-- @+overlay :: Ord a => Relation a -> Relation a -> Relation a+overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y)++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'isEmpty'     (connect x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (connect x y) >= 'vertexCount' x+-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (connect x y) >= 'edgeCount' x+-- 'edgeCount'   (connect x y) >= 'edgeCount' y+-- 'edgeCount'   (connect x y) >= 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y+-- 'vertexCount' (connect 1 2) == 2+-- 'edgeCount'   (connect 1 2) == 1+-- @+connect :: Ord a => Relation a -> Relation a -> Relation a+connect x y = Relation (domain x `union` domain y)+    (relation x `union` relation y `union` (domain x `setProduct` domain y))+ -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory and size. --@@ -82,6 +286,7 @@ -- @ -- edges []          == 'empty' -- edges [(x,y)]     == 'edge' x y+-- edges             == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: Ord a => [(a, a)] -> Relation a@@ -147,8 +352,7 @@ -- -- @ -- hasVertex x 'empty'            == False--- hasVertex x ('vertex' x)       == True--- hasVertex 1 ('vertex' 2)       == False+-- hasVertex x ('vertex' y)       == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> Relation a -> Bool@@ -489,7 +693,7 @@  -- | 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+-- Complexity: /O(n + m)/ time, assuming that the predicate takes /O(1)/ to -- be evaluated. -- -- @@@ -504,6 +708,26 @@   where     pp (x, y) = p x && p y +-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'.+-- Complexity: /O(n + m)/ time.+--+-- @+-- induceJust ('vertex' 'Nothing')                               == 'empty'+-- induceJust ('edge' ('Just' x) 'Nothing')                        == 'vertex' x+-- induceJust . 'gmap' 'Just'                                    == 'id'+-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p+-- @+induceJust :: Ord a => Relation (Maybe a) -> Relation a+induceJust (Relation d r) = Relation (catMaybesSet d) (catMaybesSet2 r)+  where+    catMaybesSet         = Set.mapMonotonic Maybe.fromJust . Set.delete Nothing+    catMaybesSet2        = Set.mapMonotonic (\(x, y) -> (Maybe.fromJust x, Maybe.fromJust y))+                         . Set.filter p+    p (Nothing, _)       = False+    p (_,       Nothing) = False+    p (_,       _)       = True+ -- | 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@@ -590,3 +814,24 @@     | otherwise  = transitiveClosure new   where     new = overlay old (old `compose` old)++-- | Check that the internal representation of a relation is consistent, i.e. if all+-- pairs of elements in the 'relation' refer to existing elements in the 'domain'.+-- It should be impossible to create an inconsistent 'Relation', and we use this+-- function in testing.+--+-- @+-- consistent 'empty'         == True+-- consistent ('vertex' x)    == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('edge' x y)    == True+-- consistent ('edges' xs)    == True+-- consistent ('stars' xs)    == True+-- @+consistent :: Ord a => Relation a -> Bool+consistent (Relation d r) = referredToVertexSet r `Set.isSubsetOf` d++-- The set of elements that appear in a given set of pairs.+referredToVertexSet :: Ord a => Set (a, a) -> Set a+referredToVertexSet = Set.fromList . uncurry (++) . unzip . Set.toAscList