diff --git a/AUTHORS.md b/AUTHORS.md new file mode 100644 --- /dev/null +++ b/AUTHORS.md @@ -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 diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -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: is a library for algebraic construction and @@ -50,15 +49,14 @@ and - can be used for polymorphic construction and manipulation of graphs. Also see - - 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 . 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 diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -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 #-} diff --git a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs @@ -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 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 diff --git a/src/Algebra/Graph/AdjacencyIntMap.hs b/src/Algebra/Graph/AdjacencyIntMap.hs --- a/src/Algebra/Graph/AdjacencyIntMap.hs +++ b/src/Algebra/Graph/AdjacencyIntMap.hs @@ -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 ] diff --git a/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs --- a/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs +++ b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs @@ -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 diff --git a/src/Algebra/Graph/AdjacencyIntMap/Internal.hs b/src/Algebra/Graph/AdjacencyIntMap/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/AdjacencyIntMap/Internal.hs +++ /dev/null @@ -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 ] diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -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 ] diff --git a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs --- a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs +++ b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs @@ -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 +-- . +-- +-- 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 diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/AdjacencyMap/Internal.hs +++ /dev/null @@ -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 diff --git a/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs b/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Bipartite/Undirected/AdjacencyMap.hs @@ -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 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 ] diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -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 diff --git a/src/Algebra/Graph/Export.hs b/src/Algebra/Graph/Export.hs --- a/src/Algebra/Graph/Export.hs +++ b/src/Algebra/Graph/Export.hs @@ -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) diff --git a/src/Algebra/Graph/Export/Dot.hs b/src/Algebra/Graph/Export/Dot.hs --- a/src/Algebra/Graph/Export/Dot.hs +++ b/src/Algebra/Graph/Export/Dot.hs @@ -19,7 +19,7 @@ -- * Export functions export, exportAsIs, exportViaShow - ) where + ) where import Data.List hiding (unlines) import Data.Monoid diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs deleted file mode 100644 --- a/src/Algebra/Graph/Fold.hs +++ /dev/null @@ -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 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 diff --git a/src/Algebra/Graph/HigherKinded/Class.hs b/src/Algebra/Graph/HigherKinded/Class.hs --- a/src/Algebra/Graph/HigherKinded/Class.hs +++ b/src/Algebra/Graph/HigherKinded/Class.hs @@ -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 diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs --- a/src/Algebra/Graph/Internal.hs +++ b/src/Algebra/Graph/Internal.hs @@ -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 diff --git a/src/Algebra/Graph/Label.hs b/src/Algebra/Graph/Label.hs --- a/src/Algebra/Graph/Label.hs +++ b/src/Algebra/Graph/Label.hs @@ -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)) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -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 diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs --- a/src/Algebra/Graph/Labelled/AdjacencyMap.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -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 ] diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +++ /dev/null @@ -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 ] diff --git a/src/Algebra/Graph/Labelled/Example/Automaton.hs b/src/Algebra/Graph/Labelled/Example/Automaton.hs --- a/src/Algebra/Graph/Labelled/Example/Automaton.hs +++ b/src/Algebra/Graph/Labelled/Example/Automaton.hs @@ -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 diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -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. diff --git a/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs --- a/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs +++ b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs @@ -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) diff --git a/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs +++ /dev/null @@ -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) diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -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 diff --git a/src/Algebra/Graph/Relation/Internal.hs b/src/Algebra/Graph/Relation/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/Relation/Internal.hs +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Relation.Internal --- Copyright : (c) Andrey Mokhov 2016-2019 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of the 'Relation' data type. The API --- is unstable and unsafe, and is exposed only for documentation. You should --- use the non-internal module "Algebra.Graph.Relation" instead. ------------------------------------------------------------------------------ -module Algebra.Graph.Relation.Internal ( - -- * Binary relation implementation - Relation (..), empty, vertex, overlay, connect, setProduct, consistent, - referredToVertexSet - ) where - -import Control.DeepSeq (NFData, rnf) -import Data.Monoid (mconcat) -import Data.Set (Set, union) - -import Algebra.Graph.Internal - -import qualified Data.Set as Set - -{-| 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: - - * 'Algebra.Graph.Relation.overlay' is commutative and associative: - - > x + y == y + x - > x + (y + z) == (x + y) + z - - * 'Algebra.Graph.Relation.connect' is associative and has - 'Algebra.Graph.Relation.empty' as the identity: - - > x * empty == x - > empty * x == x - > x * (y * z) == (x * y) * z - - * 'Algebra.Graph.Relation.connect' distributes over - 'Algebra.Graph.Relation.overlay': - - > x * (y + z) == x * y + x * z - > (x + y) * z == x * z + y * z - - * 'Algebra.Graph.Relation.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.Relation.overlay' has 'Algebra.Graph.Relation.empty' as the - identity and is idempotent: - - > x + empty == x - > empty + x == x - > x + x == x - - * Absorption and saturation of 'Algebra.Graph.Relation.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 < 'Algebra.Graph.Relation.edge' 1 2 -'vertex' 1 < 'Algebra.Graph.Relation.edge' 1 1 -'Algebra.Graph.Relation.edge' 1 1 < 'Algebra.Graph.Relation.edge' 1 2 -'Algebra.Graph.Relation.edge' 1 2 < 'Algebra.Graph.Relation.edge' 1 1 + 'Algebra.Graph.Relation.edge' 2 2 -'Algebra.Graph.Relation.edge' 1 2 < 'Algebra.Graph.Relation.edge' 1 3@ - -Note that the resulting order refines the -'Algebra.Graph.Relation.isSubgraphOf' relation and is compatible with -'overlay' and 'connect' operations: - -@'Algebra.Graph.Relation.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 (Set.size $ domain x) (Set.size $ domain y) - , compare ( domain x) ( domain y) - , compare (Set.size $ relation x) (Set.size $ relation y) - , compare ( relation x) ( relation y) ] - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' empty == True --- 'Algebra.Graph.Relation.hasVertex' x empty == False --- 'Algebra.Graph.Relation.vertexCount' empty == 0 --- 'Algebra.Graph.Relation.edgeCount' empty == 0 --- @ -empty :: Relation a -empty = Relation Set.empty Set.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (vertex x) == False --- 'Algebra.Graph.Relation.hasVertex' x (vertex x) == True --- 'Algebra.Graph.Relation.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.Relation.edgeCount' (vertex x) == 0 --- @ -vertex :: a -> Relation a -vertex x = Relation (Set.singleton x) Set.empty - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (overlay x y) == 'Algebra.Graph.Relation.isEmpty' x && 'iAlgebra.Graph.Relation.sEmpty' y --- 'Algebra.Graph.Relation.hasVertex' z (overlay x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y --- 'Algebra.Graph.Relation.vertexCount' (overlay x y) >= 'Algebra.Graph.Relation.vertexCount' x --- 'Algebra.Graph.Relation.vertexCount' (overlay x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (overlay x y) >= 'Algebra.Graph.Relation.edgeCount' x --- 'Algebra.Graph.Relation.edgeCount' (overlay x y) <= 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.Relation.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => Relation a -> Relation a -> Relation a -overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y) - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (connect x y) == 'Algebra.Graph.Relation.isEmpty' x && 'Algebra.Graph.Relation.isEmpty' y --- 'Algebra.Graph.Relation.hasVertex' z (connect x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y --- 'Algebra.Graph.Relation.vertexCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x --- 'Algebra.Graph.Relation.vertexCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' x --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y + 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.Relation.edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => Relation a -> Relation a -> Relation a -connect x y = Relation (domain x `union` domain y) - (relation x `union` relation y `union` (domain x `setProduct` domain y)) - -instance NFData a => NFData (Relation a) where - rnf (Relation d r) = rnf d `seq` rnf r `seq` () - --- | __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 - --- | Check if the internal representation of a relation is consistent, i.e. if all --- pairs of elements in the 'relation' refer to existing elements in the 'domain'. --- It should be impossible to create an inconsistent 'Relation', and we use this --- function in testing. --- /Note: this function is for internal use only/. --- --- @ --- consistent 'Algebra.Graph.Relation.empty' == True --- consistent ('Algebra.Graph.Relation.vertex' x) == True --- consistent ('Algebra.Graph.Relation.overlay' x y) == True --- consistent ('Algebra.Graph.Relation.connect' x y) == True --- consistent ('Algebra.Graph.Relation.edge' x y) == True --- consistent ('Algebra.Graph.Relation.edges' xs) == True --- consistent ('Algebra.Graph.Relation.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. --- /Note: this function is for internal use only/. -referredToVertexSet :: Ord a => Set (a, a) -> Set a -referredToVertexSet = Set.fromList . uncurry (++) . unzip . Set.toAscList diff --git a/src/Algebra/Graph/Relation/InternalDerived.hs b/src/Algebra/Graph/Relation/InternalDerived.hs deleted file mode 100644 --- a/src/Algebra/Graph/Relation/InternalDerived.hs +++ /dev/null @@ -1,130 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Relation.InternalDerived --- Copyright : (c) Andrey Mokhov 2016-2019 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of derived binary relation data types. --- The API is unstable and unsafe, and is exposed only for documentation. You --- should use the non-internal modules "Algebra.Graph.Relation.Reflexive", --- "Algebra.Graph.Relation.Symmetric", "Algebra.Graph.Relation.Transitive" and --- "Algebra.Graph.Relation.Preorder" instead. ------------------------------------------------------------------------------ -module Algebra.Graph.Relation.InternalDerived ( - -- * Implementation of derived binary relations - ReflexiveRelation (..), TransitiveRelation (..), PreorderRelation (..) - ) where - -import Control.DeepSeq (NFData (..)) - -import Algebra.Graph.Class -import Algebra.Graph.Relation (Relation, reflexiveClosure, transitiveClosure, closure) - -{-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ -over a set of elements. Reflexive relations satisfy all laws of the -'Reflexive' type class and, in particular, the /self-loop/ axiom: - -@'vertex' x == 'vertex' x * 'vertex' x@ - -The 'Show' instance produces reflexively closed expressions: - -@show (1 :: ReflexiveRelation Int) == "edge 1 1" -show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ --} -newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } - deriving (Num, NFData) - -instance Ord a => Eq (ReflexiveRelation a) where - x == y = reflexiveClosure (fromReflexive x) == reflexiveClosure (fromReflexive y) - -instance (Ord a, Show a) => Show (ReflexiveRelation a) where - show = show . reflexiveClosure . fromReflexive - -instance Ord a => Graph (ReflexiveRelation a) where - type Vertex (ReflexiveRelation a) = a - empty = ReflexiveRelation empty - vertex = ReflexiveRelation . vertex - overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y - connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y - -instance Ord a => Reflexive (ReflexiveRelation a) - --- TODO: Optimise the implementation by caching the results of transitive closure. -{-| The 'TransitiveRelation' data type represents a /transitive binary relation/ -over a set of elements. Transitive relations satisfy all laws of the -'Transitive' type class and, in particular, the /closure/ axiom: - -@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ - -For example, the following holds: - -@'path' xs == ('clique' xs :: TransitiveRelation Int)@ - -The 'Show' instance produces transitively closed expressions: - -@show (1 * 2 :: TransitiveRelation Int) == "edge 1 2" -show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ --} -newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } - deriving (Num, NFData) - -instance Ord a => Eq (TransitiveRelation a) where - x == y = transitiveClosure (fromTransitive x) == transitiveClosure (fromTransitive y) - -instance (Ord a, Show a) => Show (TransitiveRelation a) where - show = show . transitiveClosure . fromTransitive - --- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => Graph (TransitiveRelation a) where - type Vertex (TransitiveRelation a) = a - empty = TransitiveRelation empty - vertex = TransitiveRelation . vertex - overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y - connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y - -instance Ord a => Transitive (TransitiveRelation a) - --- TODO: Optimise the implementation by caching the results of preorder closure. -{-| The 'PreorderRelation' data type represents a -/binary relation that is both reflexive and transitive/. Preorders satisfy all -laws of the 'Preorder' type class and, in particular, the /self-loop/ axiom: - -@'vertex' x == 'vertex' x * 'vertex' x@ - -and the /closure/ axiom: - -@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ - -For example, the following holds: - -@'path' xs == ('clique' xs :: PreorderRelation Int)@ - -The 'Show' instance produces reflexively and transitively closed expressions: - -@show (1 :: PreorderRelation Int) == "edge 1 1" -show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]" -show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ --} -newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } - deriving (Num, NFData) - -instance (Ord a, Show a) => Show (PreorderRelation a) where - show = show . closure . fromPreorder - -instance Ord a => Eq (PreorderRelation a) where - x == y = closure (fromPreorder x) == closure (fromPreorder y) - --- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => Graph (PreorderRelation a) where - type Vertex (PreorderRelation a) = a - empty = PreorderRelation empty - vertex = PreorderRelation . vertex - overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y - connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y - -instance Ord a => Reflexive (PreorderRelation a) -instance Ord a => Transitive (PreorderRelation a) -instance Ord a => Preorder (PreorderRelation a) - diff --git a/src/Algebra/Graph/Relation/Preorder.hs b/src/Algebra/Graph/Relation/Preorder.hs --- a/src/Algebra/Graph/Relation/Preorder.hs +++ b/src/Algebra/Graph/Relation/Preorder.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Preorder --- 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 @@ -12,10 +12,57 @@ module Algebra.Graph.Relation.Preorder ( -- * Data structure PreorderRelation, fromRelation, toRelation - ) where + ) where +import Control.DeepSeq import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived + +import qualified Algebra.Graph.Class as C + +-- TODO: Optimise the implementation by caching the results of preorder closure. +{-| The 'PreorderRelation' data type represents a +/binary relation that is both reflexive and transitive/. Preorders satisfy all +laws of the 'Preorder' type class and, in particular, the /self-loop/ axiom: + +@'vertex' x == 'vertex' x * 'vertex' x@ + +and the /closure/ axiom: + +@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ + +For example, the following holds: + +@'path' xs == ('clique' xs :: PreorderRelation Int)@ + +The 'Show' instance produces reflexively and transitively closed expressions: + +@show (1 :: PreorderRelation Int) == "edge 1 1" +show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]" +show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ +-} +newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } + deriving (Num, NFData) + +instance (Ord a, Show a) => Show (PreorderRelation a) where + show = show . toRelation + +instance Ord a => Eq (PreorderRelation a) where + x == y = toRelation x == toRelation y + +instance Ord a => Ord (PreorderRelation a) where + compare x y = compare (toRelation x) (toRelation y) + +-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 +instance Ord a => C.Graph (PreorderRelation a) where + type Vertex (PreorderRelation a) = a + empty = PreorderRelation empty + vertex = PreorderRelation . vertex + overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y + connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y + +instance Ord a => C.Reflexive (PreorderRelation a) +instance Ord a => C.Transitive (PreorderRelation a) +instance Ord a => C.Preorder (PreorderRelation a) -- | Construct a preorder relation from a 'Relation'. -- Complexity: /O(1)/ time. diff --git a/src/Algebra/Graph/Relation/Reflexive.hs b/src/Algebra/Graph/Relation/Reflexive.hs --- a/src/Algebra/Graph/Relation/Reflexive.hs +++ b/src/Algebra/Graph/Relation/Reflexive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Reflexive --- 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 @@ -12,10 +12,44 @@ module Algebra.Graph.Relation.Reflexive ( -- * Data structure ReflexiveRelation, fromRelation, toRelation - ) where + ) where +import Control.DeepSeq import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived + +import qualified Algebra.Graph.Class as C + +{-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ +over a set of elements. Reflexive relations satisfy all laws of the +'Reflexive' type class and, in particular, the /self-loop/ axiom: + +@'vertex' x == 'vertex' x * 'vertex' x@ + +The 'Show' instance produces reflexively closed expressions: + +@show (1 :: ReflexiveRelation Int) == "edge 1 1" +show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ +-} +newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } + deriving (Num, NFData) + +instance Ord a => Eq (ReflexiveRelation a) where + x == y = toRelation x == toRelation y + +instance Ord a => Ord (ReflexiveRelation a) where + compare x y = compare (toRelation x) (toRelation y) + +instance (Ord a, Show a) => Show (ReflexiveRelation a) where + show = show . toRelation + +instance Ord a => C.Graph (ReflexiveRelation a) where + type Vertex (ReflexiveRelation a) = a + empty = ReflexiveRelation empty + vertex = ReflexiveRelation . vertex + overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y + connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y + +instance Ord a => C.Reflexive (ReflexiveRelation a) -- | Construct a reflexive relation from a 'Relation'. -- Complexity: /O(1)/ time. diff --git a/src/Algebra/Graph/Relation/Symmetric.hs b/src/Algebra/Graph/Relation/Symmetric.hs --- a/src/Algebra/Graph/Relation/Symmetric.hs +++ b/src/Algebra/Graph/Relation/Symmetric.hs @@ -34,19 +34,101 @@ path, circuit, clique, biclique, star, stars, tree, forest, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, - ) where + removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, induceJust, -import Algebra.Graph.Relation.Symmetric.Internal + -- * Miscellaneous + consistent + + ) where + +import Control.DeepSeq +import Data.Coerce import Data.Set (Set) import Data.Tree -import Data.Tuple import qualified Data.Set as Set -import qualified Algebra.Graph.Relation as R -import qualified Algebra.Graph.Relation.Internal as RI +import qualified Algebra.Graph.Relation as R +{-| This data type represents a /symmetric binary relation/ over a set of +elements of type @a@. Symmetric relations satisfy all laws of the +'Algebra.Graph.Class.Undirected' type class, including the commutativity of +'connect': + +@'connect' x y == 'connect' y x@ + +The 'Show' instance lists edge vertices in non-decreasing order: + +@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 (2 * 1 :: Relation Int) == "edge 1 2" +show (1 * 2 * 1 :: Relation Int) == "edges [(1,1),(1,2)]" +show (3 * 2 * 1 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: Relation Int) == "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. + +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' 2 1 < 'edge' 1 3@ + +@'edge' 1 2 == 'edge' 2 1@ + +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 Relation a = SR { + -- | Extract the underlying symmetric "Algebra.Graph.Relation". + -- Complexity: /O(1)/ time and memory. + -- + -- @ + -- fromSymmetric ('edge' 1 2) == 'R.edges' [(1,2), (2,1)] + -- 'R.vertexCount' . fromSymmetric == 'vertexCount' + -- 'R.edgeCount' . fromSymmetric <= (*2) . 'edgeCount' + -- @ + fromSymmetric :: R.Relation a + } deriving (Eq, NFData) + +instance (Ord a, Show a) => Show (Relation a) where + show = show . toRelation + where + toRelation r = R.vertices (vertexList r) `R.overlay` R.edges (edgeList 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) ] + +-- | __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 a symmetric relation from a given "Algebra.Graph.Relation". -- Complexity: /O(m*log(m))/ time. -- @@ -60,6 +142,69 @@ toSymmetric :: Ord a => R.Relation a -> Relation a toSymmetric = SR . R.symmetricClosure +-- | 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 = coerce R.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 = coerce R.vertex + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- '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 = coerce R.overlay + +-- | /Connect/ two graphs. 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 of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- connect x y == connect y x +-- '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 \`div\` 2 +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => Relation a -> Relation a -> Relation a +connect x y = coerce R.connect x y `overlay` biclique (vertexList y) (vertexList x) + -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory and size. -- @@ -73,7 +218,7 @@ -- 'vertexCount' (edge 1 2) == 2 -- @ edge :: Ord a => a -> a -> Relation a -edge x y = SR $ RI.Relation (Set.fromList [x, y]) (Set.fromList [(x,y), (y,x)]) +edge x y = SR $ R.edges [(x,y), (y,x)] -- | 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 @@ -87,7 +232,7 @@ -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: Ord a => [a] -> Relation a -vertices = SR . R.vertices +vertices = coerce R.vertices -- TODO: Optimise by avoiding multiple list traversal. -- | Construct the graph from a list of edges. @@ -99,8 +244,7 @@ -- edges [(x,y), (y,x)] == 'edge' x y -- @ edges :: Ord a => [(a, a)] -> Relation a -edges es = SR $ RI.Relation - (Set.fromList $ uncurry (++) $ unzip es) (Set.fromList (es ++ map swap es)) +edges = toSymmetric . R.edges -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -113,7 +257,7 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: Ord a => [Relation a] -> Relation a -overlays = SR . R.overlays . map fromSymmetric +overlays = coerce R.overlays -- | Connect a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -143,7 +287,7 @@ -- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Relation a -> Relation a -> Bool -isSubgraphOf x y = R.isSubgraphOf (fromSymmetric x) (fromSymmetric y) +isSubgraphOf = coerce R.isSubgraphOf -- | Check if a relation is empty. -- Complexity: /O(1)/ time. @@ -156,19 +300,18 @@ -- isEmpty ('removeEdge' x y $ 'edge' x y) == False -- @ isEmpty :: Relation a -> Bool -isEmpty = R.isEmpty . fromSymmetric +isEmpty = coerce R.isEmpty -- | Check if a graph contains a given vertex. -- Complexity: /O(log(n))/ time. -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> Relation a -> Bool -hasVertex x = R.hasVertex x . fromSymmetric +hasVertex = coerce R.hasVertex -- | Check if a graph contains a given edge. -- Complexity: /O(log(n))/ time. @@ -179,10 +322,10 @@ -- hasEdge x y ('edge' x y) == True -- hasEdge x y ('edge' y x) == True -- hasEdge x y . 'removeEdge' x y == 'const' False --- hasEdge x y == 'elem' (min x y, max x y) . 'edgeList' +-- hasEdge x y == 'elem' ('min' x y, 'max' x y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> Relation a -> Bool -hasEdge x y = R.hasEdge x y . fromSymmetric +hasEdge = coerce R.hasEdge -- | The number of vertices in a graph. -- Complexity: /O(1)/ time. @@ -194,7 +337,7 @@ -- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: Relation a -> Int -vertexCount = R.vertexCount . fromSymmetric +vertexCount = coerce R.vertexCount -- | The number of edges in a graph. -- Complexity: /O(1)/ time. @@ -206,7 +349,7 @@ -- edgeCount == 'length' . 'edgeList' -- @ edgeCount :: Ord a => Relation a -> Int -edgeCount = length . edgeList +edgeCount = Set.size . edgeSet -- | The sorted list of vertices of a given graph. -- Complexity: /O(n)/ time and memory. @@ -217,7 +360,7 @@ -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ vertexList :: Relation a -> [a] -vertexList = R.vertexList . fromSymmetric +vertexList = coerce R.vertexList -- | The sorted list of edges of a graph, where edge vertices appear in the -- non-decreasing order. @@ -229,7 +372,7 @@ -- @ -- edgeList 'empty' == [] -- edgeList ('vertex' x) == [] --- edgeList ('edge' x y) == [(min x y, max y x)] +-- edgeList ('edge' x y) == [('min' x y, 'max' y x)] -- edgeList ('star' 2 [3,1]) == [(1,2), (2,3)] -- @ edgeList :: Ord a => Relation a -> [(a, a)] @@ -244,8 +387,24 @@ -- vertexSet . 'vertices' == Set.'Set.fromList' -- @ vertexSet :: Relation a -> Set a -vertexSet = R.vertexSet . fromSymmetric +vertexSet = coerce R.vertexSet +-- | The set of edges of a given graph, where edge vertices appear in the +-- non-decreasing order. +-- Complexity: /O(m)/ time. +-- +-- Note: If you need the set of edges where an edge appears in both directions, +-- use @'R.relation' . 'fromSymmetric'@. The latter is much +-- faster than this function, and takes only /O(1)/ time and memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' x y) == Set.'Set.singleton' ('min' x y, 'max' x y) +-- @ +edgeSet :: Ord a => Relation a -> Set (a, a) +edgeSet = Set.filter (uncurry (<=)) . R.edgeSet . fromSymmetric + -- | The sorted /adjacency list/ of a graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory. -- @@ -257,7 +416,7 @@ -- 'stars' . adjacencyList == id -- @ adjacencyList :: Eq a => Relation a -> [(a, [a])] -adjacencyList = R.adjacencyList . fromSymmetric +adjacencyList = coerce R.adjacencyList -- | The /path/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -269,9 +428,7 @@ -- path == path . 'reverse' -- @ path :: Ord a => [a] -> Relation a -path xs = case xs of [] -> empty - [x] -> vertex x - (_:ys) -> edges (zip xs ys) +path = toSymmetric . R.path -- | The /circuit/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -283,11 +440,11 @@ -- circuit == circuit . 'reverse' -- @ circuit :: Ord a => [a] -> Relation a -circuit [] = empty -circuit (x:xs) = path $ [x] ++ xs ++ [x] +circuit = toSymmetric . R.circuit +-- TODO: Optimise by avoiding the call to 'R.symmetricClosure'. -- | The /clique/ on a list of vertices. --- Complexity: /O((n + m) * log(n))/ time + /O(m*log(m)) time from computing the symmetricClosure and /O(n + m)/ memory. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ -- clique [] == 'empty' @@ -298,10 +455,11 @@ -- clique == clique . 'reverse' -- @ clique :: Ord a => [a] -> Relation a -clique = SR . R.symmetricClosure . R.clique +clique = toSymmetric . R.clique +-- TODO: Optimise by avoiding the call to 'R.symmetricClosure'. -- | The /biclique/ on two lists of vertices. --- Complexity: /O(n * log(n) + m)/ time + /O(m*log(m)) time from computing the symmetricClosure and /O(n + m)/ memory. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ -- biclique [] [] == 'empty' @@ -311,7 +469,7 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Ord a => [a] -> [a] -> Relation a -biclique xs = SR . R.symmetricClosure . R.biclique xs +biclique xs ys = toSymmetric (R.biclique xs ys) -- TODO: Optimise. -- | The /star/ formed by a centre vertex connected to a list of leaves. @@ -324,8 +482,7 @@ -- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Ord a => a -> [a] -> Relation a -star x [] = vertex x -star x ys = connect (vertex x) (vertices ys) +star x = toSymmetric . R.star x -- | The /stars/ formed by overlaying a list of 'star's. An inverse of -- 'adjacencyList'. @@ -342,10 +499,7 @@ -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: Ord a => [(a, [a])] -> Relation a -stars as = SR $ RI.Relation (Set.fromList vs) (Set.fromList es) - where - vs = concatMap (uncurry (:)) as - es = [ (x, y) | (x, ys) <- as, y <- ys ] ++ [ (y, x) | (x, ys) <- as, y <- ys ] +stars = toSymmetric . R.stars -- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -357,9 +511,7 @@ -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] -- @ tree :: Ord a => Tree a -> Relation a -tree (Node x []) = vertex x -tree (Node x f ) = star x (map rootLabel f) - `overlay` forest (filter (not . null . subForest) f) +tree = toSymmetric . R.tree -- | The /forest graph/ constructed from a given 'Tree.Forest' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -371,7 +523,7 @@ -- forest == 'overlays' . 'map' 'tree' -- @ forest :: Ord a => Forest a -> Relation a -forest = overlays . map tree +forest = toSymmetric . R.forest -- | Remove a vertex from a given graph. -- Complexity: /O(n + m)/ time. @@ -384,7 +536,7 @@ -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: Ord a => a -> Relation a -> Relation a -removeVertex x = SR . R.removeVertex x . fromSymmetric +removeVertex = coerce R.removeVertex -- | Remove an edge from a given graph. -- Complexity: /O(log(m))/ time. @@ -398,9 +550,7 @@ -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- @ removeEdge :: Ord a => a -> a -> Relation a -> Relation a -removeEdge x y r = SR $ RI.Relation d (Set.delete (y, x) $ Set.delete (x, y) rr) - where - RI.Relation d rr = fromSymmetric r +removeEdge x y = SR . R.removeEdge x y . R.removeEdge y x . fromSymmetric -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'Relation'. If @y@ already exists, @x@ and @y@ will be merged. @@ -412,7 +562,7 @@ -- replaceVertex x y == 'mergeVertices' (== x) y -- @ replaceVertex :: Ord a => a -> a -> Relation a -> Relation a -replaceVertex u v = gmap $ \w -> if w == u then v else w +replaceVertex = coerce R.replaceVertex -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes @@ -425,7 +575,7 @@ -- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Ord a => (a -> Bool) -> a -> Relation a -> Relation a -mergeVertices p v = gmap $ \u -> if p u then v else u +mergeVertices = coerce R.mergeVertices -- | Transform a graph by applying a function to each of its vertices. This is -- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric @@ -440,11 +590,11 @@ -- gmap f . gmap g == gmap (f . g) -- @ gmap :: Ord b => (a -> b) -> Relation a -> Relation b -gmap f = SR . R.gmap f . fromSymmetric +gmap = coerce R.gmap -- | 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. -- -- @ @@ -455,17 +605,47 @@ -- 'isSubgraphOf' (induce p x) x == True -- @ induce :: (a -> Bool) -> Relation a -> Relation a -induce p = SR . R.induce p . fromSymmetric +induce = coerce R.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 ('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 = coerce R.induceJust + -- | The set of /neighbours/ of an element @x@ is the set of elements that are -- related to it, i.e. @neighbours x == { a | aRx }@. In the context of undirected -- graphs, this corresponds to the set of /adjacent/ vertices of vertex @x@. -- -- @ --- neighbours x 'Algebra.Graph.Class.empty' == Set.'Set.empty' --- neighbours x ('Algebra.Graph.Class.vertex' x) == Set.'Set.empty' --- neighbours x ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [y] --- neighbours y ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [x] +-- neighbours x 'empty' == Set.'Set.empty' +-- neighbours x ('vertex' x) == Set.'Set.empty' +-- neighbours x ('edge' x y) == Set.'Set.fromList' [y] +-- neighbours y ('edge' x y) == Set.'Set.fromList' [x] -- @ neighbours :: Ord a => a -> Relation a -> Set a -neighbours x = R.postSet x . fromSymmetric +neighbours = coerce R.postSet + +-- | Check that the internal representation of a symmetric relation is +-- consistent, i.e. that (i) that all edges refer to existing vertices, and (ii) +-- all edges have their symmetric counterparts. 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 (SR r) = R.consistent r && r == R.transpose r diff --git a/src/Algebra/Graph/Relation/Symmetric/Internal.hs b/src/Algebra/Graph/Relation/Symmetric/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/Relation/Symmetric/Internal.hs +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Relation.Symmetric.Internal --- Copyright : (c) Andrey Mokhov 2016-2019 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of symmetric binary relation data type. --- The API is unstable and unsafe, and is exposed only for documentation. You --- should use the non-internal module "Algebra.Graph.Relation.Symmetric" instead. ------------------------------------------------------------------------------ - -module Algebra.Graph.Relation.Symmetric.Internal ( - -- * Implementation of symmetric binary relations - Relation (..), fromSymmetric, empty, vertex, overlay, connect, edgeSet, - consistent - ) where - -import Algebra.Graph.Internal -import Control.DeepSeq -import Data.Monoid (mconcat) -import Data.Set (Set) - -import qualified Data.Set as Set - -import qualified Algebra.Graph.Relation.Internal as RI -import qualified Algebra.Graph.Relation as R - -{-| This data type represents a /symmetric binary relation/ over a set of -elements of type @a@. Symmetric relations satisfy all laws of the -'Algebra.Graph.Class.Undirected' type class, including the commutativity of -'connect': - -@'connect' x y == 'connect' y x@ - -The 'Show' instance lists edge vertices in non-decreasing order: - -@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 (2 * 1 :: Relation Int) == "edge 1 2" -show (1 * 2 * 1 :: Relation Int) == "edges [(1,1),(1,2)]" -show (3 * 2 * 1 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]" -show (1 * 2 + 3 :: Relation Int) == "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. - -Here are a few examples: - -@'vertex' 1 < 'vertex' 2 -'vertex' 3 < 'Algebra.Graph.Relation.Symmetric.edge' 1 2 -'vertex' 1 < 'Algebra.Graph.Relation.Symmetric.edge' 1 1 -'Algebra.Graph.Relation.Symmetric.edge' 1 1 < 'Algebra.Graph.Relation.Symmetric.edge' 1 2 -'Algebra.Graph.Relation.Symmetric.edge' 1 2 < 'Algebra.Graph.Relation.Symmetric.edge' 1 1 + 'Algebra.Graph.Relation.Symmetric.edge' 2 2 -'Algebra.Graph.Relation.Symmetric.edge' 2 1 < 'Algebra.Graph.Relation.Symmetric.edge' 1 3@ - -@'Algebra.Graph.Relation.Symmetric.edge' 1 2 == 'Algebra.Graph.Relation.Symmetric.edge' 2 1@ - -Note that the resulting order refines the -'Algebra.Graph.Relation.Symmetric.isSubgraphOf' relation and is compatible with -'overlay' and 'connect' operations: - -@'Algebra.Graph.Relation.Symmetric.isSubgraphOf' x y ==> x <= y@ - -@'empty' <= x -x <= x + y -x + y <= x * y@ --} -newtype Relation a = SR (RI.Relation a) deriving NFData - -instance Ord a => Eq (Relation a) where - x == y = fromSymmetric x == fromSymmetric y - -instance (Ord a, Show a) => Show (Relation a) where - show r@(SR (RI.Relation d _)) = show (RI.Relation d $ edgeSet r) - -instance Ord a => Ord (Relation a) where - compare rx@(SR (RI.Relation vx _)) ry@(SR (RI.Relation vy _)) = mconcat - [ compare (Set.size vx) (Set.size vy) - , compare vx vy - , compare (Set.size ex) (Set.size ey) - , compare ex ey ] - where - ex = edgeSet rx - ey = edgeSet ry - -instance (Ord a, Num a) => Num (Relation a) where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id - --- | Extract the underlying symmetric "Algebra.Graph.Relation". --- Complexity: /O(1)/ time and memory. --- --- @ --- fromSymmetric ('Algebra.Graph.Relation.Symmetric.edge' 1 2) == 'Algebra.Graph.Relation.edges' [(1,2), (2,1)] --- 'Algebra.Graph.Relation.vertexCount' . fromSymmetric == 'Algebra.Graph.Relation.Symmetric.vertexCount' --- 'Algebra.Graph.Relation.edgeCount' . fromSymmetric <= (*2) . 'Algebra.Graph.Relation.Symmetric.edgeCount' --- @ -fromSymmetric :: Relation a -> RI.Relation a -fromSymmetric (SR x) = x - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.Symmetric.isEmpty' empty == True --- 'Algebra.Graph.Relation.Symmetric.hasVertex' x empty == False --- 'Algebra.Graph.Relation.Symmetric.vertexCount' empty == 0 --- 'Algebra.Graph.Relation.Symmetric.edgeCount' empty == 0 --- @ -empty :: Relation a -empty = SR $ RI.Relation Set.empty Set.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.Symmetric.isEmpty' (vertex x) == False --- 'Algebra.Graph.Relation.Symmetric.hasVertex' x (vertex x) == True --- 'Algebra.Graph.Relation.Symmetric.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (vertex x) == 0 --- @ -vertex :: a -> Relation a -vertex x = SR $ RI.Relation (Set.singleton x) Set.empty - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'Algebra.Graph.Relation.Symmetric.isEmpty' (overlay x y) == 'Algebra.Graph.Relation.Symmetric.isEmpty' x && 'Algebra.Graph.Relation.Symmetric.isEmpty' y --- 'Algebra.Graph.Relation.Symmetric.hasVertex' z (overlay x y) == 'Algebra.Graph.Relation.Symmetric.hasVertex' z x || 'Algebra.Graph.Relation.Symmetric.hasVertex' z y --- 'Algebra.Graph.Relation.Symmetric.vertexCount' (overlay x y) >= 'Algebra.Graph.Relation.Symmetric.vertexCount' x --- 'Algebra.Graph.Relation.Symmetric.vertexCount' (overlay x y) <= 'Algebra.Graph.Relation.Symmetric.vertexCount' x + 'Algebra.Graph.Relation.Symmetric.vertexCount' y --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (overlay x y) >= 'Algebra.Graph.Relation.Symmetric.edgeCount' x --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (overlay x y) <= 'Algebra.Graph.Relation.Symmetric.edgeCount' x + 'Algebra.Graph.Relation.Symmetric.edgeCount' y --- 'Algebra.Graph.Relation.Symmetric.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => Relation a -> Relation a -> Relation a -overlay (SR x) (SR y) = SR $ RI.Relation (R.domain x `Set.union` R.domain y) - (R.relation x `Set.union` R.relation y) - --- | /Connect/ two graphs. 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 of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- connect x y == connect y x --- 'Algebra.Graph.Relation.Symmetric.isEmpty' (connect x y) == 'Algebra.Graph.Relation.Symmetric.isEmpty' x && 'Algebra.Graph.Relation.Symmetric.isEmpty' y --- 'Algebra.Graph.Relation.Symmetric.hasVertex' z (connect x y) == 'Algebra.Graph.Relation.Symmetric.hasVertex' z x || 'Algebra.Graph.Relation.Symmetric.hasVertex' z y --- 'Algebra.Graph.Relation.Symmetric.vertexCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.vertexCount' x --- 'Algebra.Graph.Relation.Symmetric.vertexCount' (connect x y) <= 'Algebra.Graph.Relation.Symmetric.vertexCount' x + 'Algebra.Graph.Relation.Symmetric.vertexCount' y --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.edgeCount' x --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.edgeCount' y --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.vertexCount' x * 'Algebra.Graph.Relation.Symmetric.vertexCount' y \`div\` 2 --- 'Algebra.Graph.Relation.Symmetric.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => Relation a -> Relation a -> Relation a -connect (SR x) (SR y) = SR $ RI.Relation (R.domain x `Set.union` R.domain y) - (Set.unions [R.relation x, R.relation y, R.domain x `setProduct` R.domain y - , R.domain y `setProduct` R.domain x ]) - --- | The set of edges of a given graph, where edge vertices appear in the --- non-decreasing order. --- Complexity: /O(m)/ time. --- --- Note: If you need the set of edges where an edge appears in both directions, --- use @'Algebra.Graph.Relation.relation' . 'fromSymmetric'@. The latter is much --- faster than this function, and takes only /O(1)/ time and memory. --- --- @ --- edgeSet 'empty' == Set.'Set.empty' --- edgeSet ('vertex' x) == Set.'Set.empty' --- edgeSet ('Algebra.Graph.Relation.Symmetric.edge' x y) == Set.'Set.singleton' (min x y, max x y) --- @ -edgeSet :: Ord a => Relation a -> Set (a, a) -edgeSet (SR (RI.Relation _ r)) = Set.filter (uncurry (<=)) r - --- | Check if the internal representation of a symmetric relation is consistent, --- i.e. if (i) all pairs of elements in the 'RI.relation' refer to existing --- elements in the 'RI.domain', and (ii) all edges have their symmetric --- counterparts. It should be impossible to create an inconsistent 'Relation', --- and we use this function in testing. --- /Note: this function is for internal use only/. --- --- @ --- consistent 'Algebra.Graph.Relation.Symmetric.empty' == True --- consistent ('Algebra.Graph.Relation.Symmetric.vertex' x) == True --- consistent ('Algebra.Graph.Relation.Symmetric.overlay' x y) == True --- consistent ('Algebra.Graph.Relation.Symmetric.connect' x y) == True --- consistent ('Algebra.Graph.Relation.Symmetric.edge' x y) == True --- consistent ('Algebra.Graph.Relation.Symmetric.edges' xs) == True --- consistent ('Algebra.Graph.Relation.Symmetric.stars' xs) == True --- @ -consistent :: Ord a => Relation a -> Bool -consistent (SR r) = - RI.referredToVertexSet (R.relation r) `Set.isSubsetOf` R.domain r - && - r == R.transpose r diff --git a/src/Algebra/Graph/Relation/Transitive.hs b/src/Algebra/Graph/Relation/Transitive.hs --- a/src/Algebra/Graph/Relation/Transitive.hs +++ b/src/Algebra/Graph/Relation/Transitive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Transitive --- 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 @@ -12,10 +12,50 @@ module Algebra.Graph.Relation.Transitive ( -- * Data structure TransitiveRelation, fromRelation, toRelation - ) where + ) where +import Control.DeepSeq import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived + +import qualified Algebra.Graph.Class as C + +-- TODO: Optimise the implementation by caching the results of transitive closure. +{-| The 'TransitiveRelation' data type represents a /transitive binary relation/ +over a set of elements. Transitive relations satisfy all laws of the +'Transitive' type class and, in particular, the /closure/ axiom: + +@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ + +For example, the following holds: + +@'path' xs == ('clique' xs :: TransitiveRelation Int)@ + +The 'Show' instance produces transitively closed expressions: + +@show (1 * 2 :: TransitiveRelation Int) == "edge 1 2" +show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ +-} +newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } + deriving (Num, NFData) + +instance Ord a => Eq (TransitiveRelation a) where + x == y = toRelation x == toRelation y + +instance Ord a => Ord (TransitiveRelation a) where + compare x y = compare (toRelation x) (toRelation y) + +instance (Ord a, Show a) => Show (TransitiveRelation a) where + show = show . toRelation + +-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 +instance Ord a => C.Graph (TransitiveRelation a) where + type Vertex (TransitiveRelation a) = a + empty = TransitiveRelation empty + vertex = TransitiveRelation . vertex + overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y + connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y + +instance Ord a => C.Transitive (TransitiveRelation a) -- | Construct a transitive relation from a 'Relation'. -- Complexity: /O(1)/ time. diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.ToGraph --- 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 @@ -41,10 +41,14 @@ -- of 'foldMap' and 'Data.Foldable.toList' violate this requirement, for example -- @[1] ++ [1] /= [1]@, and are therefore disallowed. ----------------------------------------------------------------------------- -module Algebra.Graph.ToGraph (ToGraph (..)) where +module Algebra.Graph.ToGraph ( + -- * Type class + ToGraph (..), -import Prelude () -import Prelude.Compat + -- * Derived functions + adjacencyMap, adjacencyIntMap, adjacencyMapTranspose, adjacencyIntMapTranspose + ) where + import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) @@ -54,14 +58,11 @@ import qualified Algebra.Graph as G import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM -import qualified Algebra.Graph.AdjacencyMap.Internal as AM import qualified Algebra.Graph.Labelled as LG import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM -import qualified Algebra.Graph.NonEmpty.AdjacencyMap.Internal as NAM import qualified Algebra.Graph.AdjacencyIntMap as AIM import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIM -import qualified Algebra.Graph.AdjacencyIntMap.Internal as AIM import qualified Algebra.Graph.Relation as R import qualified Algebra.Graph.Relation.Symmetric as SR import qualified Data.IntMap as IntMap @@ -104,19 +105,6 @@ isEmpty :: t -> Bool isEmpty = foldg True (const False) (&&) (&&) - -- | The /size/ of a graph, i.e. the number of leaves of the expression - -- including 'empty' leaves. - -- - -- __Note:__ The default implementation of this function violates the - -- requirement that the four arguments of 'foldg' should satisfy the laws - -- of algebraic graphs, since @1 + 1 /= 1@. Use this function with care. - -- - -- @ - -- size == 'foldg' 1 ('const' 1) (+) (+) - -- @ - size :: t -> Int - size = foldg 1 (const 1) (+) (+) - -- | Check if a graph contains a given vertex. -- -- @ @@ -234,44 +222,6 @@ adjacencyList :: Ord (ToVertex t) => t -> [(ToVertex t, [ToVertex t])] adjacencyList = AM.adjacencyList . toAdjacencyMap - -- | The /adjacency map/ of a graph: each vertex is associated with a set - -- of its /direct successors/. - -- - -- @ - -- adjacencyMap == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMap' - -- @ - adjacencyMap :: Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) - adjacencyMap = AM.adjacencyMap . toAdjacencyMap - - -- | The /adjacency map/ of a graph: each vertex is associated with a set - -- of its /direct successors/. Like 'adjacencyMap' but specialised for - -- graphs with vertices of type 'Int'. - -- - -- @ - -- adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMap' - -- @ - adjacencyIntMap :: ToVertex t ~ Int => t -> IntMap IntSet - adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap - - -- | The transposed /adjacency map/ of a graph: each vertex is associated - -- with a set of its /direct predecessors/. - -- - -- @ - -- adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMapTranspose' - -- @ - adjacencyMapTranspose :: Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) - adjacencyMapTranspose = AM.adjacencyMap . toAdjacencyMapTranspose - - -- | The transposed /adjacency map/ of a graph: each vertex is associated - -- with a set of its /direct predecessors/. Like 'adjacencyMapTranspose' but - -- specialised for graphs with vertices of type 'Int'. - -- - -- @ - -- adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMapTranspose' - -- @ - adjacencyIntMapTranspose :: ToVertex t ~ Int => t -> IntMap IntSet - adjacencyIntMapTranspose = AIM.adjacencyIntMap . toAdjacencyIntMapTranspose - -- | Compute the /depth-first search/ forest of a graph that corresponds to -- searching from each of the graph vertices in the 'Ord' @a@ order. -- @@ -310,13 +260,13 @@ reachable :: Ord (ToVertex t) => ToVertex t -> t -> [ToVertex t] reachable x = AM.reachable x . toAdjacencyMap - -- | Compute the /topological sort/ of a graph or return @Nothing@ if the + -- | Compute the /topological sort/ of a graph or a @AM.Cycle@ if the -- graph is cyclic. -- -- @ -- topSort == Algebra.Graph.AdjacencyMap.'AM.topSort' . toAdjacencyMap -- @ - topSort :: Ord (ToVertex t) => t -> Maybe [ToVertex t] + topSort :: Ord (ToVertex t) => t -> Either (AM.Cycle (ToVertex t)) [ToVertex t] topSort = AM.topSort . toAdjacencyMap -- | Check if a given graph is /acyclic/. @@ -405,11 +355,6 @@ adjacencyList = AM.adjacencyList preSet = AM.preSet postSet = AM.postSet - adjacencyMap = AM.adjacencyMap - adjacencyIntMap = IntMap.fromAscList - . map (fmap $ IntSet.fromAscList . Set.toAscList) - . Map.toAscList - . AM.adjacencyMap dfsForest = AM.dfsForest dfsForestFrom = AM.dfsForestFrom dfs = AM.dfs @@ -417,7 +362,7 @@ topSort = AM.topSort isAcyclic = AM.isAcyclic toAdjacencyMap = id - toAdjacencyIntMap = AIM.AM . adjacencyIntMap + toAdjacencyIntMap = AIM.fromAdjacencyMap toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap isDfsForestOf = AM.isDfsForestOf @@ -442,18 +387,13 @@ adjacencyList = AIM.adjacencyList preIntSet = AIM.preIntSet postIntSet = AIM.postIntSet - adjacencyMap = Map.fromAscList - . map (fmap $ Set.fromAscList . IntSet.toAscList) - . IntMap.toAscList - . AIM.adjacencyIntMap dfsForest = AIM.dfsForest dfsForestFrom = AIM.dfsForestFrom dfs = AIM.dfs reachable = AIM.reachable topSort = AIM.topSort isAcyclic = AIM.isAcyclic - adjacencyIntMap = AIM.adjacencyIntMap - toAdjacencyMap = AM.AM . adjacencyMap + toAdjacencyMap = AM.stars . AIM.adjacencyList toAdjacencyIntMap = id toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap @@ -499,34 +439,32 @@ -- | See "Algebra.Graph.NonEmpty.AdjacencyMap". instance Ord a => ToGraph (NAM.AdjacencyMap a) where type ToVertex (NAM.AdjacencyMap a) = a - toGraph = toGraph . NAM.am + toGraph = toGraph . toAdjacencyMap isEmpty _ = False hasVertex = NAM.hasVertex hasEdge = NAM.hasEdge vertexCount = NAM.vertexCount edgeCount = NAM.edgeCount - vertexList = vertexList . NAM.am + vertexList = vertexList . toAdjacencyMap vertexSet = NAM.vertexSet - vertexIntSet = vertexIntSet . NAM.am + vertexIntSet = vertexIntSet . toAdjacencyMap edgeList = NAM.edgeList edgeSet = NAM.edgeSet - adjacencyList = adjacencyList . NAM.am + adjacencyList = adjacencyList . toAdjacencyMap preSet = NAM.preSet postSet = NAM.postSet - adjacencyMap = adjacencyMap . NAM.am - adjacencyIntMap = adjacencyIntMap . NAM.am - dfsForest = dfsForest . NAM.am - dfsForestFrom xs = dfsForestFrom xs . NAM.am - dfs xs = dfs xs . NAM.am - reachable x = reachable x . NAM.am - topSort = topSort . NAM.am - isAcyclic = isAcyclic . NAM.am - toAdjacencyMap = NAM.am - toAdjacencyIntMap = toAdjacencyIntMap . NAM.am - toAdjacencyMapTranspose = NAM.am . NAM.transpose + dfsForest = dfsForest . toAdjacencyMap + dfsForestFrom xs = dfsForestFrom xs . toAdjacencyMap + dfs xs = dfs xs . toAdjacencyMap + reachable x = reachable x . toAdjacencyMap + topSort = topSort . toAdjacencyMap + isAcyclic = isAcyclic . toAdjacencyMap + toAdjacencyMap = NAM.fromNonEmpty + toAdjacencyIntMap = toAdjacencyIntMap . toAdjacencyMap + toAdjacencyMapTranspose = toAdjacencyMap . NAM.transpose toAdjacencyIntMapTranspose = toAdjacencyIntMap . NAM.transpose - isDfsForestOf f = isDfsForestOf f . NAM.am - isTopSortOf x = isTopSortOf x . NAM.am + isDfsForestOf f = isDfsForestOf f . toAdjacencyMap + isTopSortOf x = isTopSortOf x . toAdjacencyMap -- TODO: Get rid of "Relation.Internal" and move this instance to "Relation". -- | See "Algebra.Graph.Relation". @@ -545,14 +483,8 @@ edgeList = R.edgeList edgeSet = R.edgeSet adjacencyList = R.adjacencyList - adjacencyMap = Map.fromAscList - . map (fmap Set.fromAscList) - . R.adjacencyList - adjacencyIntMap = IntMap.fromAscList - . map (fmap IntSet.fromAscList) - . R.adjacencyList - toAdjacencyMap = AM.AM . adjacencyMap - toAdjacencyIntMap = AIM.AM . adjacencyIntMap + toAdjacencyMap = AM.stars . R.adjacencyList + toAdjacencyIntMap = AIM.stars . R.adjacencyList toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap @@ -574,9 +506,45 @@ edgeList = SR.edgeList edgeSet = SR.edgeSet adjacencyList = SR.adjacencyList - adjacencyMap = adjacencyMap . SR.fromSymmetric - adjacencyIntMap = adjacencyIntMap . SR.fromSymmetric - toAdjacencyMap = AM.AM . adjacencyMap - toAdjacencyIntMap = AIM.AM . adjacencyIntMap + toAdjacencyMap = toAdjacencyMap . SR.fromSymmetric + toAdjacencyIntMap = toAdjacencyIntMap . SR.fromSymmetric toAdjacencyMapTranspose = toAdjacencyMap toAdjacencyIntMapTranspose = toAdjacencyIntMap + +-- | The /adjacency map/ of a graph: each vertex is associated with a set of its +-- /direct successors/. +-- +-- @ +-- adjacencyMap == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMap' +-- @ +adjacencyMap :: ToGraph t => Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) +adjacencyMap = AM.adjacencyMap . toAdjacencyMap + +-- | The /adjacency map/ of a graph: each vertex is associated with a set of its +-- /direct successors/. Like 'adjacencyMap' but specialised for graphs with +-- vertices of type 'Int'. +-- +-- @ +-- adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMap' +-- @ +adjacencyIntMap :: (ToGraph t, ToVertex t ~ Int) => t -> IntMap IntSet +adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap + +-- | The transposed /adjacency map/ of a graph: each vertex is associated with a +-- set of its /direct predecessors/. +-- +-- @ +-- adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMapTranspose' +-- @ +adjacencyMapTranspose :: (ToGraph t, Ord (ToVertex t)) => t -> Map (ToVertex t) (Set (ToVertex t)) +adjacencyMapTranspose = AM.adjacencyMap . toAdjacencyMapTranspose + +-- | The transposed /adjacency map/ of a graph: each vertex is associated with a +-- set of its /direct predecessors/. Like 'adjacencyMapTranspose' but +-- specialised for graphs with vertices of type 'Int'. +-- +-- @ +-- adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMapTranspose' +-- @ +adjacencyIntMapTranspose :: (ToGraph t, ToVertex t ~ Int) => t -> IntMap IntSet +adjacencyIntMapTranspose = AIM.adjacencyIntMap . toAdjacencyIntMapTranspose diff --git a/src/Algebra/Graph/Undirected.hs b/src/Algebra/Graph/Undirected.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Undirected.hs @@ -0,0 +1,819 @@ +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Undirected +-- 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 for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines an undirected version of algebraic graphs. Undirected +-- graphs satisfy all laws of the 'Algebra.Graph.Class.Undirected' type class, +-- including the commutativity of 'connect'. +-- +-- To avoid name clashes with "Algebra.Graph", this module can be imported +-- qualified: +-- +-- @ +-- import qualified Algebra.Graph.Undirected as Undirected +-- @ + +----------------------------------------------------------------------------- +module Algebra.Graph.Undirected ( + -- * Algebraic data type for graphs + Graph, fromUndirected, toUndirected, + + -- * Basic graph construction primitives + empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, + + -- * Graph folding + foldg, + + -- * Relations on graphs + isSubgraphOf, toRelation, + + -- * Graph properties + isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, + edgeList, vertexSet, edgeSet, adjacencyList, neighbours, + + -- * Standard families of graphs + path, circuit, clique, biclique, star, stars, tree, forest, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, mergeVertices, induce, induceJust, + complement + ) where + +import Algebra.Graph.Internal +import Algebra.Graph.ToGraph (toGraph) +import Control.Applicative (Alternative) +import Control.DeepSeq +import Control.Monad +import Data.Coerce +import Data.List +import GHC.Generics +import Data.Set (Set) +import Data.Tree (Tree, Forest) + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Relation.Symmetric as R +import qualified Data.Set as Set + +-- TODO: Specialise the API for graphs with vertices of type 'Int'. + +{-| The 'Graph' data type provides the four algebraic graph construction +primitives 'empty', 'vertex', 'overlay' and 'connect', as well as various +derived functions. The only difference compared to the 'Algebra.Graph.Graph' +data type defined in "Algebra.Graph" is that the 'connect' operation is +/commutative/. We define a 'Num' instance as a convenient notation for working +with undirected graphs: + + > 0 == vertex 0 + > 1 + 2 == vertices [1,2] + > 1 * 2 == edge 1 2 + > 1 + 2 * 3 == overlay (vertex 1) (edge 2 3) + > 1 * (2 + 3) == edges [(1,2),(1,3)] + +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + +The 'Eq' instance is currently implemented using the 'R.Relation' 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, commutative 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 + +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 'Graph' 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 an undirected 'Graph' to the corresponding 'R.Relation' 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 +'edge' 1 2 == 'edge' 2 1@ + +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 Graph a = UG (G.Graph a) + deriving (Alternative, Applicative, Functor, Generic, Monad, MonadPlus, NFData) + +instance (Show a, Ord a) => Show (Graph a) where + show = show . toRelation + +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more +-- details. +instance Num a => Num (Graph a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance Ord a => Eq (Graph a) where + (==) = eqR + +instance Ord a => Ord (Graph a) where + compare = ordR + +-- TODO: Find a more efficient equality check. +-- Check if two graphs are equal by converting them to symmetric relations. +eqR :: Ord a => Graph a -> Graph a -> Bool +eqR x y = toRelation x == toRelation y + +-- TODO: Find a more efficient comparison. +-- Compare two graphs by converting them to their symmetric relations. +ordR :: Ord a => Graph a -> Graph a -> Ordering +ordR x y = compare (toRelation x) (toRelation y) + +-- | Construct an undirected graph from a given "Algebra.Graph". +-- Complexity: /O(1)/ time. +-- +-- @ +-- toUndirected ('Algebra.Graph.edge' 1 2) == 'edge' 1 2 +-- toUndirected . 'fromUndirected' == id +-- 'vertexCount' . toUndirected == 'Algebra.Graph.vertexCount' +-- (*2) . 'edgeCount' . toUndirected >= 'Algebra.Graph.edgeCount' +-- @ +toUndirected :: G.Graph a -> Graph a +toUndirected = coerce + +-- | Extract the underlying "Algebra.Graph". +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- fromUndirected ('Algebra.Graph.edge' 1 2) == 'Algebra.Graph.edges' [(1,2),(2,1)] +-- 'toUndirected' . 'fromUndirected' == id +-- 'Algebra.Graph.vertexCount' . fromUndirected == 'vertexCount' +-- 'Algebra.Graph.edgeCount' . fromUndirected <= (*2) . 'edgeCount' +-- @ +fromUndirected :: Ord a => Graph a -> G.Graph a +fromUndirected = toGraph . toRelation + +-- | 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 :: Graph a +empty = coerce00 G.empty +{-# INLINE empty #-} + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- 'size' (vertex x) == 1 +-- @ +vertex :: a -> Graph a +vertex = coerce10 G.vertex +{-# INLINE vertex #-} + +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- edge x y == 'edge' y x +-- edge x y == 'edges' [(x,y), (y,x)] +-- '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 -> Graph a +edge = coerce20 G.edge +{-# INLINE edge #-} + +-- | /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 :: Graph a -> Graph a -> Graph a +overlay = coerce20 G.overlay +{-# INLINE overlay #-} + +-- | /Connect/ two graphs. This is a commutative and 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)/. +-- +-- @ +-- 'connect' x y == 'connect' y x +-- '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 `div` 2 +-- 'size' (connect x y) == 'size' x + 'size' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Graph a -> Graph a -> Graph a +connect = coerce20 G.connect +{-# INLINE connect #-} + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- 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] -> Graph a +vertices = coerce10 G.vertices +{-# INLINE vertices #-} + +-- | Construct the graph from a list of edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- edges [] == 'empty' +-- edges [(x,y)] == 'edge' x y +-- edges [(x,y), (y,x)] == 'edge' x y +-- @ +edges :: [(a, a)] -> Graph a +edges = coerce10 G.edges +{-# 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. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: [Graph a] -> Graph a +overlays = coerce10 G.overlays +{-# 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. +-- +-- @ +-- connects [] == 'empty' +-- connects [x] == x +-- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' +-- 'isEmpty' . connects == 'all' 'isEmpty' +-- connects == connects . 'reverse' +-- @ +connects :: [Graph a] -> Graph a +connects = coerce10 G.connects +{-# INLINE 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') == id +-- foldg 1 ('const' 1) (+) (+) == 'size' +-- foldg True ('const' False) (&&) (&&) == 'isEmpty' +-- foldg False (== x) (||) (||) == 'hasVertex' x +-- @ +foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b +foldg = coerce G.foldg + where + coerce :: (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> G.Graph a -> b) + -> (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b) + coerce = Data.Coerce.coerce +{-# INLINE foldg #-} + +-- | 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 ('edge' x y) ('edge' y x) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool +isSubgraphOf x y = R.isSubgraphOf (toRelation x) (toRelation y) +{-# NOINLINE [1] isSubgraphOf #-} + +-- TODO: This is a very inefficient implementation. Find a way to construct a +-- symmetric relation directly, without building intermediate representations +-- for all subgraphs. +-- | Convert an undirected graph to a symmetric 'R.Relation'. +toRelation :: Ord a => Graph a -> R.Relation a +toRelation = foldg R.empty R.vertex R.overlay R.connect +{-# INLINE toRelation #-} + +-- | Check if a graph is empty. +-- 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 :: Graph a -> Bool +isEmpty = coerce01 G.isEmpty +{-# INLINE 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 :: Graph a -> Int +size = coerce01 G.size +{-# INLINE size #-} + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Eq a => a -> Graph a -> Bool +hasVertex = coerce11 G.hasVertex +{-# INLINE hasVertex #-} +{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} + +-- TODO: Optimise this further. +-- | 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 ('edge' y x) == True +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'elem' (min x y, max x y) . 'edgeList' +-- @ +hasEdge :: Eq a => a -> a -> Graph a -> Bool +hasEdge s t (UG g) = G.hasEdge s t g || G.hasEdge t s g +{-# INLINE hasEdge #-} +{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} + +-- | The number of vertices in a graph. +-- Complexity: /O(s * log(n))/ time. +-- +-- @ +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y +-- @ +vertexCount :: Ord a => Graph a -> Int +vertexCount = coerce01 G.vertexCount +{-# INLINE [1] 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 => Graph a -> Int +edgeCount = R.edgeCount . toRelation +{-# INLINE [1] 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 => Graph a -> [a] +vertexList = coerce01 G.vertexList +{-# INLINE [1] 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) == [(min x y, max y x)] +-- edgeList ('star' 2 [3,1]) == [(1,2), (2,3)] +-- @ +edgeList :: Ord a => Graph a -> [(a, a)] +edgeList = R.edgeList . toRelation +{-# INLINE [1] 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 => Graph a -> Set a +vertexSet = coerce01 G.vertexSet +{-# INLINE 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' ('min' x y, 'max' x y) +-- @ +edgeSet :: Ord a => Graph a -> Set (a, a) +edgeSet = R.edgeSet . toRelation +{-# INLINE [1] edgeSet #-} + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [1])] +-- adjacencyList ('star' 2 [3,1]) == [(1, [2]), (2, [1,3]), (3, [2])] +-- 'stars' . adjacencyList == id +-- @ +adjacencyList :: Ord a => Graph a -> [(a, [a])] +adjacencyList = R.adjacencyList . toRelation +{-# INLINE adjacencyList #-} +{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} + +-- | The set of vertices /adjacent/ to a given vertex. +-- +-- @ +-- neighbours x 'empty' == Set.'Set.empty' +-- neighbours x ('vertex' x) == Set.'Set.empty' +-- neighbours x ('edge' x y) == Set.'Set.fromList' [y] +-- neighbours y ('edge' x y) == Set.'Set.fromList' [x] +-- @ +neighbours :: Ord a => a -> Graph a -> Set a +neighbours x = R.neighbours x . toRelation +{-# INLINE neighbours #-} + +-- | 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' == path +-- @ +path :: [a] -> Graph a +path = coerce10 G.path +{-# INLINE path #-} + +-- | 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] == 'edge' (x,y) +-- circuit . 'reverse' == circuit +-- @ +circuit :: [a] -> Graph a +circuit = coerce10 G.circuit +{-# 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. +-- +-- @ +-- 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' == clique +-- @ +clique :: [a] -> Graph a +clique = coerce10 G.clique +{-# 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. +-- +-- @ +-- biclique [] [] == 'empty' +-- biclique [x] [] == 'vertex' x +-- biclique [] [y] == 'vertex' y +-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,x2), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) +-- @ +biclique :: [a] -> [a] -> Graph a +biclique = coerce20 G.biclique +{-# 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. +-- +-- @ +-- 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] -> Graph a +star = coerce20 G.star +{-# 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])] -> Graph a +stars = coerce10 G.stars +{-# INLINE stars #-} + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the +-- given tree (i.e. the number of vertices in the tree). +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ +tree :: Tree a -> Graph a +tree = coerce10 G.tree +{-# INLINE tree #-} + +-- | The /forest graph/ constructed from a given 'Forest' data structure. +-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the +-- given forest (i.e. the number of vertices in the forest). +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . 'map' 'tree' +-- @ +forest :: Forest a -> Graph a +forest = coerce10 G.forest +{-# INLINE forest #-} + +-- | 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 -> Graph a -> Graph a +removeVertex = coerce11 G.removeVertex +{-# INLINE removeVertex #-} +{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} + +-- TODO: Optimise by doing a single graph traversal. +-- | 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 == removeEdge y x +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Eq a => a -> a -> Graph a -> Graph a +removeEdge s t = Data.Coerce.coerce $ G.removeEdge s t . G.removeEdge t s +{-# INLINE removeEdge #-} +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'mergeVertices' (== x) y +-- @ +replaceVertex :: Eq a => a -> a -> Graph a -> Graph a +replaceVertex = coerce21 G.replaceVertex +{-# 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. +-- +-- @ +-- mergeVertices ('const' False) x == id +-- mergeVertices (== x) y == 'replaceVertex' x y +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 +-- @ +mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a +mergeVertices = coerce21 G.mergeVertices +{-# INLINE mergeVertices #-} + +-- 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. +-- +-- @ +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> Graph a -> Graph a +induce = coerce20 G.induce +{-# INLINE induce #-} + +-- | 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 (Maybe a) -> Graph a +induceJust = coerce10 G.induceJust +{-# INLINE induceJust #-} + +-- | The edge complement of a graph. Note that, as can be seen from the examples +-- below, this operation ignores self-loops. +-- Complexity: /O(n^2 * log n)/ time, /O(n^2)/ memory. +-- +-- @ +-- complement 'empty' == 'empty' +-- complement ('vertex' x) == ('vertex' x) +-- complement ('edge' 1 2) == ('vertices' [1, 2]) +-- complement ('edge' 0 0) == ('edge' 0 0) +-- complement ('star' 1 [2, 3]) == ('overlay' ('vertex' 1) ('edge' 2 3)) +-- complement . complement == id +-- @ +complement :: Ord a => Graph a -> Graph a +complement g = overlay (vertices vsOld) (edges $ Set.toAscList esNew) + where + vsOld = vertexList g + esOld = edgeSet g + loops = Set.filter (uncurry (==)) esOld + esAll = Set.fromAscList [ (x, y) | x:ys <- tails vsOld, y <- ys ] + esNew = Set.union loops (Set.difference esAll esOld) diff --git a/src/Data/Graph/Typed.hs b/src/Data/Graph/Typed.hs --- a/src/Data/Graph/Typed.hs +++ b/src/Data/Graph/Typed.hs @@ -19,21 +19,22 @@ GraphKL(..), fromAdjacencyMap, fromAdjacencyIntMap, -- * Basic algorithms - dfsForest, dfsForestFrom, dfs, topSort - ) where - -import Algebra.Graph.AdjacencyMap.Internal as AM -import Algebra.Graph.AdjacencyIntMap.Internal as AIM + dfsForest, dfsForestFrom, dfs, topSort, scc + ) where import Data.Tree import Data.Maybe +import Data.Foldable -import qualified Data.Graph as KL -import qualified Data.Map.Strict as Map -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Data.Graph as KL +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Algebra.Graph.AdjacencyIntMap as AIM + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + -- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in -- the "Data.Graph" module of the @containers@ library. data GraphKL a = GraphKL { @@ -46,25 +47,25 @@ -- Returns 'Nothing' if the argument is not in the graph. toVertexKL :: a -> Maybe KL.Vertex } --- | Build 'GraphKL' from an 'AdjacencyMap'. --- If @fromAdjacencyMap g == h@ then the following holds: +-- | Build 'GraphKL' from an 'AM.AdjacencyMap'. If @fromAdjacencyMap g == h@ +-- then the following holds: -- -- @ --- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.vertexList' g --- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.edgeList' g +-- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'AM.vertexList' g +-- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'AM.edgeList' g -- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] -- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] -- @ -fromAdjacencyMap :: Ord a => AdjacencyMap a -> GraphKL a -fromAdjacencyMap (AM.AM m) = GraphKL +fromAdjacencyMap :: Ord a => AM.AdjacencyMap a -> GraphKL a +fromAdjacencyMap am = GraphKL { toGraphKL = g , fromVertexKL = \u -> case r u of (_, v, _) -> v , toVertexKL = t } where - (g, r, t) = KL.graphFromEdges [ ((), v, Set.toAscList us) | (v, us) <- Map.toAscList m ] + (g, r, t) = KL.graphFromEdges [ ((), x, ys) | (x, ys) <- AM.adjacencyList am ] --- | Build 'GraphKL' from an 'AdjacencyIntMap'. --- If @fromAdjacencyIntMap g == h@ then the following holds: +-- | Build 'GraphKL' from an 'AIM.AdjacencyIntMap'. If +-- @fromAdjacencyIntMap g == h@ then the following holds: -- -- @ -- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Data.IntSet.toAscList' ('Algebra.Graph.AdjacencyIntMap.vertexIntSet' g) @@ -72,32 +73,33 @@ -- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] -- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] -- @ -fromAdjacencyIntMap :: AdjacencyIntMap -> GraphKL Int -fromAdjacencyIntMap (AIM.AM m) = GraphKL +fromAdjacencyIntMap :: AIM.AdjacencyIntMap -> GraphKL Int +fromAdjacencyIntMap aim = GraphKL { toGraphKL = g - , fromVertexKL = \u -> case r u of (_, v, _) -> v + , fromVertexKL = \x -> case r x of (_, v, _) -> v , toVertexKL = t } where - (g, r, t) = KL.graphFromEdges [ ((), v, IntSet.toAscList us) | (v, us) <- IntMap.toAscList m ] + (g, r, t) = KL.graphFromEdges [ ((), x, ys) | (x, ys) <- AIM.adjacencyList aim ] -- | Compute the /depth-first search/ forest of a graph. -- --- In the following we will use the helper function: +-- In the following examples we will use the helper function: -- -- @ --- (%) :: (GraphKL Int -> a) -> AM.AdjacencyMap Int -> a --- a % g = a $ fromAdjacencyMap g +-- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a +-- a % g = a $ 'fromAdjacencyMap' g -- @ --- for greater clarity. (One could use an AdjacencyIntMap just as well) -- +-- for greater clarity. +-- -- @ --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 1 1) == 'AM.vertex' 1 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.edge' 1 2 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 2 1) == 'AM.vertices' [1, 2] --- 'AM.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForest % x) x == True --- dfsForest % 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % x) == dfsForest % x +-- 'AM.forest' (dfsForest % 'AM.edge' 1 1) == 'AM.vertex' 1 +-- 'AM.forest' (dfsForest % 'AM.edge' 1 2) == 'AM.edge' 1 2 +-- 'AM.forest' (dfsForest % 'AM.edge' 2 1) == 'AM.vertices' [1, 2] +-- 'AM.isSubgraphOf' ('AM.forest' $ dfsForest % x) x == True +-- dfsForest % 'AM.forest' (dfsForest % x) == dfsForest % x -- dfsForest % 'AM.vertices' vs == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'Algebra.Graph.AdjacencyMap.dfsForestFrom' ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == dfsForest % x +-- 'AM.dfsForestFrom' ('AM.vertexList' x) % x == dfsForest % x -- dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] }]} @@ -112,15 +114,24 @@ -- the given vertices in order. Note that the resulting forest does not -- necessarily span the whole graph, as some vertices may be unreachable. -- +-- In the following examples we will use the helper function: +-- -- @ --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 1) == 'AM.vertex' 1 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.edge' 1 2 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'AM.vertex' 2 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [3] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'AM.empty' --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [2, 1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.vertices' [1, 2] --- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForestFrom vs % x) x == True --- dfsForestFrom ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == 'dfsForest' % x --- dfsForestFrom vs % 'Algebra.Graph.AdjacencyMap.vertices' vs == 'map' (\\v -> Node v []) ('Data.List.nub' vs) +-- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a +-- a % g = a $ 'fromAdjacencyMap' g +-- @ +-- +-- for greater clarity. +-- +-- @ +-- 'AM.forest' (dfsForestFrom [1] % 'AM.edge' 1 1) == 'AM.vertex' 1 +-- 'AM.forest' (dfsForestFrom [1] % 'AM.edge' 1 2) == 'AM.edge' 1 2 +-- 'AM.forest' (dfsForestFrom [2] % 'AM.edge' 1 2) == 'AM.vertex' 2 +-- 'AM.forest' (dfsForestFrom [3] % 'AM.edge' 1 2) == 'AM.empty' +-- 'AM.forest' (dfsForestFrom [2, 1] % 'AM.edge' 1 2) == 'AM.vertices' [1, 2] +-- 'AM.isSubgraphOf' ('AM.forest' $ dfsForestFrom vs % x) x == True +-- dfsForestFrom ('AM.vertexList' x) % x == 'dfsForest' % x +-- dfsForestFrom vs % 'AM.vertices' vs == 'map' (\\v -> Node v []) ('Data.List.nub' vs) -- dfsForestFrom [] % x == [] -- dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 @@ -131,30 +142,61 @@ dfsForestFrom :: [a] -> GraphKL a -> Forest a dfsForestFrom vs (GraphKL g r t) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) --- | Compute the list of vertices visited by the /depth-first search/ in a graph, --- when searching from each of the given vertices in order. +-- | Compute the list of vertices visited by the /depth-first search/ in a +-- graph, when searching from each of the given vertices in order. -- +-- In the following examples we will use the helper function: +-- -- @ --- dfs [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 1 == [1] --- dfs [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [1,2] --- dfs [2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [2] --- dfs [3] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [] --- dfs [1,2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [1,2] --- dfs [2,1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [2,1] +-- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a +-- a % g = a $ 'fromAdjacencyMap' g +-- @ +-- +-- for greater clarity. +-- +-- @ +-- dfs [1] % 'AM.edge' 1 1 == [1] +-- dfs [1] % 'AM.edge' 1 2 == [1,2] +-- dfs [2] % 'AM.edge' 1 2 == [2] +-- dfs [3] % 'AM.edge' 1 2 == [] +-- dfs [1,2] % 'AM.edge' 1 2 == [1,2] +-- dfs [2,1] % 'AM.edge' 1 2 == [2,1] -- dfs [] % x == [] --- dfs [1,4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] --- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.vertices' $ dfs vs x) x == True +-- dfs [1,4] % (3 * (1 + 4) * (1 + 5)) == [1,5,4] +-- 'AM.isSubgraphOf' ('AM.vertices' $ dfs vs x) x == True -- @ dfs :: [a] -> GraphKL a -> [a] dfs vs = concatMap flatten . dfsForestFrom vs --- | Compute the /topological sort/ of a graph. --- Unlike the (Int)AdjacencyMap algorithm this returns +-- | Compute the /topological sort/ of a graph. Note that this function returns -- a result even if the graph is cyclic. -- +-- In the following examples we will use the helper function: +-- -- @ +-- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a +-- a % g = a $ 'fromAdjacencyMap' g +-- @ +-- +-- for greater clarity. +-- +-- @ -- topSort % (1 * 2 + 3 * 1) == [3,1,2] -- topSort % (1 * 2 + 2 * 1) == [1,2] -- @ topSort :: GraphKL a -> [a] topSort (GraphKL g r _) = map r (KL.topSort g) + +scc :: Ord a => AM.AdjacencyMap a -> AM.AdjacencyMap (NonEmpty.AdjacencyMap a) +scc m = AM.gmap (component Map.!) $ removeSelfLoops $ AM.gmap (leader Map.!) m + where + GraphKL g decode _ = 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 $ AM.induce (`Set.member` s) m + where + s = Set.fromList (map decode xs) + +removeSelfLoops :: Ord a => AM.AdjacencyMap a -> AM.AdjacencyMap a +removeSelfLoops m = foldr (\x -> AM.removeEdge x x) m (AM.vertexList m) diff --git a/test/Algebra/Graph/Test.hs b/test/Algebra/Graph/Test.hs --- a/test/Algebra/Graph/Test.hs +++ b/test/Algebra/Graph/Test.hs @@ -1,4 +1,14 @@ {-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test +-- Copyright : (c) Andrey Mokhov 2016-2020 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Basic testsuite infrastructure. +----------------------------------------------------------------------------- module Algebra.Graph.Test ( module Data.List, module Data.List.Extra, @@ -6,7 +16,7 @@ module Test.QuickCheck.Function, GraphTestsuite, (//), axioms, theorems, undirectedAxioms, reflexiveAxioms, - transitiveAxioms, preorderAxioms, test, + transitiveAxioms, preorderAxioms, size10, test ) where import Data.List (sort) @@ -15,11 +25,14 @@ import System.Exit (exitFailure) import Test.QuickCheck hiding ((===)) import Test.QuickCheck.Function -import Test.QuickCheck.Test (isSuccess) import Algebra.Graph.Class import Algebra.Graph.Test.Arbitrary () +-- | Test a property only on small (at most size 10) inputs. +size10 :: Testable prop => prop -> Property +size10 = mapSize (min 10) + test :: Testable a => String -> a -> IO () test str p = do result <- quickCheckWithResult (stdArgs { chatty = False }) p @@ -43,50 +56,48 @@ infixl 6 + infixl 7 * -type GraphTestsuite g = g -> g -> g -> Property +type GraphTestsuite g = (Ord g, Graph g) => g -> g -> g -> Property -axioms :: (Eq g, Graph g) => GraphTestsuite g +axioms :: GraphTestsuite g axioms x y z = conjoin - [ x + y == y + x // "Overlay commutativity" - , x + (y + z) == (x + y) + z // "Overlay associativity" - , empty * x == x // "Left connect identity" - , x * empty == x // "Right connect identity" - , x * (y * z) == (x * y) * z // "Connect associativity" - , x * (y + z) == x * y + x * z // "Left distributivity" - , (x + y) * z == x * z + y * z // "Right distributivity" - , x * y * z == x * y + x * z + y * z // "Decomposition" ] + [ x + y == y + x // "Overlay commutativity" + , x + (y + z) == (x + y) + z // "Overlay associativity" + , empty * x == x // "Left connect identity" + , x * empty == x // "Right connect identity" + , x * (y * z) == (x * y) * z // "Connect associativity" + , x * (y + z) == x * y + x * z // "Left distributivity" + , (x + y) * z == x * z + y * z // "Right distributivity" + , x * y * z == x * y + x * z + y * z // "Decomposition" ] -theorems :: (Ord g, Graph g) => GraphTestsuite g +theorems :: GraphTestsuite g theorems x y z = conjoin - [ x + empty == x // "Overlay identity" - , x + x == x // "Overlay idempotence" - , x + y + x * y == x * y // "Absorption" + [ x + empty == x // "Overlay identity" + , x + x == x // "Overlay idempotence" + , x + y + x * y == x * y // "Absorption" , x * y * z == x * y + x * z + y * z - + x + y + z + empty // "Full decomposition" - , x * x == x * x * x // "Connect saturation" - , empty <= x // "Lower bound" - , x <= x + y // "Overlay order" - , x + y <= x * y // "Overlay-connect order" ] + + x + y + z + empty // "Full decomposition" + , x * x == x * x * x // "Connect saturation" + , empty <= x // "Lower bound" + , x <= x + y // "Overlay order" + , x + y <= x * y // "Overlay-connect order" ] -undirectedAxioms :: (Eq g, Graph g) => GraphTestsuite g +undirectedAxioms :: GraphTestsuite g undirectedAxioms x y z = conjoin [ axioms x y z - , x * y == y * x // "Connect commutativity" ] + , x * y == y * x // "Connect commutativity" ] -reflexiveAxioms :: (Eq g, Graph g, Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g +reflexiveAxioms :: forall g. (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g reflexiveAxioms x y z = conjoin [ axioms x y z - , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v) - // "Vertex self-loop" ] + , forAll arbitrary (\v -> vertex @g v == vertex v * vertex v) // "Vertex self-loop" ] -transitiveAxioms :: (Eq g, Graph g) => GraphTestsuite g +transitiveAxioms :: GraphTestsuite g transitiveAxioms x y z = conjoin [ axioms x y z - , y == empty || x * y * z == x * y + y * z // "Closure" ] + , y == empty || x * y * z == x * y + y * z // "Closure" ] -preorderAxioms :: (Eq g, Graph g, Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g +preorderAxioms :: forall g. (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g preorderAxioms x y z = conjoin [ axioms x y z - , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v) - // "Vertex self-loop" - , y == empty || x * y * z == x * y + y * z // "Closure" ] + , forAll arbitrary (\v -> vertex @g v == vertex v * vertex v) // "Vertex self-loop" + , y == empty || x * y * z == x * y + y * z // "Closure" ] diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -1,307 +1,660 @@ -{-# LANGUAGE ConstrainedClassMethods, RankNTypes #-} +{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, RecordWildCards #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.API --- 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 -- --- Graph manipulation API used for generic testing. +-- The complete graph API used for generic testing. ----------------------------------------------------------------------------- module Algebra.Graph.Test.API ( - -- * Graph manipulation API - GraphAPI (..) - ) where + -- * Graph API + API (..), Mono (..), toIntAPI, + -- * APIs of various graph data types + adjacencyMapAPI, adjacencyIntMapAPI, graphAPI, undirectedGraphAPI, relationAPI, + symmetricRelationAPI, labelledGraphAPI, labelledAdjacencyMapAPI + ) where + +import Data.Coerce +import Data.List.NonEmpty (NonEmpty) import Data.Monoid (Any) +import Data.IntMap (IntMap) import Data.IntSet (IntSet) +import Data.Map (Map) import Data.Set (Set) import Data.Tree +import Test.QuickCheck -import Algebra.Graph.Class (Graph (..)) +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Undirected as UG +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.Relation as R +import qualified Algebra.Graph.Relation.Symmetric as SR +import qualified Algebra.Graph.ToGraph as T -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Labelled as LG -import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM -import qualified Algebra.Graph.Fold as Fold -import qualified Algebra.Graph.HigherKinded.Class as HClass -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.Relation as R -import qualified Algebra.Graph.Relation.Symmetric as SR +import Algebra.Graph.Test.Arbitrary () -import qualified Algebra.Graph.AdjacencyMap.Internal as AMI -import qualified Algebra.Graph.AdjacencyIntMap.Internal as AIMI -import qualified Algebra.Graph.Relation.Internal as RI -import qualified Algebra.Graph.Relation.Symmetric.Internal as SRI +-- | A wrapper for monomorphic data types. We cannot use 'AIM.AdjacencyIntMap' +-- directly when defining an 'API', but we can if we wrap it into 'Mono'. +newtype Mono g a = Mono { getMono :: g } + deriving (Arbitrary, Eq, Num, Ord) -class Graph g => GraphAPI g where - consistent :: g -> Bool - consistent = notImplemented - edge :: Vertex g -> Vertex g -> g - edge = notImplemented - vertices :: [Vertex g] -> g - vertices = notImplemented - edges :: [(Vertex g, Vertex g)] -> g - edges = notImplemented - overlays :: [g] -> g - overlays = notImplemented - connects :: [g] -> g - connects = notImplemented - fromAdjacencySets :: [(Vertex g, Set (Vertex g))] -> g - fromAdjacencySets = notImplemented - fromAdjacencyIntSets :: [(Int, IntSet)] -> g - fromAdjacencyIntSets = notImplemented - isSubgraphOf :: g -> g -> Bool - isSubgraphOf = notImplemented - (===) :: g -> g -> Bool - (===) = notImplemented - neighbours :: Vertex g -> g -> Set (Vertex g) - neighbours = notImplemented - path :: [Vertex g] -> g - path = notImplemented - circuit :: [Vertex g] -> g - circuit = notImplemented - clique :: [Vertex g] -> g - clique = notImplemented - biclique :: [Vertex g] -> [Vertex g] -> g - biclique = notImplemented - star :: Vertex g -> [Vertex g] -> g - star = notImplemented - stars :: [(Vertex g, [Vertex g])] -> g - stars = notImplemented - tree :: Tree (Vertex g) -> g - tree = notImplemented - forest :: Forest (Vertex g) -> g - forest = notImplemented - mesh :: Vertex g ~ (a, b) => [a] -> [b] -> g - mesh = notImplemented - torus :: Vertex g ~ (a, b) => [a] -> [b] -> g - torus = notImplemented - deBruijn :: Vertex g ~ [a] => Int -> [a] -> g - deBruijn = notImplemented - removeVertex :: Vertex g -> g -> g - removeVertex = notImplemented - removeEdge :: Vertex g -> Vertex g -> g -> g - removeEdge = notImplemented - replaceVertex :: Vertex g -> Vertex g -> g -> g - replaceVertex = notImplemented - mergeVertices :: (Vertex g -> Bool) -> Vertex g -> g -> g - mergeVertices = notImplemented - splitVertex :: Vertex g -> [Vertex g] -> g -> g - splitVertex = notImplemented - transpose :: g -> g - transpose = notImplemented - gmap :: Vertex g ~ Int => (Int -> Int) -> g -> g - gmap = notImplemented - induce :: (Vertex g -> Bool) -> g -> g - induce = notImplemented - compose :: g -> g -> g - compose = notImplemented - closure :: g -> g - closure = notImplemented - reflexiveClosure :: g -> g - reflexiveClosure = notImplemented - symmetricClosure :: g -> g - symmetricClosure = notImplemented - transitiveClosure :: g -> g - transitiveClosure = notImplemented - bind :: Vertex g ~ Int => g -> (Int -> g) -> g - bind = notImplemented - simplify :: g -> g - simplify = notImplemented - box :: forall a b f. (Vertex (f a) ~ a, Vertex (f b) ~ b, Vertex (f (a, b)) ~ (a, b), g ~ f (a, b)) => f a -> f b -> f (a, b) - box = notImplemented +instance Show g => Show (Mono g a) where + show = show . getMono -notImplemented :: a -notImplemented = error "Not implemented" +-- | Convert a polymorphic API dictionary into a monomorphic 'Int' version. +toIntAPI :: API g Ord -> API g ((~) Int) +toIntAPI API{..} = API{..} -instance Ord a => GraphAPI (AM.AdjacencyMap a) where - consistent = AMI.consistent - edge = AM.edge - vertices = AM.vertices - edges = AM.edges - overlays = AM.overlays - connects = AM.connects - fromAdjacencySets = AM.fromAdjacencySets - isSubgraphOf = AM.isSubgraphOf - path = AM.path - circuit = AM.circuit - clique = AM.clique - biclique = AM.biclique - star = AM.star - stars = AM.stars - tree = AM.tree - forest = AM.forest - removeVertex = AM.removeVertex - removeEdge = AM.removeEdge - replaceVertex = AM.replaceVertex - mergeVertices = AM.mergeVertices - transpose = AM.transpose - gmap = AM.gmap - induce = AM.induce - compose = AM.compose - closure = AM.closure - reflexiveClosure = AM.reflexiveClosure - symmetricClosure = AM.symmetricClosure - transitiveClosure = AM.transitiveClosure +-- TODO: Add missing API entries for Acyclic, NonEmpty and Symmetric graphs. +-- | The complete graph API dictionary. A graph data type, such as 'G.Graph', +-- typically implements only a part of the whole API. +data API g c where + API :: ( Arbitrary (g Int), Num (g Int), Ord (g Int), Ord (g (Int, Int)) + , Ord (g (Int, Char)), Ord (g [Int]), Ord (g [Char]) + , Ord (g (Int, (Int, Int))), Ord (g ((Int, Int), Int)) + , Show (g Int)) => + { empty :: forall a. c a => g a + , vertex :: forall a. c a => a -> g a + , edge :: forall a. c a => a -> a -> g a + , overlay :: forall a. c a => g a -> g a -> g a + , connect :: forall a. c a => g a -> g a -> g a + , vertices :: forall a. c a => [a] -> g a + , edges :: forall a. c a => [(a, a)] -> g a + , overlays :: forall a. c a => [g a] -> g a + , connects :: forall a. c a => [g a] -> g a + , toGraph :: forall a. c a => g a -> G.Graph a + , foldg :: forall a. c a => forall r. r -> (a -> r) -> (r -> r -> r) -> (r -> r -> r) -> g a -> r + , isSubgraphOf :: forall a. c a => g a -> g a -> Bool + , structEq :: forall a. c a => g a -> g a -> Bool + , isEmpty :: forall a. c a => g a -> Bool + , size :: forall a. c a => g a -> Int + , hasVertex :: forall a. c a => a -> g a -> Bool + , hasEdge :: forall a. c a => a -> a -> g a -> Bool + , vertexCount :: forall a. c a => g a -> Int + , edgeCount :: forall a. c a => g a -> Int + , vertexList :: forall a. c a => g a -> [a] + , edgeList :: forall a. c a => g a -> [(a, a)] + , vertexSet :: forall a. c a => g a -> Set a + , vertexIntSet :: g Int -> IntSet + , edgeSet :: forall a. c a => g a -> Set (a, a) + , preSet :: forall a. c a => a -> g a -> Set a + , preIntSet :: Int -> g Int -> IntSet + , postSet :: forall a. c a => a -> g a -> Set a + , postIntSet :: Int -> g Int -> IntSet + , neighbours :: forall a. c a => a -> g a -> Set a + , adjacencyList :: forall a. c a => g a -> [(a, [a])] + , adjacencyMap :: forall a. c a => g a -> Map a (Set a) + , adjacencyIntMap :: g Int -> IntMap IntSet + , adjacencyMapTranspose :: forall a. c a => g a -> Map a (Set a) + , adjacencyIntMapTranspose :: g Int -> IntMap IntSet + , bfsForest :: forall a. c a => [a] -> g a -> Forest a + , bfs :: forall a. c a => [a] -> g a -> [[a]] + , dfsForest :: forall a. c a => g a -> Forest a + , dfsForestFrom :: forall a. c a => [a] -> g a -> Forest a + , dfs :: forall a. c a => [a] -> g a -> [a] + , reachable :: forall a. c a => a -> g a -> [a] + , topSort :: forall a. c a => g a -> Either (NonEmpty a) [a] + , isAcyclic :: forall a. c a => g a -> Bool + , toAdjacencyMap :: forall a. c a => g a -> AM.AdjacencyMap a + , toAdjacencyIntMap :: g Int -> AIM.AdjacencyIntMap + , toAdjacencyMapTranspose :: forall a. c a => g a -> AM.AdjacencyMap a + , toAdjacencyIntMapTranspose :: g Int -> AIM.AdjacencyIntMap + , isDfsForestOf :: forall a. c a => Forest a -> g a -> Bool + , isTopSortOf :: forall a. c a => [a] -> g a -> Bool + , path :: forall a. c a => [a] -> g a + , circuit :: forall a. c a => [a] -> g a + , clique :: forall a. c a => [a] -> g a + , biclique :: forall a. c a => [a] -> [a] -> g a + , star :: forall a. c a => a -> [a] -> g a + , stars :: forall a. c a => [(a, [a])] -> g a + , tree :: forall a. c a => Tree a -> g a + , forest :: forall a. c a => Forest a -> g a + , mesh :: forall a b. (c a, c b) => [a] -> [b] -> g (a, b) + , torus :: forall a b. (c a, c b) => [a] -> [b] -> g (a, b) + , deBruijn :: forall a. c a => Int -> [a] -> g [a] + , removeVertex :: forall a. c a => a -> g a -> g a + , removeEdge :: forall a. c a => a -> a -> g a -> g a + , replaceVertex :: forall a. c a => a -> a -> g a -> g a + , mergeVertices :: forall a. c a => (a -> Bool) -> a -> g a -> g a + , splitVertex :: forall a. c a => a -> [a] -> g a -> g a + , transpose :: forall a. c a => g a -> g a + , gmap :: forall a b. (c a, c b) => (a -> b) -> g a -> g b + , bind :: forall a b. (c a, c b) => g a -> (a -> g b) -> g b + , induce :: forall a. c a => (a -> Bool) -> g a -> g a + , induceJust :: forall a. c a => g (Maybe a) -> g a + , simplify :: forall a. c a => g a -> g a + , compose :: forall a. c a => g a -> g a -> g a + , box :: forall a b. (c a, c b) => g a -> g b -> g (a, b) + , closure :: forall a. c a => g a -> g a + , reflexiveClosure :: forall a. c a => g a -> g a + , symmetricClosure :: forall a. c a => g a -> g a + , transitiveClosure :: forall a. c a => g a -> g a + , consistent :: forall a. c a => g a -> Bool + , fromAdjacencySets :: forall a. c a => [(a, Set a)] -> g a + , fromAdjacencyIntSets :: [(Int, IntSet)] -> g Int } -> API g c -instance Ord a => GraphAPI (Fold.Fold a) where - edge = Fold.edge - vertices = Fold.vertices - edges = Fold.edges - overlays = Fold.overlays - connects = Fold.connects - isSubgraphOf = Fold.isSubgraphOf - path = Fold.path - circuit = Fold.circuit - clique = Fold.clique - biclique = Fold.biclique - star = Fold.star - stars = Fold.stars - tree = HClass.tree - forest = HClass.forest - mesh = HClass.mesh - torus = HClass.torus - deBruijn = HClass.deBruijn - removeVertex = Fold.removeVertex - removeEdge = Fold.removeEdge - replaceVertex = HClass.replaceVertex - mergeVertices = HClass.mergeVertices - splitVertex = HClass.splitVertex - transpose = Fold.transpose - gmap = fmap - induce = Fold.induce - bind = (>>=) - simplify = Fold.simplify +-- | The API of 'AM.AdjacencyMap'. +adjacencyMapAPI :: API AM.AdjacencyMap Ord +adjacencyMapAPI = API + { empty = AM.empty + , vertex = AM.vertex + , edge = AM.edge + , overlay = AM.overlay + , connect = AM.connect + , vertices = AM.vertices + , edges = AM.edges + , overlays = AM.overlays + , connects = AM.connects + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = AM.isSubgraphOf + , isEmpty = AM.isEmpty + , size = G.size . T.toGraph + , hasVertex = AM.hasVertex + , hasEdge = AM.hasEdge + , vertexCount = AM.vertexCount + , edgeCount = AM.edgeCount + , vertexList = AM.vertexList + , edgeList = AM.edgeList + , vertexSet = AM.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = AM.edgeSet + , preSet = AM.preSet + , preIntSet = T.preIntSet + , postSet = AM.postSet + , postIntSet = T.postIntSet + , adjacencyList = AM.adjacencyList + , adjacencyMap = AM.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , bfsForest = AM.bfsForest + , bfs = AM.bfs + , dfsForest = AM.dfsForest + , dfsForestFrom = AM.dfsForestFrom + , dfs = AM.dfs + , reachable = AM.reachable + , topSort = AM.topSort + , isAcyclic = AM.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = AM.isDfsForestOf + , isTopSortOf = AM.isTopSortOf + , path = AM.path + , circuit = AM.circuit + , clique = AM.clique + , biclique = AM.biclique + , star = AM.star + , stars = AM.stars + , tree = AM.tree + , forest = AM.forest + , removeVertex = AM.removeVertex + , removeEdge = AM.removeEdge + , replaceVertex = AM.replaceVertex + , mergeVertices = AM.mergeVertices + , transpose = AM.transpose + , gmap = AM.gmap + , induce = AM.induce + , induceJust = AM.induceJust + , compose = AM.compose + , box = AM.box + , closure = AM.closure + , reflexiveClosure = AM.reflexiveClosure + , symmetricClosure = AM.symmetricClosure + , transitiveClosure = AM.transitiveClosure + , consistent = AM.consistent + , fromAdjacencySets = AM.fromAdjacencySets } -instance Ord a => GraphAPI (G.Graph a) where - edge = G.edge - vertices = G.vertices - edges = G.edges - overlays = G.overlays - connects = G.connects - isSubgraphOf = G.isSubgraphOf - (===) = (G.===) - path = G.path - circuit = G.circuit - clique = G.clique - biclique = G.biclique - star = G.star - stars = G.stars - tree = G.tree - forest = G.forest - mesh = G.mesh - torus = G.torus - deBruijn = G.deBruijn - removeVertex = G.removeVertex - removeEdge = G.removeEdge - replaceVertex = G.replaceVertex - mergeVertices = G.mergeVertices - splitVertex = G.splitVertex - transpose = G.transpose - gmap = fmap - induce = G.induce - compose = G.compose - bind = (>>=) - simplify = G.simplify - box = G.box +-- | The API of 'G.Graph'. +graphAPI :: API G.Graph Ord +graphAPI = API + { empty = G.empty + , vertex = G.vertex + , edge = G.edge + , overlay = G.overlay + , connect = G.connect + , vertices = G.vertices + , edges = G.edges + , overlays = G.overlays + , connects = G.connects + , toGraph = id + , foldg = G.foldg + , isSubgraphOf = G.isSubgraphOf + , structEq = (G.===) + , isEmpty = G.isEmpty + , size = G.size + , hasVertex = G.hasVertex + , hasEdge = G.hasEdge + , vertexCount = G.vertexCount + , edgeCount = G.edgeCount + , vertexList = G.vertexList + , edgeList = G.edgeList + , vertexSet = G.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = G.edgeSet + , preSet = T.preSet + , preIntSet = T.preIntSet + , postSet = T.postSet + , postIntSet = T.postIntSet + , adjacencyList = G.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , path = G.path + , circuit = G.circuit + , clique = G.clique + , biclique = G.biclique + , star = G.star + , stars = G.stars + , tree = G.tree + , forest = G.forest + , mesh = G.mesh + , torus = G.torus + , deBruijn = G.deBruijn + , removeVertex = G.removeVertex + , removeEdge = G.removeEdge + , replaceVertex = G.replaceVertex + , mergeVertices = G.mergeVertices + , splitVertex = G.splitVertex + , transpose = G.transpose + , gmap = fmap + , bind = (>>=) + , induce = G.induce + , induceJust = G.induceJust + , simplify = G.simplify + , compose = G.compose + , box = G.box } -instance GraphAPI AIM.AdjacencyIntMap where - consistent = AIMI.consistent - edge = AIM.edge - vertices = AIM.vertices - edges = AIM.edges - overlays = AIM.overlays - connects = AIM.connects - fromAdjacencyIntSets = AIM.fromAdjacencyIntSets - isSubgraphOf = AIM.isSubgraphOf - path = AIM.path - circuit = AIM.circuit - clique = AIM.clique - biclique = AIM.biclique - star = AIM.star - stars = AIM.stars - tree = AIM.tree - forest = AIM.forest - removeVertex = AIM.removeVertex - removeEdge = AIM.removeEdge - replaceVertex = AIM.replaceVertex - mergeVertices = AIM.mergeVertices - transpose = AIM.transpose - gmap = AIM.gmap - induce = AIM.induce - compose = AIM.compose - closure = AIM.closure - reflexiveClosure = AIM.reflexiveClosure - symmetricClosure = AIM.symmetricClosure - transitiveClosure = AIM.transitiveClosure +-- | The API of 'UG.Graph'. +undirectedGraphAPI :: API UG.Graph Ord +undirectedGraphAPI = API + { empty = UG.empty + , vertex = UG.vertex + , edge = UG.edge + , overlay = UG.overlay + , connect = UG.connect + , vertices = UG.vertices + , edges = UG.edges + , overlays = UG.overlays + , connects = UG.connects + , toGraph = UG.fromUndirected + , foldg = UG.foldg + , isSubgraphOf = UG.isSubgraphOf + , isEmpty = UG.isEmpty + , size = UG.size + , hasVertex = UG.hasVertex + , hasEdge = UG.hasEdge + , vertexCount = UG.vertexCount + , edgeCount = UG.edgeCount + , vertexList = UG.vertexList + , edgeList = UG.edgeList + , vertexSet = UG.vertexSet + , edgeSet = UG.edgeSet + , neighbours = UG.neighbours + , adjacencyList = UG.adjacencyList + , path = UG.path + , circuit = UG.circuit + , clique = UG.clique + , biclique = UG.biclique + , star = UG.star + , stars = UG.stars + , tree = UG.tree + , forest = UG.forest + , removeVertex = UG.removeVertex + , removeEdge = UG.removeEdge + , replaceVertex = UG.replaceVertex + , mergeVertices = UG.mergeVertices + , transpose = id + , gmap = fmap + , induce = UG.induce + , induceJust = UG.induceJust } -instance Ord a => GraphAPI (R.Relation a) where - consistent = RI.consistent - edge = R.edge - vertices = R.vertices - edges = R.edges - overlays = R.overlays - connects = R.connects - isSubgraphOf = R.isSubgraphOf - path = R.path - circuit = R.circuit - clique = R.clique - biclique = R.biclique - star = R.star - stars = R.stars - tree = R.tree - forest = R.forest - removeVertex = R.removeVertex - removeEdge = R.removeEdge - replaceVertex = R.replaceVertex - mergeVertices = R.mergeVertices - transpose = R.transpose - gmap = R.gmap - induce = R.induce - compose = R.compose - closure = R.closure - reflexiveClosure = R.reflexiveClosure - symmetricClosure = R.symmetricClosure - transitiveClosure = R.transitiveClosure +-- | The API of 'AIM.AdjacencyIntMap'. +adjacencyIntMapAPI :: API (Mono AIM.AdjacencyIntMap) ((~) Int) +adjacencyIntMapAPI = API + { empty = coerce AIM.empty + , vertex = coerce AIM.vertex + , edge = coerce AIM.edge + , overlay = coerce AIM.overlay + , connect = coerce AIM.connect + , vertices = coerce AIM.vertices + , edges = coerce AIM.edges + , overlays = coerce AIM.overlays + , connects = coerce AIM.connects + , toGraph = T.toGraph . getMono + , foldg = \e v o c -> T.foldg e v o c . getMono + , isSubgraphOf = coerce AIM.isSubgraphOf + , isEmpty = coerce AIM.isEmpty + , size = G.size . T.toGraph . getMono + , hasVertex = coerce AIM.hasVertex + , hasEdge = coerce AIM.hasEdge + , vertexCount = coerce AIM.vertexCount + , edgeCount = coerce AIM.edgeCount + , vertexList = coerce AIM.vertexList + , edgeList = coerce AIM.edgeList + , vertexSet = T.vertexSet . getMono + , vertexIntSet = coerce AIM.vertexIntSet + , edgeSet = coerce AIM.edgeSet + , preSet = \x -> T.preSet x . getMono + , preIntSet = coerce AIM.preIntSet + , postSet = \x -> T.postSet x . getMono + , postIntSet = coerce AIM.postIntSet + , adjacencyList = coerce AIM.adjacencyList + , adjacencyMap = T.adjacencyMap . getMono + , adjacencyIntMap = coerce AIM.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose . getMono + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose . getMono + , bfsForest = coerce AIM.bfsForest + , bfs = coerce AIM.bfs + , dfsForest = coerce AIM.dfsForest + , dfsForestFrom = coerce AIM.dfsForestFrom + , dfs = coerce AIM.dfs + , reachable = coerce AIM.reachable + , topSort = coerce AIM.topSort + , isAcyclic = coerce AIM.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap . getMono + , toAdjacencyIntMap = T.toAdjacencyIntMap . getMono + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose . getMono + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose . getMono + , isDfsForestOf = coerce AIM.isDfsForestOf + , isTopSortOf = coerce AIM.isTopSortOf + , path = coerce AIM.path + , circuit = coerce AIM.circuit + , clique = coerce AIM.clique + , biclique = coerce AIM.biclique + , star = coerce AIM.star + , stars = coerce AIM.stars + , tree = coerce AIM.tree + , forest = coerce AIM.forest + , removeVertex = coerce AIM.removeVertex + , removeEdge = coerce AIM.removeEdge + , replaceVertex = coerce AIM.replaceVertex + , mergeVertices = coerce AIM.mergeVertices + , transpose = coerce AIM.transpose + , gmap = coerce AIM.gmap + , induce = coerce AIM.induce + , compose = coerce AIM.compose + , closure = coerce AIM.closure + , reflexiveClosure = coerce AIM.reflexiveClosure + , symmetricClosure = coerce AIM.symmetricClosure + , transitiveClosure = coerce AIM.transitiveClosure + , consistent = coerce AIM.consistent + , fromAdjacencyIntSets = coerce AIM.fromAdjacencyIntSets } -instance Ord a => GraphAPI (SR.Relation a) where - consistent = SRI.consistent - edge = SR.edge - vertices = SR.vertices - edges = SR.edges - overlays = SR.overlays - connects = SR.connects - isSubgraphOf = SR.isSubgraphOf - neighbours = SR.neighbours - path = SR.path - circuit = SR.circuit - clique = SR.clique - biclique = SR.biclique - star = SR.star - stars = SR.stars - tree = SR.tree - forest = SR.forest - removeVertex = SR.removeVertex - removeEdge = SR.removeEdge - replaceVertex = SR.replaceVertex - mergeVertices = SR.mergeVertices - transpose = id - gmap = SR.gmap - induce = SR.induce +-- | The API of 'R.Relation'. +relationAPI :: API R.Relation Ord +relationAPI = API + { empty = R.empty + , vertex = R.vertex + , edge = R.edge + , overlay = R.overlay + , connect = R.connect + , vertices = R.vertices + , edges = R.edges + , overlays = R.overlays + , connects = R.connects + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = R.isSubgraphOf + , isEmpty = R.isEmpty + , size = G.size . T.toGraph + , hasVertex = R.hasVertex + , hasEdge = R.hasEdge + , vertexCount = R.vertexCount + , edgeCount = R.edgeCount + , vertexList = R.vertexList + , edgeList = R.edgeList + , vertexSet = R.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = R.edgeSet + , preSet = R.preSet + , preIntSet = T.preIntSet + , postSet = R.postSet + , postIntSet = T.postIntSet + , adjacencyList = R.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , path = R.path + , circuit = R.circuit + , clique = R.clique + , biclique = R.biclique + , star = R.star + , stars = R.stars + , tree = R.tree + , forest = R.forest + , removeVertex = R.removeVertex + , removeEdge = R.removeEdge + , replaceVertex = R.replaceVertex + , mergeVertices = R.mergeVertices + , transpose = R.transpose + , gmap = R.gmap + , induce = R.induce + , induceJust = R.induceJust + , compose = R.compose + , closure = R.closure + , reflexiveClosure = R.reflexiveClosure + , symmetricClosure = R.symmetricClosure + , transitiveClosure = R.transitiveClosure + , consistent = R.consistent } -instance Ord a => GraphAPI (LG.Graph Any a) where - vertices = LG.vertices - overlays = LG.overlays - isSubgraphOf = LG.isSubgraphOf - removeVertex = LG.removeVertex - induce = LG.induce +-- | The API of 'SR.Relation'. +symmetricRelationAPI :: API SR.Relation Ord +symmetricRelationAPI = API + { empty = SR.empty + , vertex = SR.vertex + , edge = SR.edge + , overlay = SR.overlay + , connect = SR.connect + , vertices = SR.vertices + , edges = SR.edges + , overlays = SR.overlays + , connects = SR.connects + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = SR.isSubgraphOf + , isEmpty = SR.isEmpty + , size = G.size . T.toGraph + , hasVertex = SR.hasVertex + , hasEdge = SR.hasEdge + , vertexCount = SR.vertexCount + , edgeCount = SR.edgeCount + , vertexList = SR.vertexList + , edgeList = SR.edgeList + , vertexSet = SR.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = SR.edgeSet + , preSet = T.preSet + , preIntSet = T.preIntSet + , postSet = T.postSet + , postIntSet = T.postIntSet + , neighbours = SR.neighbours + , adjacencyList = SR.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , path = SR.path + , circuit = SR.circuit + , clique = SR.clique + , biclique = SR.biclique + , star = SR.star + , stars = SR.stars + , tree = SR.tree + , forest = SR.forest + , removeVertex = SR.removeVertex + , removeEdge = SR.removeEdge + , replaceVertex = SR.replaceVertex + , mergeVertices = SR.mergeVertices + , transpose = id + , gmap = SR.gmap + , induce = SR.induce + , induceJust = SR.induceJust + , consistent = SR.consistent } -instance Ord a => GraphAPI (LAM.AdjacencyMap Any a) where - vertices = LAM.vertices - overlays = LAM.overlays - isSubgraphOf = LAM.isSubgraphOf - removeVertex = LAM.removeVertex - induce = LAM.induce +-- | The API of 'LG.Graph'. +labelledGraphAPI :: API (LG.Graph Any) Ord +labelledGraphAPI = API + { empty = LG.empty + , vertex = LG.vertex + , edge = LG.edge mempty + , overlay = LG.overlay + , connect = LG.connect mempty + , vertices = LG.vertices + , edges = LG.edges . map (\(x, y) -> (mempty, x, y)) + , overlays = LG.overlays + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = LG.isSubgraphOf + , isEmpty = LG.isEmpty + , size = LG.size + , hasVertex = LG.hasVertex + , hasEdge = LG.hasEdge + , vertexCount = T.vertexCount + , edgeCount = T.edgeCount + , vertexList = LG.vertexList + , edgeList = T.edgeList + , vertexSet = LG.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = T.edgeSet + , preSet = T.preSet + , preIntSet = T.preIntSet + , postSet = T.postSet + , postIntSet = T.postIntSet + , adjacencyList = T.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , removeVertex = LG.removeVertex + , removeEdge = LG.removeEdge + , replaceVertex = LG.replaceVertex + , transpose = LG.transpose + , gmap = fmap + , induce = LG.induce + , induceJust = LG.induceJust + , closure = LG.closure + , reflexiveClosure = LG.reflexiveClosure + , symmetricClosure = LG.symmetricClosure + , transitiveClosure = LG.transitiveClosure } + +-- | The API of 'LAM.AdjacencyMap'. +labelledAdjacencyMapAPI :: API (LAM.AdjacencyMap Any) Ord +labelledAdjacencyMapAPI = API + { empty = LAM.empty + , vertex = LAM.vertex + , edge = LAM.edge mempty + , overlay = LAM.overlay + , connect = LAM.connect mempty + , vertices = LAM.vertices + , edges = LAM.edges . map (\(x, y) -> (mempty, x, y)) + , overlays = LAM.overlays + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = LAM.isSubgraphOf + , isEmpty = LAM.isEmpty + , size = G.size . T.toGraph + , hasVertex = LAM.hasVertex + , hasEdge = LAM.hasEdge + , vertexCount = LAM.vertexCount + , edgeCount = LAM.edgeCount + , vertexList = LAM.vertexList + , edgeList = T.edgeList + , vertexSet = LAM.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = T.edgeSet + , preSet = LAM.preSet + , preIntSet = T.preIntSet + , postSet = LAM.postSet + , postIntSet = T.postIntSet + , adjacencyList = T.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , removeVertex = LAM.removeVertex + , removeEdge = LAM.removeEdge + , replaceVertex = LAM.replaceVertex + , transpose = LAM.transpose + , gmap = LAM.gmap + , induce = LAM.induce + , induceJust = LAM.induceJust + , closure = LAM.closure + , reflexiveClosure = LAM.reflexiveClosure + , symmetricClosure = LAM.symmetricClosure + , transitiveClosure = LAM.transitiveClosure + , consistent = LAM.consistent } diff --git a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE OverloadedLists, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Acyclic.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2019 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Acyclic.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Acyclic.AdjacencyMap (testAcyclicAdjacencyMap) where + +import Algebra.Graph.Acyclic.AdjacencyMap +import Algebra.Graph.Internal +import Algebra.Graph.Test hiding (shrink) + +import Data.Bifunctor +import Data.Tuple + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.Set as Set + +type AAI = AdjacencyMap Int +type AI = AM.AdjacencyMap Int + +-- TODO: Switch to using generic tests. +testAcyclicAdjacencyMap :: IO () +testAcyclicAdjacencyMap = do + putStrLn "\n============ Acyclic.AdjacencyMap.Show ============" + test "show empty == \"empty\"" $ + show (empty :: AAI) == "empty" + + test "show (shrink 1) == \"vertex 1\"" $ + show (shrink 1 :: AAI) == "vertex 1" + + test "show (shrink $ 1 + 2) == \"vertices [1,2]\"" $ + show (shrink $ 1 + 2 :: AAI) == "vertices [1,2]" + + test "show (shrink $ 1 * 2) == \"(fromJust . toAcyclic) (edge 1 2)\"" $ + show (shrink $ 1 * 2 :: AAI) == "(fromJust . toAcyclic) (edge 1 2)" + + test "show (shrink $ 1 * 2 * 3) == \"(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])\"" $ + show (shrink $ 1 * 2 * 3 :: AAI) == "(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])" + + test "show (shrink $ 1 * 2 + 3) == \"(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))\"" $ + show (shrink $ 1 * 2 + 3 :: AAI) == "(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))" + + putStrLn "\n============ Acyclic.AdjacencyMap.fromAcyclic ============" + test "fromAcyclic empty == empty" $ + fromAcyclic (empty :: AAI) == AM.empty + + test "fromAcyclic . vertex == vertex" $ \(x :: Int) -> + (fromAcyclic . vertex) x == AM.vertex x + + test "fromAcyclic (shrink $ 1 * 3 * 2) == star 1 [2,3]" $ + fromAcyclic (shrink $ 1 * 3 + 2) == 1 * 3 + (2 :: AI) + + test "vertexCount . fromAcyclic == vertexCount" $ \(x :: AAI) -> + (AM.vertexCount . fromAcyclic) x == vertexCount x + + test "edgeCount . fromAcyclic == edgeCount" $ \(x :: AAI) -> + (AM.edgeCount . fromAcyclic) x == edgeCount x + + test "isAcyclic . fromAcyclic == const True" $ \(x :: AAI) -> + (AM.isAcyclic . fromAcyclic) x == const True x + + putStrLn "\n============ Acyclic.AdjacencyMap.empty ============" + test "isEmpty empty == True" $ + isEmpty (empty :: AAI) == True + + test "hasVertex x empty == False" $ \x -> + hasVertex x (empty :: AAI) == False + + test "vertexCount empty == 0" $ + vertexCount (empty :: AAI) == 0 + + test "edgeCount empty == 0" $ + edgeCount (empty :: AAI) == 0 + + putStrLn "\n============ Acyclic.AdjacencyMap.vertex ============" + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + putStrLn "\n============ Acyclic.AdjacencyMap.vertices ============" + test "vertices [] == empty" $ + vertices [] == (empty :: AAI) + + test "vertices [x] == vertex x" $ \(x :: Int) -> + vertices [x] == vertex x + + test "hasVertex x . vertices == elem x" $ \(x :: Int) xs -> + (hasVertex x . vertices) xs == elem x xs + + test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> + (vertexCount . vertices) xs == (length . nubOrd) xs + + test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> + (vertexSet . vertices) xs == Set.fromList xs + + putStrLn "\n============ Acyclic.AdjacencyMap.union ============" + test "vertexSet (union x y) == " $ \(x :: AAI) (y :: AAI) -> + vertexSet (union x y) == Set.unions ([ Set.map Left (vertexSet x) + , Set.map Right (vertexSet y) ] ++ []) + + test "edgeSet (union x y) == " $ \(x :: AAI) (y :: AAI) -> + edgeSet (union x y) == Set.unions ([ Set.map (bimap Left Left ) (edgeSet x) + , Set.map (bimap Right Right) (edgeSet y) ] ++ []) + + putStrLn "\n============ Acyclic.AdjacencyMap.join ============" + test "vertexSet (join x y) == " $ \(x :: AAI) (y :: AAI) -> + vertexSet (join x y) == Set.unions ([ Set.map Left (vertexSet x) + , Set.map Right (vertexSet y) ] ++ []) + + test "edgeSet (join x y) == " $ \(x :: AAI) (y :: AAI) -> + edgeSet (join x y) == Set.unions ([ Set.map (bimap Left Left ) (edgeSet x) + , Set.map (bimap Right Right) (edgeSet y) + , Set.map (bimap Left Right) (setProduct (vertexSet x) (vertexSet y)) ] ++ []) + + putStrLn "\n============ Acyclic.AdjacencyMap.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: AAI) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x) empty == False + + test "isSubgraphOf (induce p x) x == True" $ \(x :: AAI) (apply -> p) -> + isSubgraphOf (induce p x) x == True + + test "isSubgraphOf x (transitiveClosure x) == True" $ \(x :: AAI) -> + isSubgraphOf x (transitiveClosure x) == True + + test "isSubgraphOf x y ==> x <= y" $ \(x :: AAI) z -> + let connect x y = shrink $ fromAcyclic x + fromAcyclic y + -- TODO: Make the precondition stronger + y = connect x (vertices z) -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Acyclic.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty (empty :: AAI) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge 1 2 $ shrink $ 1 * 2) == False" $ + isEmpty (removeEdge 1 2 $ shrink $ 1 * 2 :: AAI) == False + + putStrLn "\n============ Acyclic.AdjacencyMap.hasVertex ============" + test "hasVertex x empty == False" $ \(x :: Int) -> + hasVertex x empty == False + + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> + (hasVertex x . removeVertex x) y == const False y + + putStrLn "\n============ Acyclic.AdjacencyMap.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y empty == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False + + test "hasEdge 1 2 (shrink $ 1 * 2) == True" $ + hasEdge 1 2 (shrink $ 1 * 2 :: AAI) == True + + test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (u, v) (edgeList z) + + putStrLn "\n============ Acyclic.AdjacencyMap.vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount (empty :: AAI) == 0 + + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "vertexCount == length . vertexList" $ \(x :: AAI) -> + vertexCount x == (length . vertexList) x + + test "vertexCount x < vertexCount y ==> x < y" $ \(x :: AAI) y -> + if vertexCount x < vertexCount y + then property (x < y) + else (vertexCount x > vertexCount y ==> x > y) + + putStrLn "\n============ Acyclic.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount (empty :: AAI) == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (shrink $ 1 * 2) == 1" $ + edgeCount (shrink $ 1 * 2 :: AAI) == 1 + + test "edgeCount == length . edgeList" $ \(x :: AAI) -> + edgeCount x == (length . edgeList) x + + putStrLn "\n============ Acyclic.AdjacencyMap.vertexList ============" + test "vertexList empty == []" $ + vertexList (empty :: AAI) == [] + + test "vertexList (vertex x) == [x]" $ \(x :: Int) -> + vertexList (vertex x) == [x] + + test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> + (vertexList . vertices) xs == (nubOrd . sort) xs + + putStrLn "\n============ Acyclic.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: AAI) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x) == [] + + test "edgeList (shrink $ 2 * 1) == [(2,1)]" $ + edgeList (shrink $ 2 * 1 :: AAI) == [(2,1)] + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn "\n============ Acyclic.AdjacencyMap.adjacencyList ============" + test "adjacencyList empty == []" $ + adjacencyList (empty :: AAI) == [] + + test "adjacencyList (vertex x) == [(x, [])]" $ \(x :: Int) -> + adjacencyList (vertex x) == [(x, [])] + + test "adjacencyList (shrink $ 1 * 2) == [(1, [2]), (2, [])]" $ + adjacencyList (shrink $ 1 * 2 :: AAI) == [(1, [2]), (2, [])] + + putStrLn "\n============ Acyclic.AdjacencyMap.vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet (empty :: AAI) == Set.empty + + test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> + (vertexSet . vertex) x == Set.singleton x + + test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> + (vertexSet . vertices) xs == Set.fromList xs + + putStrLn "\n============ Acyclic.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: AAI) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x) == Set.empty + + test "edgeSet (shrink $ 1 * 2) == Set.singleton (1,2)" $ + edgeSet (shrink $ 1 * 2 :: AAI) == Set.singleton (1,2) + + putStrLn "\n============ Acyclic.AdjacencyMap.preSet ============" + test "preSet x empty == Set.empty" $ \(x :: Int) -> + preSet x empty == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \(x :: Int) -> + preSet x (vertex x) == Set.empty + + test "preSet 1 (shrink $ 1 * 2) == Set.empty" $ + preSet 1 (shrink $ 1 * 2 :: AAI) == Set.empty + + test "preSet 2 (shrink $ 1 * 2) == Set.fromList [1]" $ + preSet 2 (shrink $ 1 * 2 :: AAI) == Set.fromList [1] + + test "Set.member x . preSet x == const False" $ \(x :: Int) y -> + (Set.member x . preSet x) y == const False y + + putStrLn "\n============ Acyclic.AdjacencyMap.postSet ============" + test "postSet x empty == Set.empty" $ \(x :: Int) -> + postSet x empty == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \(x :: Int) -> + postSet x (vertex x) == Set.empty + + test "postSet 1 (shrink $ 1 * 2) == Set.fromList [2]" $ + postSet 1 (shrink $ 1 * 2 :: AAI) == Set.fromList [2] + + test "postSet 2 (shrink $ 1 * 2) == Set.empty" $ + postSet 2 (shrink $ 1 * 2 :: AAI) == Set.empty + + test "Set.member x . postSet x == const False" $ \(x :: Int) y -> + (Set.member x . postSet x) y == const False y + + putStrLn "\n============ Acyclic.AdjacencyMap.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> + removeVertex x (vertex x) == empty + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2 :: AAI) == vertex 2 + + test "removeVertex 1 (shrink $ 1 * 2) == vertex 2" $ + removeVertex 1 (shrink $ 1 * 2 :: AAI) == vertex 2 + + test "removeVertex x . removeVertex x == removeVertex x" $ \(x :: Int) y -> + (removeVertex x . removeVertex x) y == removeVertex x y + + putStrLn "\n============ Acyclic.AdjacencyMap.removeEdge ============" + test "removeEdge 1 2 (shrink $ 1 * 2) == vertices [1,2]" $ + removeEdge 1 2 (shrink $ 1 * 2 :: AAI) == vertices [1,2] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 2 (shrink $ 1 * 2 * 3) == shrink ((1 + 2) * 3)" $ + removeEdge 1 2 (shrink $ 1 * 2 * 3 :: AAI) == shrink ((1 + 2) * 3) + + putStrLn "\n============ Acyclic.AdjacencyMap.transpose ============" + test "transpose empty == empty" $ + transpose (empty :: AAI) == empty + + test "transpose (vertex x) == vertex x" $ \(x :: Int) -> + transpose (vertex x) == vertex x + + test "transpose . transpose == id" $ size10 $ \(x :: AAI) -> + (transpose . transpose) x == id x + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn "\n============ Acyclic.AdjacencyMap.induce ============" + test "induce (const True ) x == x" $ \(x :: AAI) -> + induce (const True ) x == x + + test "induce (const False) x == empty" $ \(x :: AAI) -> + induce (const False) x == empty + + test "induce (/= x) == removeVertex x" $ \x (y :: AAI) -> + induce (/= x) y == removeVertex x y + + test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: AAI) -> + (induce p . induce q) y == induce (\x -> p x && q x) y + + test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) (x :: AAI) -> + isSubgraphOf (induce p x) x == True + + putStrLn "\n============ Acyclic.AdjacencyMap.induceJust ============" + test "induceJust (vertex Nothing) == empty" $ + induceJust (vertex Nothing) == (empty :: AAI) + + test "induceJust . vertex . Just == vertex" $ \(x :: Int) -> + (induceJust . vertex . Just) x == vertex x + + putStrLn "\n============ Acyclic.AdjacencyMap.box ============" + test "edgeList (box (shrink $ 1 * 2) (shrink $ 10 * 20)) == \n" $ + edgeList (box (shrink $ 1 * 2) (shrink $ 10 * 20)) == [ ((1,10), (1,20)) + , ((1,10), (2,10)) + , ((1,20), (2,20)) + , ((2,10), (2 :: Int,20 :: Int)) ] + + let gmap f = shrink . AM.gmap f . fromAcyclic + unit = gmap $ \(a :: Int, () ) -> a + comm = gmap $ \(a :: Int, b :: Int) -> (b, a) + test "box x y ~~ box y x" $ size10 $ \x y -> + comm (box x y) == box y x + + test "box x (vertex ()) ~~ x" $ size10 $ \x -> + unit(box x (vertex ())) == (x `asTypeOf` empty) + + test "box x empty ~~ empty" $ size10 $ \x -> + unit(box x empty) == empty + + let assoc = gmap $ \(a :: Int, (b :: Int, c :: Int)) -> ((a, b), c) + test "box x (box y z) ~~ box (box x y) z" $ size10 $ \x y z -> + assoc (box x (box y z)) == box (box x y) z + + test "transpose (box x y) == box (transpose x) (transpose y)" $ size10 $ \(x :: AAI) (y :: AAI) -> + transpose (box x y) == box (transpose x) (transpose y) + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ size10 $ \(x :: AAI) (y :: AAI) -> + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ size10 $ \(x :: AAI) (y :: AAI) -> + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + + putStrLn "\n============ Acyclic.AdjacencyMap.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: AAI) + + test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> + transitiveClosure (vertex x) == vertex x + + test "transitiveClosure (shrink $ 1 * 2 + 2 * 3) == shrink (1 * 2 + 1 * 3 + 2 * 3)" $ + transitiveClosure (shrink $ 1 * 2 + 2 * 3 :: AAI) == shrink (1 * 2 + 1 * 3 + 2 * 3) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ \(x :: AAI) -> + (transitiveClosure . transitiveClosure) x == transitiveClosure x + + putStrLn "\n============ Acyclic.AdjacencyMap.topSort ============" + test "topSort empty == []" $ + topSort (empty :: AAI) == [] + + test "topSort (vertex x) == [x]" $ \(x :: Int) -> + topSort (vertex x) == [x] + + test "topSort (shrink $ 1 * (2 + 4) + 3 * 4) == [1, 2, 3, 4]" $ + topSort (shrink $ 1 * (2 + 4) + 3 * 4) == [1, 2, 3, 4 :: Int] + + test "topSort (join x y) == fmap Left (topSort x) ++ fmap Right (topSort y)" $ \(x :: AAI) (y :: AAI) -> + topSort (join x y) == fmap Left (topSort x) ++ fmap Right (topSort y) + + test "Right . topSort == AM.topSort . fromAcyclic" $ \(x :: AAI) -> + Right (topSort x) == AM.topSort (fromAcyclic x) + + putStrLn "\n============ Acyclic.AdjacencyMap.scc ============" + test " scc empty == empty" $ + scc (AM.empty :: AI) == empty + + test " scc (vertex x) == vertex (NonEmpty.vertex x)" $ \(x :: Int) -> + scc (AM.vertex x) == vertex (NonEmpty.vertex x) + + test " scc (edge 1 1) == vertex (NonEmpty.edge 1 1)" $ + scc (AM.edge 1 1 :: AI) == vertex (NonEmpty.edge 1 1) + + test "edgeList $ scc (edge 1 2) == [ (NonEmpty.vertex 1 , NonEmpty.vertex 2 ) ]" $ + edgeList (scc (AM.edge 1 2 :: AI)) == [ (NonEmpty.vertex 1 , NonEmpty.vertex 2 ) ] + + test "edgeList $ scc (3 * 1 * 4 * 1 * 5) == " $ + edgeList (scc (3 * 1 * 4 * 1 * 5)) == [ (NonEmpty.vertex 3 , NonEmpty.vertex (5 :: Int)) + , (NonEmpty.vertex 3 , NonEmpty.clique1 [1,4,1]) + , (NonEmpty.clique1 [1,4,1], NonEmpty.vertex 5 ) ] + + putStrLn "\n============ Acyclic.AdjacencyMap.toAcyclic ============" + test "toAcyclic (path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3)" $ + toAcyclic (AM.path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3 :: AAI) + + test "toAcyclic (clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3))" $ + toAcyclic (AM.clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3 :: AAI)) + + test "toAcyclic (circuit [1,2,3]) == Nothing" $ + toAcyclic (AM.circuit [1,2,3 :: Int]) == Nothing + + test "toAcyclic . fromAcyclic == Just" $ \(x :: AAI) -> + (toAcyclic . fromAcyclic) x == Just x + + putStrLn "\n============ Acyclic.AdjacencyMap.toAcyclicOrd ============" + test "toAcyclicOrd empty == empty" $ + toAcyclicOrd AM.empty == (empty :: AAI) + + test "toAcyclicOrd . vertex == vertex" $ \(x :: Int) -> + (toAcyclicOrd . AM.vertex) x == vertex x + + test "toAcyclicOrd (1 + 2) == shrink (1 + 2)" $ + toAcyclicOrd (1 + 2) == (shrink $ 1 + 2 :: AAI) + + test "toAcyclicOrd (1 * 2) == shrink (1 * 2)" $ + toAcyclicOrd (1 * 2) == (shrink $ 1 * 2 :: AAI) + + test "toAcyclicOrd (2 * 1) == shrink (1 + 2)" $ + toAcyclicOrd (2 * 1) == (shrink $ 1 + 2 :: AAI) + + test "toAcyclicOrd (1 * 2 * 1) == shrink (1 * 2)" $ + toAcyclicOrd (1 * 2 * 1) == (shrink $ 1 * 2 :: AAI) + + test "toAcyclicOrd (1 * 2 * 3) == shrink (1 * 2 * 3)" $ + toAcyclicOrd (1 * 2 * 3) == (shrink $ 1 * 2 * 3 :: AAI) + + + putStrLn "\n============ Acyclic.AdjacencyMap.shrink ============" + test "shrink . AM.vertex == vertex" $ \x -> + (shrink . AM.vertex) x == (vertex x :: AAI) + + test "shrink . AM.vertices == vertices" $ \x -> + (shrink . AM.vertices) x == (vertices x :: AAI) + + test "shrink . fromAcyclic == id" $ \(x :: AAI) -> + (shrink . fromAcyclic) x == id x + + putStrLn "\n============ Acyclic.AdjacencyMap.consistent ============" + test "Arbitrary" $ \(x :: AAI) -> consistent x + test "empty" $ consistent (empty :: AAI) + test "vertex" $ \(x :: Int) -> consistent (vertex x) + test "vertices" $ \(xs :: [Int]) -> consistent (vertices xs) + test "union" $ \(x :: AAI) (y :: AAI) -> consistent (union x y) + test "join" $ \(x :: AAI) (y :: AAI) -> consistent (join x y) + test "transpose" $ \(x :: AAI) -> consistent (transpose x) + test "box" $ size10 $ \(x :: AAI) (y :: AAI) -> consistent (box x y) + test "transitiveClosure" $ \(x :: AAI) -> consistent (transitiveClosure x) + test "scc" $ \(x :: AI) -> consistent (scc x) + test "toAcyclic" $ \(x :: AI) -> fmap consistent (toAcyclic x) /= Just False + test "toAcyclicOrd" $ \(x :: AI) -> consistent (toAcyclicOrd x) diff --git a/test/Algebra/Graph/Test/AdjacencyIntMap.hs b/test/Algebra/Graph/Test/AdjacencyIntMap.hs --- a/test/Algebra/Graph/Test/AdjacencyIntMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyIntMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyIntMap --- 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 @@ -11,20 +11,27 @@ module Algebra.Graph.Test.AdjacencyIntMap ( -- * Testsuite testAdjacencyIntMap - ) where + ) where import Algebra.Graph.AdjacencyIntMap import Algebra.Graph.Test +import Algebra.Graph.Test.API (Mono (..), adjacencyIntMapAPI) import Algebra.Graph.Test.Generic -t :: Testsuite -t = testsuite "AdjacencyIntMap." empty +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +t :: TestsuiteInt (Mono AdjacencyIntMap) +t = ("AdjacencyIntMap.", adjacencyIntMapAPI) + testAdjacencyIntMap :: IO () testAdjacencyIntMap = do putStrLn "\n============ AdjacencyIntMap ============" - test "Axioms of graphs" (axioms :: GraphTestsuite AdjacencyIntMap) + test "Axioms of graphs" (axioms @ AdjacencyIntMap) + putStrLn $ "\n============ AdjacencyIntMap.fromAdjacencyMap ============" + test "fromAdjacencyMap == stars . AdjacencyMap.adjacencyList" $ \x -> + fromAdjacencyMap x == (stars . AdjacencyMap.adjacencyList) x + testConsistent t testShow t testBasicPrimitives t @@ -34,6 +41,8 @@ testGraphFamilies t testTransformations t testRelational t + testBfsForest t + testBfs t testDfsForest t testDfsForestFrom t testDfs t diff --git a/test/Algebra/Graph/Test/AdjacencyMap.hs b/test/Algebra/Graph/Test/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyMap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyMap --- 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 @@ -12,26 +12,31 @@ module Algebra.Graph.Test.AdjacencyMap ( -- * Testsuite testAdjacencyMap - ) where + ) where import Data.List.NonEmpty import Algebra.Graph.AdjacencyMap import Algebra.Graph.AdjacencyMap.Algorithm import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, adjacencyMapAPI) import Algebra.Graph.Test.Generic import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.Graph.Typed as KL -t :: Testsuite -t = testsuite "AdjacencyMap." empty +tPoly :: Testsuite AdjacencyMap Ord +tPoly = ("AdjacencyMap.", adjacencyMapAPI) +t :: TestsuiteInt AdjacencyMap +t = fmap toIntAPI tPoly + type AI = AdjacencyMap Int testAdjacencyMap :: IO () testAdjacencyMap = do putStrLn "\n============ AdjacencyMap ============" - test "Axioms of graphs" (axioms :: GraphTestsuite AI) + test "Axioms of graphs" (axioms @ AI) testConsistent t testShow t @@ -42,6 +47,9 @@ testGraphFamilies t testTransformations t testRelational t + testBox tPoly + testBfsForest t + testBfs t testDfsForest t testDfsForestFrom t testDfs t @@ -50,6 +58,7 @@ testIsAcyclic t testIsDfsForestOf t testIsTopSortOf t + testInduceJust tPoly putStrLn "\n============ AdjacencyMap.scc ============" test "scc empty == empty" $ @@ -58,6 +67,9 @@ test "scc (vertex x) == vertex (NonEmpty.vertex x)" $ \(x :: Int) -> scc (vertex x) == vertex (NonEmpty.vertex x) + test "scc (vertices xs) == vertices (map NonEmpty.vertex xs)" $ \(xs :: [Int]) -> + scc (vertices xs) == vertices (Prelude.map NonEmpty.vertex xs) + test "scc (edge 1 1) == vertex (NonEmpty.edge 1 1)" $ scc (edge 1 1 :: AI) == vertex (NonEmpty.edge 1 1) @@ -77,3 +89,6 @@ test "isAcyclic x == (scc x == gmap NonEmpty.vertex x)" $ \(x :: AI) -> isAcyclic x == (scc x == gmap NonEmpty.vertex x) + + test "scc g == KL.scc g" $ \(g :: AI) -> + scc g == KL.scc g diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Arbitrary --- 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 @@ -11,11 +11,8 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Test.Arbitrary ( -- * Generators of arbitrary graph instances - arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, arbitraryAdjacencyIntMap - ) where - -import Prelude () -import Prelude.Compat + arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, + ) where import Control.Monad import Data.List.NonEmpty (NonEmpty (..), toList) @@ -24,24 +21,24 @@ import Test.QuickCheck import Algebra.Graph -import Algebra.Graph.AdjacencyMap.Internal -import Algebra.Graph.AdjacencyIntMap.Internal import Algebra.Graph.Export -import Algebra.Graph.Fold (Fold) import Algebra.Graph.Label -import Algebra.Graph.Relation.InternalDerived -import Algebra.Graph.Relation.Symmetric.Internal -import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap -import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap -import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.Fold as Fold -import qualified Algebra.Graph.Labelled as LG -import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM -import qualified Algebra.Graph.NonEmpty as NonEmpty -import qualified Algebra.Graph.Relation as Relation -import qualified Algebra.Graph.Relation.Symmetric as Symmetric +import qualified Algebra.Graph.Undirected as UG +import qualified Algebra.Graph.Acyclic.AdjacencyMap as AAM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Bipartite.Undirected.AdjacencyMap as BAM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Algebra.Graph.Relation as Relation +import qualified Algebra.Graph.Relation.Preorder as Preorder +import qualified Algebra.Graph.Relation.Reflexive as Reflexive +import qualified Algebra.Graph.Relation.Symmetric as Symmetric +import qualified Algebra.Graph.Relation.Transitive as Transitive -- | Generate an arbitrary 'C.Graph' value of a specified size. arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g @@ -64,19 +61,23 @@ shrink (Connect x y) = [Empty, x, y, Overlay x y] ++ [Connect x' y' | (x', y') <- shrink (x, y) ] -instance (Eq a, Ord a, Arbitrary a) => Arbitrary (Fold a) where +-- An Arbitrary instance for Graph.Undirected +instance Arbitrary a => Arbitrary (UG.Graph a) where arbitrary = arbitraryGraph - shrink g = oneLessVertex ++ oneLessEdge - where - oneLessVertex = - let vertices = Fold.vertexList g - in [ Fold.removeVertex v g | v <- vertices ] +-- An Arbitrary instance for Acyclic.AdjacencyMap +instance (Ord a, Arbitrary a) => Arbitrary (AAM.AdjacencyMap a) where + arbitrary = AAM.shrink <$> arbitrary - oneLessEdge = - let edges = Fold.edgeList g - in [ Fold.removeEdge v w g | (v, w) <- edges ] + shrink g = shrinkVertices ++ shrinkEdges + where + shrinkVertices = + let vertices = AAM.vertexList g + in [ AAM.removeVertex x g | x <- vertices ] + shrinkEdges = + let edges = AAM.edgeList g + in [ AAM.removeEdge x y g | (x, y) <- edges ] -- | Generate an arbitrary 'NonEmpty.Graph' value of a specified size. arbitraryNonEmptyGraph :: Arbitrary a => Gen (NonEmpty.Graph a) @@ -106,46 +107,44 @@ instance (Arbitrary a, Ord a) => Arbitrary (Relation.Relation a) where arbitrary = arbitraryRelation - shrink g = oneLessVertex ++ oneLessEdge + shrink g = shrinkVertices ++ shrinkEdges where - oneLessVertex = + shrinkVertices = let vertices = Relation.vertexList g in [ Relation.removeVertex v g | v <- vertices ] - oneLessEdge = + shrinkEdges = let edges = Relation.edgeList g in [ Relation.removeEdge v w g | (v, w) <- edges ] - -instance (Arbitrary a, Ord a) => Arbitrary (ReflexiveRelation a) where - arbitrary = ReflexiveRelation <$> arbitraryRelation +-- TODO: Simplify. +instance (Arbitrary a, Ord a) => Arbitrary (Reflexive.ReflexiveRelation a) where + arbitrary = Reflexive.fromRelation . Relation.reflexiveClosure + <$> arbitraryRelation instance (Arbitrary a, Ord a) => Arbitrary (Symmetric.Relation a) where - arbitrary = SR . Relation.symmetricClosure <$> arbitraryRelation + arbitrary = Symmetric.toSymmetric <$> arbitraryRelation -instance (Arbitrary a, Ord a) => Arbitrary (TransitiveRelation a) where - arbitrary = TransitiveRelation <$> arbitraryRelation +instance (Arbitrary a, Ord a) => Arbitrary (Transitive.TransitiveRelation a) where + arbitrary = Transitive.fromRelation . Relation.transitiveClosure + <$> arbitraryRelation -instance (Arbitrary a, Ord a) => Arbitrary (PreorderRelation a) where - arbitrary = PreorderRelation <$> arbitraryRelation +instance (Arbitrary a, Ord a) => Arbitrary (Preorder.PreorderRelation a) where + arbitrary = Preorder.fromRelation . Relation.closure + <$> arbitraryRelation -- | Generate an arbitrary 'AdjacencyMap'. It is guaranteed that the -- resulting adjacency map is 'consistent'. -arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AdjacencyMap a) -arbitraryAdjacencyMap = AdjacencyMap.stars <$> arbitrary +arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AM.AdjacencyMap a) +arbitraryAdjacencyMap = AM.stars <$> arbitrary -instance (Arbitrary a, Ord a) => Arbitrary (AdjacencyMap a) where +instance (Arbitrary a, Ord a) => Arbitrary (AM.AdjacencyMap a) where arbitrary = arbitraryAdjacencyMap - shrink g = oneLessVertex ++ oneLessEdge + shrink g = shrinkVertices ++ shrinkEdges where - oneLessVertex = - let vertices = AdjacencyMap.vertexList g - in [ AdjacencyMap.removeVertex v g | v <- vertices ] - - oneLessEdge = - let edges = AdjacencyMap.edgeList g - in [ AdjacencyMap.removeEdge v w g | (v, w) <- edges ] + shrinkVertices = [ AM.removeVertex v g | v <- AM.vertexList g ] + shrinkEdges = [ AM.removeEdge v w g | (v, w) <- AM.edgeList g ] -- | Generate an arbitrary non-empty 'NAM.AdjacencyMap'. It is guaranteed that -- the resulting adjacency map is 'consistent'. @@ -163,33 +162,23 @@ instance (Arbitrary a, Ord a) => Arbitrary (NAM.AdjacencyMap a) where arbitrary = arbitraryNonEmptyAdjacencyMap - shrink g = oneLessVertex ++ oneLessEdge + shrink g = shrinkVertices ++ shrinkEdges where - oneLessVertex = + shrinkVertices = let vertices = toList $ NAM.vertexList1 g in catMaybes [ NAM.removeVertex1 v g | v <- vertices ] - oneLessEdge = + shrinkEdges = let edges = NAM.edgeList g in [ NAM.removeEdge v w g | (v, w) <- edges ] --- | Generate an arbitrary 'AdjacencyIntMap'. It is guaranteed that the --- resulting adjacency map is 'consistent'. -arbitraryAdjacencyIntMap :: Gen AdjacencyIntMap -arbitraryAdjacencyIntMap = AdjacencyIntMap.stars <$> arbitrary - -instance Arbitrary AdjacencyIntMap where - arbitrary = arbitraryAdjacencyIntMap +instance Arbitrary AIM.AdjacencyIntMap where + arbitrary = AIM.stars <$> arbitrary - shrink g = oneLessVertex ++ oneLessEdge + shrink g = shrinkVertices ++ shrinkEdges where - oneLessVertex = - let vertices = AdjacencyIntMap.vertexList g - in [ AdjacencyIntMap.removeVertex v g | v <- vertices ] - - oneLessEdge = - let edges = AdjacencyIntMap.edgeList g - in [ AdjacencyIntMap.removeEdge v w g | (v, w) <- edges ] + shrinkVertices = [ AIM.removeVertex x g | x <- AIM.vertexList g ] + shrinkEdges = [ AIM.removeEdge x y g | (x, y) <- AIM.edgeList g ] -- | Generate an arbitrary labelled 'LAM.AdjacencyMap'. It is guaranteed -- that the resulting adjacency map is 'consistent'. @@ -199,13 +188,13 @@ instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.AdjacencyMap e a) where arbitrary = arbitraryLabelledAdjacencyMap - shrink g = oneLessVertex ++ oneLessEdge + shrink g = shrinkVertices ++ shrinkEdges where - oneLessVertex = + shrinkVertices = let vertices = LAM.vertexList g in [ LAM.removeVertex v g | v <- vertices ] - oneLessEdge = + shrinkEdges = let edges = LAM.edgeList g in [ LAM.removeEdge v w g | (_, v, w) <- edges ] @@ -249,3 +238,22 @@ instance (Arbitrary a, Num a, Ord a) => Arbitrary (Distance a) where arbitrary = (\x -> if x < 0 then distance infinite else distance (unsafeFinite x)) <$> arbitrary + +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Capacity a) where + arbitrary = (\x -> if x < 0 then capacity infinite else capacity (unsafeFinite x)) <$> arbitrary + +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Count a) where + arbitrary = (\x -> if x < 0 then count infinite else count (unsafeFinite x)) <$> arbitrary + +instance Arbitrary a => Arbitrary (Minimum a) where + arbitrary = frequency [(10, pure <$> arbitrary), (1, pure noMinimum)] + +instance (Arbitrary a, Ord a) => Arbitrary (PowerSet a) where + arbitrary = PowerSet <$> arbitrary + +instance (Arbitrary o, Arbitrary a) => Arbitrary (Optimum o a) where + arbitrary = Optimum <$> arbitrary <*> arbitrary + +instance (Arbitrary a, Arbitrary b, Ord a, Ord b) => Arbitrary (BAM.AdjacencyMap a b) where + arbitrary = BAM.toBipartite <$> arbitrary + shrink = map BAM.toBipartite . shrink . BAM.fromBipartite diff --git a/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs b/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Bipartite/Undirected/AdjacencyMap.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2020 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Bipartite.Undirected.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap ( + -- * Testsuite + testBipartiteUndirectedAdjacencyMap + ) where + +import Algebra.Graph.Bipartite.Undirected.AdjacencyMap +import Algebra.Graph.Test +import Data.Either +import Data.Either.Extra +import Data.List +import Data.Map.Strict (Map) +import Data.Set (Set) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Bipartite.Undirected.AdjacencyMap as B +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tuple + +type AI = AM.AdjacencyMap Int +type AII = AM.AdjacencyMap (Either Int Int) +type BAII = AdjacencyMap Int Int + +testBipartiteUndirectedAdjacencyMap :: IO () +testBipartiteUndirectedAdjacencyMap = do + -- Help with type inference by shadowing overly polymorphic functions + let consistent :: BAII -> Bool + consistent = B.consistent + show :: BAII -> String + show = Prelude.show + leftAdjacencyMap :: BAII -> Map Int (Set Int) + leftAdjacencyMap = B.leftAdjacencyMap + rightAdjacencyMap :: BAII -> Map Int (Set Int) + empty :: BAII + empty = B.empty + vertex :: Either Int Int -> BAII + vertex = B.vertex + leftVertex :: Int -> BAII + leftVertex = B.leftVertex + rightVertex :: Int -> BAII + rightVertex = B.rightVertex + edge :: Int -> Int -> BAII + edge = B.edge + rightAdjacencyMap = B.rightAdjacencyMap + isEmpty :: BAII -> Bool + isEmpty = B.isEmpty + hasLeftVertex :: Int -> BAII -> Bool + hasLeftVertex = B.hasLeftVertex + hasRightVertex :: Int -> BAII -> Bool + hasRightVertex = B.hasRightVertex + hasVertex :: Either Int Int -> BAII -> Bool + hasVertex = B.hasVertex + hasEdge :: Int -> Int -> BAII -> Bool + hasEdge = B.hasEdge + vertexCount :: BAII -> Int + vertexCount = B.vertexCount + edgeCount :: BAII -> Int + edgeCount = B.edgeCount + vertices :: [Int] -> [Int] -> BAII + vertices = B.vertices + edges :: [(Int, Int)] -> BAII + edges = B.edges + overlays :: [BAII] -> BAII + overlays = B.overlays + connects :: [BAII] -> BAII + connects = B.connects + swap :: BAII -> BAII + swap = B.swap + toBipartite :: AII -> BAII + toBipartite = B.toBipartite + toBipartiteWith :: Ord a => (a -> Either Int Int) -> AM.AdjacencyMap a -> BAII + toBipartiteWith = B.toBipartiteWith + fromBipartite :: BAII -> AII + fromBipartite = B.fromBipartite + biclique :: [Int] -> [Int] -> BAII + biclique = B.biclique + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.consistent ============" + test "consistent empty == True" $ + consistent empty == True + test "consistent (vertex x) == True" $ \x -> + consistent (vertex x) == True + test "consistent (edge x y) == True" $ \x y -> + consistent (edge x y) == True + test "consistent (edges x) == True" $ \x -> + consistent (edges x) == True + test "consistent (toBipartite x) == True" $ \x -> + consistent (toBipartite x) == True + test "consistent (swap x) == True" $ \x -> + consistent (swap x) == True + test "consistent (biclique xs ys) == True" $ \xs ys -> + consistent (biclique xs ys) == True + test "consistent (circuit xs) == True" $ \xs -> + consistent (circuit xs) == True + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftAdjacencyMap ============" + test "leftAdjacencyMap empty == Map.empty" $ + leftAdjacencyMap empty == Map.empty + test "leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty" $ \x -> + leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty + test "leftAdjacencyMap (rightVertex x) == Map.empty" $ \x -> + leftAdjacencyMap (rightVertex x) == Map.empty + test "leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y)" $ \x y -> + leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightAdjacencyMap ============" + test "rightAdjacencyMap empty == Map.empty" $ + rightAdjacencyMap empty == Map.empty + test "rightAdjacencyMap (leftVertex x) == Map.empty" $ \x -> + rightAdjacencyMap (leftVertex x) == Map.empty + test "rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty" $ \x -> + rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty + test "rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x)" $ \x y -> + rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.Num ============" + test "0 == rightVertex 0" $ + 0 == rightVertex 0 + test "swap 1 == leftVertex 1" $ + swap 1 == leftVertex 1 + test "swap 1 + 2 == vertices [1] [2]" $ + swap 1 + 2 == vertices [1] [2] + test "swap 1 * 2 == edge 1 2" $ + swap 1 * 2 == edge 1 2 + test "swap 1 + 2 * swap 3 == overlay (leftVertex 1) (edge 3 2)" $ + swap 1 + 2 * swap 3 == overlay (leftVertex 1) (edge 3 2) + test "swap 1 * (2 + swap 3) == connect (leftVertex 1) (vertices [3] [2])" $ + swap 1 * (2 + swap 3) == connect (leftVertex 1) (vertices [3] [2]) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.Eq ============" + test "(x == y) == (leftAdjacencyMap x == leftAdjacencyMap y && rightAdjacencyMap x == rightAdjacencyMap y)" $ \(x :: BAII) (y :: BAII) -> + (x == y) == (leftAdjacencyMap x == leftAdjacencyMap y && rightAdjacencyMap x == rightAdjacencyMap y) + + putStrLn "" + test " x + y == y + x" $ \(x :: BAII) y -> + x + y == y + x + test "x + (y + z) == (x + y) + z" $ \(x :: BAII) y z -> + x + (y + z) == (x + y) + z + test " x * empty == x" $ \(x :: BAII) -> + x * empty == x + test " empty * x == x" $ \(x :: BAII) -> + empty * x == x + test " x * y == y * x" $ \(x :: BAII) y -> + x * y == y * x + test "x * (y * z) == (x * y) * z" $ size10 $ \(x :: BAII) y z -> + x * (y * z) == (x * y) * z + test "x * (y + z) == x * y + x * z" $ size10 $ \(x :: BAII) y z -> + x * (y + z) == x * (y + z) + test "(x + y) * z == x * z + y * z" $ size10 $ \(x :: BAII) y z -> + (x + y) * z == x * z + y * z + test " x * y * z == x * y + x * z + y * z" $ size10 $ \(x :: BAII) y z -> + x * y * z == x * y + x * z + y * z + test " x + empty == x" $ \(x :: BAII) -> + x + empty == x + test " empty + x == x" $ \(x :: BAII) -> + empty + x == x + test " x + x == x" $ \(x :: BAII) -> + x + x == x + test "x * y + x + y == x * y" $ \(x :: BAII) (y :: BAII) -> + x * y + x + y == x * y + test " x * x * x == x * x" $ size10 $ \(x :: BAII) -> + x * x * x == x * x + + putStrLn "" + test " leftVertex x * leftVertex y == leftVertex x + leftVertex y " $ \(x :: Int) y -> + leftVertex x * leftVertex y == leftVertex x + leftVertex y + test "rightVertex x * rightVertex y == rightVertex x + rightVertex y" $ \(x :: Int) y -> + rightVertex x * rightVertex y == rightVertex x + rightVertex y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.Show ============" + test "show empty == \"empty\"" $ + show empty == "empty" + test "show 1 == \"rightVertex 1\"" $ + show 1 == "rightVertex 1" + test "show (swap 2) == \"leftVertex 2\"" $ + show (swap 2) == "leftVertex 2" + test "show 1 + 2 == \"vertices [] [1,2]\"" $ + show (1 + 2) == "vertices [] [1,2]" + test "show (swap (1 + 2)) == \"vertices [1,2] []\"" $ + show (swap (1 + 2)) == "vertices [1,2] []" + test "show (swap 1 * 2) == \"edge 1 2\"" $ + show (swap 1 * 2) == "edge 1 2" + test "show (swap 1 * 2 * swap 3) == \"edges [(1,2),(3,2)]\"" $ + show (swap 1 * 2 * swap 3) == "edges [(1,2),(3,2)]" + test "show (swap 1 * 2 + swap 3) == \"overlay (leftVertex 3) (edge 1 2)\"" $ + show (swap 1 * 2 + swap 3) == "overlay (leftVertex 3) (edge 1 2)" + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.empty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + test "leftAdjacencyMap empty == Map.empty" $ + leftAdjacencyMap empty == Map.empty + test "rightAdjacencyMap empty == Map.empty" $ + rightAdjacencyMap empty == Map.empty + test "hasVertex x empty == False" $ \x -> + hasVertex x empty == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertex ============" + test "leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty" $ \x -> + leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty + test "rightAdjacencyMap (leftVertex x) == Map.empty" $ \x -> + rightAdjacencyMap (leftVertex x) == Map.empty + test "hasLeftVertex x (leftVertex y) == (x == y)" $ \x y -> + hasLeftVertex x (leftVertex y) == (x == y) + test "hasRightVertex x (leftVertex y) == False" $ \x y -> + hasRightVertex x (leftVertex y) == False + test "hasEdge x y (leftVertex z) == False" $ \x y z -> + hasEdge x y (leftVertex z) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertex ============" + test "leftAdjacencyMap (rightVertex x) == Map.empty" $ \x -> + leftAdjacencyMap (rightVertex x) == Map.empty + test "rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty" $ \x -> + rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty + test "hasLeftVertex x (rightVertex y) == False" $ \x y -> + hasLeftVertex x (rightVertex y) == False + test "hasRightVertex x (rightVertex y) == (x == y)" $ \x y -> + hasRightVertex x (rightVertex y) == (x == y) + test "hasEdge x y (rightVertex z) == False" $ \x y z -> + hasEdge x y (rightVertex z) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertex ============" + test "vertex (Left x) == leftVertex x" $ \x -> + vertex (Left x) == leftVertex x + test "vertex (Right x) == rightVertex x" $ \x -> + vertex (Right x) == rightVertex x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edge ============" + test "edge x y == connect (leftVertex x) (rightVertex y)" $ \x y -> + edge x y == connect (leftVertex x) (rightVertex y) + test "leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y)" $ \x y -> + leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y) + test "rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x)" $ \x y -> + rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x) + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + test "hasEdge 1 2 (edge 2 1) == False" $ + hasEdge 1 2 (edge 2 1) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.overlay ============" + test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (overlay x y) ==(isEmpty x && isEmpty y) + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (overlay x y) ==(hasVertex z x || hasVertex z y) + test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> + vertexCount (overlay x y) >= vertexCount x + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> + edgeCount (overlay x y) >= edgeCount x + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.connect ============" + test "connect (leftVertex x) (leftVertex y) == vertices [x,y] []" $ \x y -> + connect (leftVertex x) (leftVertex y) == vertices [x,y] [] + test "connect (leftVertex x) (rightVertex y) == edge x y" $ \x y -> + connect (leftVertex x) (rightVertex y) == edge x y + test "connect (rightVertex x) (leftVertex y) == edge y x" $ \x y -> + connect (rightVertex x) (leftVertex y) == edge y x + test "connect (rightVertex x) (rightVertex y) == vertices [] [x,y]" $ \x y -> + connect (rightVertex x) (rightVertex y) == vertices [] [x,y] + test "connect (vertices xs1 ys1) (vertices xs2 ys2) == overlay (biclique xs1 ys2) (biclique xs2 ys1)" $ \xs1 ys1 xs2 ys2 -> + connect (vertices xs1 ys1) (vertices xs2 ys2) == overlay (biclique xs1 ys2) (biclique xs2 ys1) + test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (connect x y) ==(isEmpty x && isEmpty y) + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (connect x y) ==(hasVertex z x || hasVertex z y) + test "vertexCount (connect x y) >= vertexCount x" $ \x y -> + vertexCount (connect x y) >= vertexCount x + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + test "edgeCount (connect x y) >= edgeCount x" $ \x y -> + edgeCount (connect x y) >= edgeCount x + test "edgeCount (connect x y) >= leftVertexCount x * rightVertexCount y" $ \x y -> + edgeCount (connect x y) >= leftVertexCount x * rightVertexCount y + test "edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertices ============" + test "vertices [] [] == empty" $ + vertices [] [] == empty + test "vertices [x] [] == leftVertex x" $ \x -> + vertices [x] [] == leftVertex x + test "vertices [] [x] == rightVertex x" $ \x -> + vertices [] [x] == rightVertex x + test "hasLeftVertex x (vertices xs ys) == elem x xs" $ \x xs ys -> + hasLeftVertex x (vertices xs ys) == elem x xs + test "hasRightVertex y (vertices xs ys) == elem y ys" $ \y xs ys -> + hasRightVertex y (vertices xs ys) == elem y ys + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edges ============" + test "edges [] == empty" $ + edges [] == empty + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == edge x y + test "edges == overlays . map (uncurry edge)" $ \xs -> + edges xs == (overlays . map (uncurry edge)) xs + test "hasEdge x y . edges == elem (x,y)" $ \x y es -> + (hasEdge x y . edges) es == elem (x,y) es + test "edgeCount . edges == length . nub" $ \es -> + (edgeCount . edges) es == (length . nubOrd) es + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.overlays ============" + test "overlays [] == empty" $ + overlays [] == empty + test "overlays [x] == x" $ \x -> + overlays [x] == x + test "overlays [x,y] == overlay x y" $ \x y -> + overlays [x,y] == overlay x y + test "overlays == foldr overlay empty" $ size10 $ \xs -> + overlays xs == foldr overlay empty xs + test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> + (isEmpty . overlays) xs == all isEmpty xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.connects ============" + test "connects [] == empty" $ + connects [] == empty + test "connects [x] == x" $ \x -> + connects [x] == x + test "connects [x,y] == connect x y" $ \x y -> + connects [x,y] == connect x y + test "connects == foldr connect empty" $ size10 $ \xs -> + connects xs == foldr connect empty xs + test "isEmpty . connects == all isEmpty" $ size10 $ \ xs -> + (isEmpty . connects) xs == all isEmpty xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.swap ============" + test "swap empty == empty" $ + swap empty == empty + test "swap . leftVertex == rightVertex" $ \x -> + (swap . leftVertex) x == rightVertex x + test "swap (vertices xs ys) == vertices ys xs" $ \xs ys -> + swap (vertices xs ys) == vertices ys xs + test "swap (edge x y) == edge y x" $ \x y -> + swap (edge x y) == edge y x + test "swap . edges == edges . map Data.Tuple.swap" $ \es -> + (swap . edges) es == (edges . map Data.Tuple.swap) es + test "swap . swap == id" $ \x -> + (swap . swap) x == x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.toBipartite ============" + test "toBipartite empty == empty" $ + toBipartite AM.empty == empty + test "toBipartite (vertex (Left x)) == leftVertex x" $ \x -> + toBipartite (AM.vertex (Left x)) == leftVertex x + test "toBipartite (vertex (Right x)) == rightVertex x" $ \x -> + toBipartite (AM.vertex (Right x)) == rightVertex x + test "toBipartite (edge (Left x) (Left y)) == vertices [x,y] []" $ \x y -> + toBipartite (AM.edge (Left x) (Left y)) == vertices [x,y] [] + test "toBipartite (edge (Left x) (Right y)) == edge x y" $ \x y -> + toBipartite (AM.edge (Left x) (Right y)) == edge x y + test "toBipartite (edge (Right x) (Left y)) == edge y x" $ \x y -> + toBipartite (AM.edge (Right x) (Left y)) == edge y x + test "toBipartite (edge (Right x) (Right y)) == vertices [] [x,y]" $ \x y -> + toBipartite (AM.edge (Right x) (Right y)) == vertices [] [x,y] + test "toBipartite (clique xs) == uncurry biclique (partitionEithers xs)" $ \xs -> + toBipartite (AM.clique xs) == uncurry biclique (partitionEithers xs) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.toBipartiteWith ============" + test "toBipartiteWith f empty == empty" $ \(apply -> f) -> + toBipartiteWith f (AM.empty :: AII) == empty + test "toBipartiteWith Left x == vertices (vertexList x) []" $ \x -> + toBipartiteWith Left x == vertices (AM.vertexList x) [] + test "toBipartiteWith Right x == vertices [] (vertexList x)" $ \x -> + toBipartiteWith Right x == vertices [] (AM.vertexList x) + test "toBipartiteWith f == toBipartite . gmap f" $ \(apply -> f) x -> + toBipartiteWith f x == (toBipartite . AM.gmap f) (x :: AII) + test "toBipartiteWith id == toBipartite" $ \x -> + toBipartiteWith id x == toBipartite x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.fromBipartite ============" + test "fromBipartite empty == empty" $ + fromBipartite empty == AM.empty + test "fromBipartite (leftVertex x) == vertex (Left x)" $ \x -> + fromBipartite (leftVertex x) == AM.vertex (Left x) + test "fromBipartite (edge x y) == edges [(Left x, Right y), (Right y, Left x)]" $ \x y -> + fromBipartite (edge x y) == AM.edges [(Left x, Right y), (Right y, Left x)] + test "toBipartite . fromBipartite == id" $ \x -> + (toBipartite . fromBipartite) x == x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.fromBipartiteWith ============" + test "fromBipartiteWith Left Right == fromBipartite" $ \x -> + fromBipartiteWith Left Right x == fromBipartite x + test "fromBipartiteWith id id (vertices xs ys) == vertices (xs ++ ys)" $ \xs ys -> + fromBipartiteWith id id (vertices xs ys) == AM.vertices (xs ++ ys) + test "fromBipartiteWith id id . edges == edges" $ \xs -> + (fromBipartiteWith id id . edges) xs == (AM.symmetricClosure . AM.edges) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty) == True + test "isEmpty (vertex x) == False" $ \x -> + isEmpty (vertex x) == False + test "isEmpty == (==) empty" $ \x -> + isEmpty x == (==) empty x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasLeftVertex ============" + test "hasLeftVertex x empty == False" $ \x -> + hasLeftVertex x empty == False + test "hasLeftVertex x (leftVertex y) == (x == y)" $ \x y -> + hasLeftVertex x (leftVertex y) == (x == y) + test "hasLeftVertex x (rightVertex y) == False" $ \x y -> + hasLeftVertex x (rightVertex y) == False + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasRightVertex ============" + test "hasRightVertex x empty == False" $ \x -> + hasRightVertex x empty == False + test "hasRightVertex x (leftVertex y) == False" $ \x y -> + hasRightVertex x (leftVertex y) == False + test "hasRightVertex x (rightVertex y) == (x == y)" $ \x y -> + hasRightVertex x (rightVertex y) == (x == y) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasVertex ============" + test "hasVertex . Left == hasLeftVertex" $ \x y -> + (hasVertex . Left) x y == hasLeftVertex x y + test "hasVertex . Right == hasRightVertex" $ \x y -> + (hasVertex . Right) x y == hasRightVertex x y + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.hasEdge ============" + test "hasEdge x y empty == False" $ \x y -> + hasEdge x y empty == False + test "hasEdge x y (vertex z) == False" $ \x y z -> + hasEdge x y (vertex z) == False + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do + let es = edgeList z + (x, y) <- elements ((x, y) : es) + return $ hasEdge x y z == elem (x, y) es + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertexCount ============" + test "leftVertexCount empty == 0" $ + leftVertexCount empty == 0 + test "leftVertexCount (leftVertex x) == 1" $ \x -> + leftVertexCount (leftVertex x) == 1 + test "leftVertexCount (rightVertex x) == 0" $ \x -> + leftVertexCount (rightVertex x) == 0 + test "leftVertexCount (edge x y) == 1" $ \x y -> + leftVertexCount (edge x y) == 1 + test "leftVertexCount . edges == length . nub . map fst" $ \xs -> + (leftVertexCount . edges) xs == (length . nub . map fst) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertexCount ============" + test "rightVertexCount empty == 0" $ + rightVertexCount empty == 0 + test "rightVertexCount (leftVertex x) == 0" $ \x -> + rightVertexCount (leftVertex x) == 0 + test "rightVertexCount (rightVertex x) == 1" $ \x -> + rightVertexCount (rightVertex x) == 1 + test "rightVertexCount (edge x y) == 1" $ \x y -> + rightVertexCount (edge x y) == 1 + test "rightVertexCount . edges == length . nub . map snd" $ \xs -> + (rightVertexCount . edges) xs == (length . nub . map snd) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount empty == 0 + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount (vertex x) == 1 + test "vertexCount (edge x y) == 2" $ \x y -> + vertexCount (edge x y) == 2 + test "vertexCount x == leftVertexCount x + rightVertexCount x" $ \x -> + vertexCount x == leftVertexCount x + rightVertexCount x + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount (vertex x) == 0 + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount (edge x y) == 1 + test "edgeCount . edges == length . nub" $ \xs -> + (edgeCount . edges) xs == (length . nubOrd) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertexList ============" + test "leftVertexList empty == []" $ + leftVertexList empty == [] + test "leftVertexList (leftVertex x) == [x]" $ \x -> + leftVertexList (leftVertex x) == [x] + test "leftVertexList (rightVertex x) == []" $ \x -> + leftVertexList (rightVertex x) == [] + test "leftVertexList . flip vertices [] == nub . sort" $ \xs -> + (leftVertexList . flip vertices []) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertexList ============" + test "rightVertexList empty == []" $ + rightVertexList empty == [] + test "rightVertexList (leftVertex x) == []" $ \x -> + rightVertexList (leftVertex x) == [] + test "rightVertexList (rightVertex x) == [x]" $ \x -> + rightVertexList (rightVertex x) == [x] + test "rightVertexList . vertices [] == nub . sort" $ \xs -> + (rightVertexList . vertices []) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertexList ============" + test "vertexList empty == []" $ + vertexList empty == [] + test "vertexList (vertex x) == [x]" $ \x -> + vertexList (vertex x) == [x] + test "vertexList (edge x y) == [Left x, Right y]" $ \x y -> + vertexList (edge x y) == [Left x, Right y] + test "vertexList (vertices (lefts xs) (rights xs)) == nub (sort xs)" $ \xs -> + vertexList (vertices (lefts xs) (rights xs)) == nubOrd (sort xs) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList empty == [] + test "edgeList (vertex x) == []" $ \x -> + edgeList (vertex x) == [] + test "edgeList (edge x y) == [(x,y)]" $ \x y -> + edgeList (edge x y) == [(x,y)] + test "edgeList . edges == nub . sort" $ \xs -> + (edgeList . edges) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.leftVertexSet ============" + test "leftVertexSet empty == Set.empty" $ + leftVertexSet empty == Set.empty + test "leftVertexSet . leftVertex == Set.singleton" $ \x -> + (leftVertexSet . leftVertex) x == Set.singleton x + test "leftVertexSet . rightVertex == const Set.empty" $ \x -> + (leftVertexSet . rightVertex) x == const Set.empty x + test "leftVertexSet . flip vertices [] == Set.fromList" $ \xs -> + (leftVertexSet . flip vertices []) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.rightVertexSet ============" + test "rightVertexSet empty == Set.empty" $ + rightVertexSet empty == Set.empty + test "rightVertexSet . leftVertex == const Set.empty" $ \x -> + (rightVertexSet . leftVertex) x == const Set.empty x + test "rightVertexSet . rightVertex == Set.singleton" $ \x -> + (rightVertexSet . rightVertex) x == Set.singleton x + test "rightVertexSet . vertices [] == Set.fromList" $ \xs -> + (rightVertexSet . vertices []) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet empty == Set.empty + test "vertexSet . vertex == Set.singleton" $ \x -> + (vertexSet . vertex) x == Set.singleton x + test "vertexSet (edge x y) == Set.fromList [Left x, Right y]" $ \x y -> + vertexSet (edge x y) == Set.fromList [Left x, Right y] + test "vertexSet (vertices (lefts xs) (rights xs)) == Set.fromList xs" $ \xs -> + vertexSet (vertices (lefts xs) (rights xs)) == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet empty == Set.empty + test "edgeSet (vertex x) == Set.empty" $ \x -> + edgeSet (vertex x) == Set.empty + test "edgeSet (edge x y) == Set.singleton (x,y)" $ \x y -> + edgeSet (edge x y) == Set.singleton (x,y) + test "edgeSet . edges == Set.fromList" $ \xs -> + (edgeSet . edges) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.circuit ============" + test "circuit [] == empty" $ + circuit [] == empty + test "circuit [(x,y)] == edge x y" $ \x y -> + circuit [(x,y)] == edge x y + test "circuit [(1,2), (3,4)] == biclique [1,3] [2,4]" $ + circuit [(1,2), (3,4)] == biclique [1,3 :: Int] [2,4 :: Int] + test "circuit [(1,2), (3,4), (5,6)] == edges [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)]" $ + circuit [(1,2), (3,4), (5,6)] == edges [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)] + test "circuit . reverse == swap . circuit . map Data.Tuple.swap" $ \xs -> + (circuit . reverse) xs == (swap . circuit . map Data.Tuple.swap) xs + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.biclique ============" + test "biclique [] [] == empty" $ + biclique [] [] == empty + test "biclique xs [] == vertices xs []" $ \xs -> + biclique xs [] == vertices xs [] + test "biclique [] ys == vertices [] ys" $ \ys -> + biclique [] ys == vertices [] ys + test "biclique xs ys == connect (vertices xs []) (vertices [] ys)" $ \xs ys -> + biclique xs ys == connect (vertices xs []) (vertices [] ys) + + putStrLn "\n============ Bipartite.Undirected.AdjacencyMap.detectParts ============" + test "detectParts empty == Right empty" $ + detectParts AM.empty == Right empty + test "detectParts (vertex x) == Right (leftVertex x)" $ \x -> + detectParts (AM.vertex x) == Right (leftVertex x) + test "detectParts (edge x x) == Left [x]" $ \x -> + detectParts (AM.edge x x :: AI) == Left [x] + test "detectParts (edge 1 2) == Right (edge 1 2)" $ + detectParts (AM.edge 1 2) == Right (edge 1 2) + test "detectParts (1 * (2 + 3)) == Right (edges [(1,2), (1,3)])" $ + detectParts (1 * (2 + 3)) == Right (edges [(1,2), (1,3)]) + test "detectParts (1 * 2 * 3) == Left [1, 2, 3]" $ + detectParts (1 * 2 * 3 :: AI) == Left [1, 2, 3] + test "detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right (swap (1 + 3) * (2 + 4) + swap 5 * 6)" $ + detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right (swap (1 + 3) * (2 + 4) + swap 5 * 6) + test "detectParts ((1 * 3 * 4) + 2 * (1 + 2)) == Left [2]" $ + detectParts ((1 * 3 * 4) + 2 * (1 + 2) :: AI) == Left [2] + test "detectParts (clique [1..10]) == Left [1, 2, 3]" $ + detectParts (AM.clique [1..10] :: AI) == Left [1, 2, 3] + test "detectParts (circuit [1..11]) == Left [1..11]" $ + detectParts (AM.circuit [1..11] :: AI) == Left [1..11] + test "detectParts (circuit [1..10]) == Right (circuit [(x, x + 1) | x <- [1,3,5,7,9]])" $ + detectParts (AM.circuit [1..10] :: AI) == Right (circuit [(x, x + 1) | x <- [1,3,5,7,9]]) + test "detectParts (biclique [] xs) == Right (vertices xs [])" $ \xs -> + detectParts (AM.biclique [] xs) == Right (vertices xs []) + test "detectParts (biclique (map Left (x:xs)) (map Right ys)) == Right (biclique (map Left (x:xs)) (map Right ys))" $ \(x :: Int) xs (ys :: [Int]) -> + detectParts (AM.biclique (map Left (x:xs)) (map Right ys)) == Right (B.biclique (map Left (x:xs)) (map Right ys)) + test "isRight (detectParts (star x ys)) == notElem x ys" $ \(x :: Int) ys -> + isRight (detectParts (AM.star x ys)) == notElem x ys + test "isRight (detectParts (fromBipartite x)) == True" $ \x -> + isRight (detectParts (fromBipartite x)) == True + + putStrLn "" + test "Correctness of detectParts" $ \input -> + let undirected = AM.symmetricClosure input in + case detectParts input of + Left cycle -> mod (length cycle) 2 == 1 && AM.isSubgraphOf (AM.circuit cycle) undirected + Right bipartite -> AM.gmap fromEither (fromBipartite bipartite) == undirected diff --git a/test/Algebra/Graph/Test/Export.hs b/test/Algebra/Graph/Test/Export.hs --- a/test/Algebra/Graph/Test/Export.hs +++ b/test/Algebra/Graph/Test/Export.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Export @@ -12,19 +12,13 @@ module Algebra.Graph.Test.Export ( -- * Testsuite testExport - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif + ) where import Algebra.Graph (Graph, circuit) import Algebra.Graph.Export hiding (unlines) import Algebra.Graph.Export.Dot (Attribute (..)) import Algebra.Graph.Test +import Data.Semigroup ((<>)) import qualified Algebra.Graph.Export as E import qualified Algebra.Graph.Export.Dot as ED diff --git a/test/Algebra/Graph/Test/Fold.hs b/test/Algebra/Graph/Test/Fold.hs deleted file mode 100644 --- a/test/Algebra/Graph/Test/Fold.hs +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Test.Fold --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- Testsuite for "Algebra.Graph.Fold" and polymorphic functions defined in --- "Algebra.Graph.Class". ------------------------------------------------------------------------------ -module Algebra.Graph.Test.Fold ( - -- * Testsuite - testFold - ) where - -import Algebra.Graph.Fold -import Algebra.Graph.Test -import Algebra.Graph.Test.Generic - -t :: Testsuite -t = testsuite "Fold." (empty :: Fold Int) - -type F = Fold Int - -testFold :: IO () -testFold = do - putStrLn "\n============ Fold ============" - test "Axioms of graphs" (axioms :: GraphTestsuite F) - - testShow t - testBasicPrimitives t - testIsSubgraphOf t - testToGraph t - testSize t - testGraphFamilies t - testTransformations t - testSplitVertex t - testBind t - testSimplify t diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -1,1833 +1,2069 @@ -{-# LANGUAGE GADTs, RankNTypes, ViewPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Test.Generic --- Copyright : (c) Andrey Mokhov 2016-2019 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- Generic graph API testing. ------------------------------------------------------------------------------ -module Algebra.Graph.Test.Generic where - -import Prelude () -import Prelude.Compat - -import Control.Monad (when) -import Data.Orphans () - -import Data.List (nub) -import Data.Maybe -import Data.Tree -import Data.Tuple - -import Algebra.Graph.Class (Graph (..)) -import Algebra.Graph.ToGraph -import Algebra.Graph.Test -import Algebra.Graph.Test.API - -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet - -data Testsuite where - Testsuite :: (Arbitrary g, GraphAPI g, Num g, Ord g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) - => String -> (forall r. (g -> r) -> g -> r) -> Testsuite - -testsuite :: (Arbitrary g, GraphAPI g, Num g, Ord g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) - => String -> g -> Testsuite -testsuite prefix g = Testsuite prefix (\f x -> f (x `asTypeOf` g)) - -size10 :: Testable prop => prop -> Property -size10 = mapSize (min 10) - -testBasicPrimitives :: Testsuite -> IO () -testBasicPrimitives = mconcat [ testOrd - , testEmpty - , testVertex - , testEdge - , testOverlay - , testConnect - , testVertices - , testEdges - , testOverlays - , testConnects ] - -testSymmetricBasicPrimitives :: Testsuite -> IO () -testSymmetricBasicPrimitives = mconcat [ testSymmetricOrd - , testEmpty - , testVertex - , testSymmetricEdge - , testOverlay - , testSymmetricConnect - , testVertices - , testSymmetricEdges - , testOverlays - , testSymmetricConnects ] - -testToGraph :: Testsuite -> IO () -testToGraph = mconcat [ testToGraphDefault - , testFoldg - , testIsEmpty - , testHasVertex - , testHasEdge - , testVertexCount - , testEdgeCount - , testVertexList - , testVertexSet - , testVertexIntSet - , testEdgeList - , testEdgeSet - , testAdjacencyList - , testPreSet - , testPreIntSet - , testPostSet - , testPostIntSet ] - -testSymmetricToGraph :: Testsuite -> IO () -testSymmetricToGraph = mconcat [ testSymmetricToGraphDefault - , testIsEmpty - , testHasVertex - , testSymmetricHasEdge - , testVertexCount - , testEdgeCount - , testVertexList - , testVertexSet - , testVertexIntSet - , testSymmetricEdgeList - , testSymmetricEdgeSet - , testSymmetricAdjacencyList - , testNeighbours ] - -testRelational :: Testsuite -> IO () -testRelational = mconcat [ testCompose - , testClosure - , testReflexiveClosure - , testSymmetricClosure - , testTransitiveClosure ] - -testGraphFamilies :: Testsuite -> IO () -testGraphFamilies = mconcat [ testPath - , testCircuit - , testClique - , testBiclique - , testStar - , testStars - , testTree - , testForest ] - -testSymmetricGraphFamilies :: Testsuite -> IO () -testSymmetricGraphFamilies = mconcat [ testSymmetricPath - , testSymmetricCircuit - , testSymmetricClique - , testBiclique - , testStar - , testStars - , testTree - , testForest ] - -testTransformations :: Testsuite -> IO () -testTransformations = mconcat [ testRemoveVertex - , testRemoveEdge - , testReplaceVertex - , testMergeVertices - , testTranspose - , testGmap - , testInduce ] - -testSymmetricTransformations :: Testsuite -> IO () -testSymmetricTransformations = mconcat [ testRemoveVertex - , testSymmetricRemoveEdge - , testReplaceVertex - , testMergeVertices - , testGmap - , testInduce ] - -testConsistent :: Testsuite -> IO () -testConsistent (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "consistent ============" - test "Consistency of the Arbitrary instance" $ \x -> consistent % x - - putStrLn "" - test "consistent empty == True" $ - consistent % empty == True - - test "consistent (vertex x) == True" $ \x -> - consistent % (vertex x) == True - - test "consistent (overlay x y) == True" $ \x y -> - consistent % (overlay x y) == True - - test "consistent (connect x y) == True" $ \x y -> - consistent % (connect x y) == True - - test "consistent (edge x y) == True" $ \x y -> - consistent % (edge x y) == True - - test "consistent (edges xs) == True" $ \xs -> - consistent % (edges xs) == True - - test "consistent (stars xs) == True" $ \xs -> - consistent % (stars xs) == True - -testShow :: Testsuite -> IO () -testShow (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "Show ============" - test "show (empty ) == \"empty\"" $ - show % empty == "empty" - - test "show (1 ) == \"vertex 1\"" $ - show % 1 == "vertex 1" - - test "show (1 + 2 ) == \"vertices [1,2]\"" $ - show % (1 + 2) == "vertices [1,2]" - - test "show (1 * 2 ) == \"edge 1 2\"" $ - show % (1 * 2) == "edge 1 2" - - test "show (1 * 2 * 3) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show % (1 * 2 * 3) == "edges [(1,2),(1,3),(2,3)]" - - test "show (1 * 2 + 3) == \"overlay (vertex 3) (edge 1 2)\"" $ - show % (1 * 2 + 3) == "overlay (vertex 3) (edge 1 2)" - - putStrLn "" - test "show (vertex (-1) ) == \"vertex (-1)\"" $ - show % (vertex (-1) ) == "vertex (-1)" - - test "show (vertex (-1) + vertex (-2) ) == \"vertices [-2,-1]\"" $ - show % (vertex (-1) + vertex (-2) ) == "vertices [-2,-1]" - - test "show (vertex (-2) * vertex (-1) ) == \"edge (-2) (-1)\"" $ - show % (vertex (-2) * vertex (-1) ) == "edge (-2) (-1)" - - test "show (vertex (-3) * vertex (-2) * vertex (-1)) == \"edges [(-3,-2),(-3,-1),(-2,-1)]\"" $ - show % (vertex (-3) * vertex (-2) * vertex (-1)) == "edges [(-3,-2),(-3,-1),(-2,-1)]" - - test "show (vertex (-3) * vertex (-2) + vertex (-1)) == \"overlay (vertex (-1)) (edge (-3) (-2))\"" $ - show % (vertex (-3) * vertex (-2) + vertex (-1)) == "overlay (vertex (-1)) (edge (-3) (-2))" - -testSymmetricShow :: Testsuite -> IO () -testSymmetricShow t@(Testsuite _ (%)) = do - testShow t - putStrLn "" - test "show (2 * 1 ) == \"edge 1 2\"" $ - show % (2 * 1) == "edge 1 2" - - test "show (1 * 2 * 1) == \"edges [(1,1),(1,2)]\"" $ - show % (1 * 2 * 1) == "edges [(1,1),(1,2)]" - - test "show (3 * 2 * 1) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show % (3 * 2 * 1) == "edges [(1,2),(1,3),(2,3)]" - -testOrd :: Testsuite -> IO () -testOrd (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "Ord ============" - test "vertex 1 < vertex 2" $ - vertex 1 < id % vertex 2 - - test "vertex 3 < edge 1 2" $ - vertex 3 < id % edge 1 2 - - test "vertex 1 < edge 1 1" $ - vertex 1 < id % edge 1 1 - - test "edge 1 1 < edge 1 2" $ - edge 1 1 < id % edge 1 2 - - test "edge 1 2 < edge 1 1 + edge 2 2" $ - edge 1 2 < id % edge 1 1 + edge 2 2 - - test "edge 1 2 < edge 1 3" $ - edge 1 2 < id % edge 1 3 - - test "x <= x + y" $ \x y -> - id % x <= x + y - - test "x + y <= x * y" $ \x y -> - id % x + y <= x * y - -testSymmetricOrd :: Testsuite -> IO () -testSymmetricOrd (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "Ord ============" - test "vertex 1 < vertex 2" $ - vertex 1 < id % vertex 2 - - test "vertex 3 < edge 1 2" $ - vertex 3 < id % edge 1 2 - - test "vertex 1 < edge 1 1" $ - vertex 1 < id % edge 1 1 - - test "edge 1 1 < edge 1 2" $ - edge 1 1 < id % edge 1 2 - - test "edge 1 2 < edge 1 1 + edge 2 2" $ - edge 1 2 < id % edge 1 1 + edge 2 2 - - test "edge 2 1 < edge 1 3" $ - edge 2 1 < id % edge 1 3 - - test "edge 1 2 == edge 2 1" $ - edge 1 2 == id % edge 2 1 - - test "x <= x + y" $ \x y -> - id % x <= x + y - - test "x + y <= x * y" $ \x y -> - id % x + y <= x * y - -testEmpty :: Testsuite -> IO () -testEmpty (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "empty ============" - test "isEmpty empty == True" $ - isEmpty % empty == True - - test "hasVertex x empty == False" $ \x -> - hasVertex x % empty == False - - test "vertexCount empty == 0" $ - vertexCount % empty == 0 - - test "edgeCount empty == 0" $ - edgeCount % empty == 0 - -testVertex :: Testsuite -> IO () -testVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertex ============" - test "isEmpty (vertex x) == False" $ \x -> - isEmpty % vertex x == False - - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x % vertex x == True - - test "vertexCount (vertex x) == 1" $ \x -> - vertexCount % vertex x == 1 - - test "edgeCount (vertex x) == 0" $ \x -> - edgeCount % vertex x == 0 - -testEdge :: Testsuite -> IO () -testEdge (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edge ============" - test "edge x y == connect (vertex x) (vertex y)" $ \x y -> - edge x y == connect (vertex x) % vertex y - - test "hasEdge x y (edge x y) == True" $ \x y -> - hasEdge x y % edge x y == True - - test "edgeCount (edge x y) == 1" $ \x y -> - edgeCount % edge x y == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount % edge 1 1 == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount % edge 1 2 == 2 - -testSymmetricEdge :: Testsuite -> IO () -testSymmetricEdge (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edge ============" - test "edge x y == connect (vertex x) (vertex y)" $ \x y -> - edge x y == connect (vertex x) % vertex y - - test "edge x y == edge y x" $ \x y -> - edge x y == id % edge y x - - test "edge x y == edges [(x,y), (y,x)]" $ \x y -> - edge x y == id % edges [(x,y), (y,x)] - - test "hasEdge x y (edge x y) == True" $ \x y -> - hasEdge x y % edge x y == True - - test "edgeCount (edge x y) == 1" $ \x y -> - edgeCount % edge x y == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount % edge 1 1 == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount % edge 1 2 == 2 - -testOverlay :: Testsuite -> IO () -testOverlay (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "overlay ============" - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty % overlay x y == (isEmpty x && isEmpty y) - - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> - hasVertex z % overlay x y == (hasVertex z x || hasVertex z y) - - test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> - vertexCount % overlay x y >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> - vertexCount % overlay x y <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> - edgeCount % overlay x y >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> - edgeCount % overlay x y <= edgeCount x + edgeCount y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount % overlay 1 2 == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount % overlay 1 2 == 0 - -testConnect :: Testsuite -> IO () -testConnect (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "connect ============" - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty % connect x y == (isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> - hasVertex z % connect x y == (hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \x y -> - vertexCount % connect x y >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> - vertexCount % connect x y <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \x y -> - edgeCount % connect x y >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \x y -> - edgeCount % connect x y >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \x y -> - edgeCount % connect x y >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> - edgeCount % connect x y <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount % connect 1 2 == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount % connect 1 2 == 1 - -testSymmetricConnect :: Testsuite -> IO () -testSymmetricConnect (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "connect ============" - test "connect x y == connect y x" $ \x y -> - connect x y == id % connect y x - - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty % connect x y == (isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> - hasVertex z % connect x y == (hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \x y -> - vertexCount % connect x y >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> - vertexCount % connect x y <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \x y -> - edgeCount % connect x y >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \x y -> - edgeCount % connect x y >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y `div` 2" $ \x y -> - edgeCount % connect x y >= vertexCount x * vertexCount y `div` 2 - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> - edgeCount % connect x y <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount % connect 1 2 == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount % connect 1 2 == 1 - -testVertices :: Testsuite -> IO () -testVertices (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertices ============" - test "vertices [] == empty" $ - vertices [] == id % empty - - test "vertices [x] == vertex x" $ \x -> - vertices [x] == id % vertex x - - test "hasVertex x . vertices == elem x" $ \x xs -> - hasVertex x % vertices xs == elem x xs - - test "vertexCount . vertices == length . nub" $ \xs -> - vertexCount % vertices xs == (length . nubOrd) xs - - test "vertexSet . vertices == Set.fromList" $ \xs -> - vertexSet % vertices xs == Set.fromList xs - -testEdges :: Testsuite -> IO () -testEdges (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edges ============" - test "edges [] == empty" $ - edges [] == id % empty - - test "edges [(x,y)] == edge x y" $ \x y -> - edges [(x,y)] == id % edge x y - - test "edgeCount . edges == length . nub" $ \xs -> - edgeCount % edges xs == (length . nubOrd) xs - -testSymmetricEdges :: Testsuite -> IO () -testSymmetricEdges (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edges ============" - test "edges [] == empty" $ - edges [] == id % empty - - test "edges [(x,y)] == edge x y" $ \x y -> - edges [(x,y)] == id % edge x y - - test "edges [(x,y), (y,x)] == edge x y" $ \x y -> - edges [(x,y), (y,x)] == id % edge x y - -testOverlays :: Testsuite -> IO () -testOverlays (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "overlays ============" - test "overlays [] == empty" $ - overlays [] == id % empty - - test "overlays [x] == x" $ \x -> - overlays [x] == id % x - - test "overlays [x,y] == overlay x y" $ \x y -> - overlays [x,y] == id % overlay x y - - test "overlays == foldr overlay empty" $ size10 $ \xs -> - overlays xs == id % foldr overlay empty xs - - test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> - isEmpty % overlays xs == all isEmpty xs - -testConnects :: Testsuite -> IO () -testConnects (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "connects ============" - test "connects [] == empty" $ - connects [] == id % empty - - test "connects [x] == x" $ \x -> - connects [x] == id % x - - test "connects [x,y] == connect x y" $ \x y -> - connects [x,y] == id % connect x y - - test "connects == foldr connect empty" $ size10 $ \xs -> - connects xs == id % foldr connect empty xs - - test "isEmpty . connects == all isEmpty" $ size10 $ \xs -> - isEmpty % connects xs == all isEmpty xs - -testSymmetricConnects :: Testsuite -> IO () -testSymmetricConnects t@(Testsuite _ (%)) = do - testConnects t - test "connects == connects . reverse" $ size10 $ \xs -> - connects xs == id % connects (reverse xs) - -testStars :: Testsuite -> IO () -testStars (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "stars ============" - test "stars [] == empty" $ - stars [] == id % empty - - test "stars [(x, [])] == vertex x" $ \x -> - stars [(x, [])] == id % vertex x - - test "stars [(x, [y])] == edge x y" $ \x y -> - stars [(x, [y])] == id % edge x y - - test "stars [(x, ys)] == star x ys" $ \x ys -> - stars [(x, ys)] == id % star x ys - - test "stars == overlays . map (uncurry star)" $ \xs -> - stars xs == id % overlays (map (uncurry star) xs) - - test "stars . adjacencyList == id" $ \x -> - (stars . adjacencyList) x == id % x - - test "overlay (stars xs) (stars ys) == stars (xs ++ ys)" $ \xs ys -> - overlay (stars xs) % stars ys == stars (xs ++ ys) - -testFromAdjacencySets :: Testsuite -> IO () -testFromAdjacencySets (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencySets ============" - test "fromAdjacencySets [] == empty" $ - fromAdjacencySets [] == id % empty - - test "fromAdjacencySets [(x, Set.empty)] == vertex x" $ \x -> - fromAdjacencySets [(x, Set.empty)] == id % vertex x - - test "fromAdjacencySets [(x, Set.singleton y)] == edge x y" $ \x y -> - fromAdjacencySets [(x, Set.singleton y)] == id % edge x y - - test "fromAdjacencySets . map (fmap Set.fromList) == stars" $ \x -> - (fromAdjacencySets . map (fmap Set.fromList)) x == id % stars x - - test "overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencySets xs) % fromAdjacencySets ys == fromAdjacencySets (xs ++ ys) - -testFromAdjacencyIntSets :: Testsuite -> IO () -testFromAdjacencyIntSets (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyIntSets ============" - test "fromAdjacencyIntSets [] == empty" $ - fromAdjacencyIntSets [] == id % empty - - test "fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x" $ \x -> - fromAdjacencyIntSets [(x, IntSet.empty)] == id % vertex x - - test "fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y" $ \x y -> - fromAdjacencyIntSets [(x, IntSet.singleton y)] == id % edge x y - - test "fromAdjacencyIntSets . map (fmap IntSet.fromList) == stars" $ \x -> - (fromAdjacencyIntSets . map (fmap IntSet.fromList)) x == id % stars x - - test "overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencyIntSets xs) % fromAdjacencyIntSets ys == fromAdjacencyIntSets (xs ++ ys) - -testIsSubgraphOf :: Testsuite -> IO () -testIsSubgraphOf (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \x -> - isSubgraphOf empty % x == True - - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) % empty == False - - test "isSubgraphOf x (overlay x y) == True" $ \x y -> - isSubgraphOf x % overlay x y == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> - isSubgraphOf (overlay x y) % connect x y == True - - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs) % circuit xs == True - - test "isSubgraphOf x y ==> x <= y" $ \x z -> - let y = x + z -- Make sure we hit the precondition - in isSubgraphOf x % y ==> x <= y - -testSymmetricIsSubgraphOf :: Testsuite -> IO () -testSymmetricIsSubgraphOf t@(Testsuite _ (%)) = do - testIsSubgraphOf t - test "isSubgraphOf (edge x y) (edge y x) == True" $ \x y -> - isSubgraphOf (edge x y) % edge y x == True - -testToGraphDefault :: Testsuite -> IO () -testToGraphDefault (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" - test "toGraph == foldg Empty Vertex Overlay Connect" $ \x -> - toGraph % x == foldg G.Empty G.Vertex G.Overlay G.Connect x - - test "foldg == Algebra.Graph.foldg . toGraph" $ \e (apply -> v) (applyFun2 -> o) (applyFun2 -> c) x -> - foldg e v o c x == (G.foldg (e :: Int) v o c . toGraph) % x - - test "isEmpty == foldg True (const False) (&&) (&&)" $ \x -> - isEmpty x == foldg True (const False) (&&) (&&) % x - - test "size == foldg 1 (const 1) (+) (+)" $ \x -> - size x == foldg 1 (const 1) (+) (+) % x - - test "hasVertex x == foldg False (==x) (||) (||)" $ \x y -> - hasVertex x y == foldg False (==x) (||) (||) % y - - test "hasEdge x y == Algebra.Graph.hasEdge x y . toGraph" $ \x y z -> - hasEdge x y z == (G.hasEdge x y . toGraph) % z - - test "vertexCount == Set.size . vertexSet" $ \x -> - vertexCount x == (Set.size . vertexSet) % x - - test "edgeCount == Set.size . edgeSet" $ \x -> - edgeCount x == (Set.size . edgeSet) % x - - test "vertexList == Set.toAscList . vertexSet" $ \x -> - vertexList x == (Set.toAscList . vertexSet) % x - - test "edgeList == Set.toAscList . edgeSet" $ \x -> - edgeList x == (Set.toAscList . edgeSet) % x - - test "vertexSet == foldg Set.empty Set.singleton Set.union Set.union" $ \x -> - vertexSet x == foldg Set.empty Set.singleton Set.union Set.union % x - - test "vertexIntSet == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union" $ \x -> - vertexIntSet x == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union % x - - test "edgeSet == Algebra.Graph.AdjacencyMap.edgeSet . foldg empty vertex overlay connect" $ \x -> - edgeSet x == (AM.edgeSet . foldg empty vertex overlay connect) % x - - test "preSet x == Algebra.Graph.AdjacencyMap.preSet x . toAdjacencyMap" $ \x y -> - preSet x y == (AM.preSet x . toAdjacencyMap) % y - - test "preIntSet x == Algebra.Graph.AdjacencyIntMap.preIntSet x . toAdjacencyIntMap" $ \x y -> - preIntSet x y == (AIM.preIntSet x . toAdjacencyIntMap) % y - - test "postSet x == Algebra.Graph.AdjacencyMap.postSet x . toAdjacencyMap" $ \x y -> - postSet x y == (AM.postSet x . toAdjacencyMap) % y - - test "postIntSet x == Algebra.Graph.AdjacencyIntMap.postIntSet x . toAdjacencyIntMap" $ \x y -> - postIntSet x y == (AIM.postIntSet x . toAdjacencyIntMap) % y - - test "adjacencyList == Algebra.Graph.AdjacencyMap.adjacencyList . toAdjacencyMap" $ \x -> - adjacencyList x == (AM.adjacencyList . toAdjacencyMap) % x - - test "adjacencyMap == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMap" $ \x -> - adjacencyMap x == (AM.adjacencyMap . toAdjacencyMap) % x - - test "adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMap" $ \x -> - adjacencyIntMap x == (AIM.adjacencyIntMap . toAdjacencyIntMap) % x - - test "adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMapTranspose" $ \x -> - adjacencyMapTranspose x == (AM.adjacencyMap . toAdjacencyMapTranspose) % x - - test "adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMapTranspose" $ \x -> - adjacencyIntMapTranspose x == (AIM.adjacencyIntMap . toAdjacencyIntMapTranspose) % x - - test "dfsForest == Algebra.Graph.AdjacencyMap.dfsForest . toAdjacencyMap" $ \x -> - dfsForest x == (AM.dfsForest . toAdjacencyMap) % x - - test "dfsForestFrom vs == Algebra.Graph.AdjacencyMap.dfsForestFrom vs . toAdjacencyMap" $ \vs x -> - dfsForestFrom vs x == (AM.dfsForestFrom vs . toAdjacencyMap) % x - - test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> - dfs vs x == (AM.dfs vs . toAdjacencyMap) % x - - test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> - reachable x y == (AM.reachable x . toAdjacencyMap) % y - - test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> - topSort x == (AM.topSort . toAdjacencyMap) % x - - test "isAcyclic == Algebra.Graph.AdjacencyMap.isAcyclic . toAdjacencyMap" $ \x -> - isAcyclic x == (AM.isAcyclic . toAdjacencyMap) % x - - test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> - isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x - - test "toAdjacencyMap == foldg empty vertex overlay connect" $ \x -> - toAdjacencyMap x == foldg AM.empty AM.vertex AM.overlay AM.connect % x - - test "toAdjacencyMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> - toAdjacencyMapTranspose x == foldg AM.empty AM.vertex AM.overlay (flip AM.connect) % x - - test "toAdjacencyIntMap == foldg empty vertex overlay connect" $ \x -> - toAdjacencyIntMap x == foldg AIM.empty AIM.vertex AIM.overlay AIM.connect % x - - test "toAdjacencyIntMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> - toAdjacencyIntMapTranspose x == foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) % x - - test "isDfsForestOf f == Algebra.Graph.AdjacencyMap.isDfsForestOf f . toAdjacencyMap" $ \f x -> - isDfsForestOf f x == (AM.isDfsForestOf f . toAdjacencyMap) % x - - test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> - isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x - --- TODO: We currently do not test 'edgeSet'. -testSymmetricToGraphDefault :: Testsuite -> IO () -testSymmetricToGraphDefault (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" - test "toGraph == foldg Empty Vertex Overlay Connect" $ \x -> - toGraph % x == foldg G.Empty G.Vertex G.Overlay G.Connect x - - test "foldg == Algebra.Graph.foldg . toGraph" $ \e (apply -> v) (applyFun2 -> o) (applyFun2 -> c) x -> - foldg e v o c x == (G.foldg (e :: Int) v o c . toGraph) % x - - test "isEmpty == foldg True (const False) (&&) (&&)" $ \x -> - isEmpty x == foldg True (const False) (&&) (&&) % x - - test "size == foldg 1 (const 1) (+) (+)" $ \x -> - size x == foldg 1 (const 1) (+) (+) % x - - test "hasVertex x == foldg False (==x) (||) (||)" $ \x y -> - hasVertex x y == foldg False (==x) (||) (||) % y - - test "hasEdge x y == Algebra.Graph.hasEdge x y . toGraph" $ \x y z -> - hasEdge x y z == (G.hasEdge x y . toGraph) % z - - test "vertexCount == Set.size . vertexSet" $ \x -> - vertexCount x == (Set.size . vertexSet) % x - - test "edgeCount == Set.size . edgeSet" $ \x -> - edgeCount x == (Set.size . edgeSet) % x - - test "vertexList == Set.toAscList . vertexSet" $ \x -> - vertexList x == (Set.toAscList . vertexSet) % x - - test "edgeList == Set.toAscList . edgeSet" $ \x -> - edgeList x == (Set.toAscList . edgeSet) % x - - test "vertexSet == foldg Set.empty Set.singleton Set.union Set.union" $ \x -> - vertexSet x == foldg Set.empty Set.singleton Set.union Set.union % x - - test "vertexIntSet == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union" $ \x -> - vertexIntSet x == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union % x - - test "adjacencyList == Algebra.Graph.AdjacencyMap.adjacencyList . toAdjacencyMap" $ \x -> - adjacencyList x == (AM.adjacencyList . toAdjacencyMap) % x - - test "adjacencyMap == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMap" $ \x -> - adjacencyMap x == (AM.adjacencyMap . toAdjacencyMap) % x - - test "adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMap" $ \x -> - adjacencyIntMap x == (AIM.adjacencyIntMap . toAdjacencyIntMap) % x - - test "adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMapTranspose" $ \x -> - adjacencyMapTranspose x == (AM.adjacencyMap . toAdjacencyMapTranspose) % x - - test "adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMapTranspose" $ \x -> - adjacencyIntMapTranspose x == (AIM.adjacencyIntMap . toAdjacencyIntMapTranspose) % x - - test "dfsForest == Algebra.Graph.AdjacencyMap.dfsForest . toAdjacencyMap" $ \x -> - dfsForest x == (AM.dfsForest . toAdjacencyMap) % x - - test "dfsForestFrom vs == Algebra.Graph.AdjacencyMap.dfsForestFrom vs . toAdjacencyMap" $ \vs x -> - dfsForestFrom vs x == (AM.dfsForestFrom vs . toAdjacencyMap) % x - - test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> - dfs vs x == (AM.dfs vs . toAdjacencyMap) % x - - test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> - reachable x y == (AM.reachable x . toAdjacencyMap) % y - - test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> - topSort x == (AM.topSort . toAdjacencyMap) % x - - test "isAcyclic == Algebra.Graph.AdjacencyMap.isAcyclic . toAdjacencyMap" $ \x -> - isAcyclic x == (AM.isAcyclic . toAdjacencyMap) % x - - test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> - isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x - - test "toAdjacencyMap == foldg empty vertex overlay connect" $ \x -> - toAdjacencyMap x == foldg AM.empty AM.vertex AM.overlay AM.connect % x - - test "toAdjacencyMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> - toAdjacencyMapTranspose x == foldg AM.empty AM.vertex AM.overlay (flip AM.connect) % x - - test "toAdjacencyIntMap == foldg empty vertex overlay connect" $ \x -> - toAdjacencyIntMap x == foldg AIM.empty AIM.vertex AIM.overlay AIM.connect % x - - test "toAdjacencyIntMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> - toAdjacencyIntMapTranspose x == foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) % x - - test "isDfsForestOf f == Algebra.Graph.AdjacencyMap.isDfsForestOf f . toAdjacencyMap" $ \f x -> - isDfsForestOf f x == (AM.isDfsForestOf f . toAdjacencyMap) % x - - test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> - isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x - -testFoldg :: Testsuite -> IO () -testFoldg (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "foldg ============" - test "foldg empty vertex overlay connect == id" $ \x -> - foldg empty vertex overlay connect % x == id x - - test "foldg empty vertex overlay (flip connect) == transpose" $ \x -> - foldg empty vertex overlay (flip connect) % x == transpose x - - test "foldg 1 (const 1) (+) (+) == size" $ \x -> - foldg 1 (const 1) (+) (+) % x == size x - - test "foldg True (const False) (&&) (&&) == isEmpty" $ \x -> - foldg True (const False) (&&) (&&) % x == isEmpty x - -testIsEmpty :: Testsuite -> IO () -testIsEmpty (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isEmpty ============" - test "isEmpty empty == True" $ - isEmpty % empty == True - - test "isEmpty (overlay empty empty) == True" $ - isEmpty % overlay empty empty == True - - test "isEmpty (vertex x) == False" $ \x -> - isEmpty % vertex x == False - - test "isEmpty (removeVertex x $ vertex x) == True" $ \x -> - isEmpty (removeVertex x % vertex x) == True - - test "isEmpty (removeEdge x y $ edge x y) == False" $ \x y -> - isEmpty (removeEdge x y % edge x y) == False - -testSize :: Testsuite -> IO () -testSize (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "size ============" - test "size empty == 1" $ - size % empty == 1 - - test "size (vertex x) == 1" $ \x -> - size % vertex x == 1 - - test "size (overlay x y) == size x + size y" $ \x y -> - size % overlay x y == size x + size y - - test "size (connect x y) == size x + size y" $ \x y -> - size % connect x y == size x + size y - - test "size x >= 1" $ \x -> - size % x >= 1 - - test "size x >= vertexCount x" $ \x -> - size % x >= vertexCount x - -testHasVertex :: Testsuite -> IO () -testHasVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "hasVertex ============" - test "hasVertex x empty == False" $ \x -> - hasVertex x % empty == False - - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x % vertex x == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 % vertex 2 == False - - test "hasVertex x . removeVertex x == const False" $ \x y -> - (hasVertex x . removeVertex x) y == const False % y - -testHasEdge :: Testsuite -> IO () -testHasEdge (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "hasEdge ============" - test "hasEdge x y empty == False" $ \x y -> - hasEdge x y % empty == False - - test "hasEdge x y (vertex z) == False" $ \x y z -> - hasEdge x y % vertex z == False - - test "hasEdge x y (edge x y) == True" $ \x y -> - hasEdge x y % edge x y == True - - test "hasEdge x y . removeEdge x y == const False" $ \x y z -> - (hasEdge x y . removeEdge x y) z == const False % z - - test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do - (u, v) <- elements ((x, y) : edgeList z) - return $ hasEdge u v z == elem (u, v) (edgeList % z) - -testSymmetricHasEdge :: Testsuite -> IO () -testSymmetricHasEdge (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "hasEdge ============" - test "hasEdge x y empty == False" $ \x y -> - hasEdge x y % empty == False - - test "hasEdge x y (vertex z) == False" $ \x y z -> - hasEdge x y % vertex z == False - - test "hasEdge x y (edge x y) == True" $ \x y -> - hasEdge x y % edge x y == True - - test "hasEdge x y (edge y x) == True" $ \x y -> - hasEdge x y % edge y x == True - - test "hasEdge x y . removeEdge x y == const False" $ \x y z -> - (hasEdge x y . removeEdge x y) z == const False % z - - test "hasEdge x y == elem (min x y, max x y) . edgeList" $ \x y z -> do - (u, v) <- elements ((x, y) : edgeList z) - return $ hasEdge u v z == elem (min u v, max u v) (edgeList % z) - -testVertexCount :: Testsuite -> IO () -testVertexCount (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount % empty == 0 - - test "vertexCount (vertex x) == 1" $ \x -> - vertexCount % (vertex x) == 1 - - test "vertexCount == length . vertexList" $ \x -> - vertexCount % x == (length . vertexList) x - - test "vertexCount x < vertexCount y ==> x < y" $ \x y -> - if vertexCount x < vertexCount % y - then property (x < y) - else (vertexCount x > vertexCount y ==> x > y) - -testEdgeCount :: Testsuite -> IO () -testEdgeCount (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount % empty == 0 - - test "edgeCount (vertex x) == 0" $ \x -> - edgeCount % vertex x == 0 - - test "edgeCount (edge x y) == 1" $ \x y -> - edgeCount % edge x y == 1 - - test "edgeCount == length . edgeList" $ \x -> - edgeCount % x == (length . edgeList) x - -testVertexList :: Testsuite -> IO () -testVertexList (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexList ============" - test "vertexList empty == []" $ - vertexList % empty == [] - - test "vertexList (vertex x) == [x]" $ \x -> - vertexList % vertex x == [x] - - test "vertexList . vertices == nub . sort" $ \xs -> - vertexList % vertices xs == (nubOrd . sort) xs - -testEdgeList :: Testsuite -> IO () -testEdgeList (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edgeList ============" - test "edgeList empty == []" $ - edgeList % empty == [] - - test "edgeList (vertex x) == []" $ \x -> - edgeList % vertex x == [] - - test "edgeList (edge x y) == [(x,y)]" $ \x y -> - edgeList % edge x y == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList % star 2 [3,1] == [(2,1), (2,3)] - - test "edgeList . edges == nub . sort" $ \xs -> - edgeList % edges xs == (nubOrd . sort) xs - -testSymmetricEdgeList :: Testsuite -> IO () -testSymmetricEdgeList (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edgeList ============" - test "edgeList empty == []" $ - edgeList % empty == [] - - test "edgeList (vertex x) == []" $ \x -> - edgeList % vertex x == [] - - test "edgeList (edge x y) == [(min x y, max y x)]" $ \x y -> - edgeList % edge x y == [(min x y, max y x)] - - test "edgeList (star 2 [3,1]) == [(1,2), (2,3)]" $ - edgeList % star 2 [3,1] == [(1,2), (2,3)] - -testAdjacencyList :: Testsuite -> IO () -testAdjacencyList (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "adjacencyList ============" - test "adjacencyList empty == []" $ - adjacencyList % empty == [] - - test "adjacencyList (vertex x) == [(x, [])]" $ \x -> - adjacencyList % vertex x == [(x, [])] - - test "adjacencyList (edge 1 2) == [(1, [2]), (2, [])]" $ - adjacencyList % edge 1 2 == [(1, [2]), (2, [])] - - test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ - adjacencyList % star 2 [3,1] == [(1, []), (2, [1,3]), (3, [])] - -testSymmetricAdjacencyList :: Testsuite -> IO () -testSymmetricAdjacencyList (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "adjacencyList ============" - test "adjacencyList empty == []" $ - adjacencyList % empty == [] - - test "adjacencyList (vertex x) == [(x, [])]" $ \x -> - adjacencyList % vertex x == [(x, [])] - - test "adjacencyList (edge 1 2) == [(1, [2]), (2, [1])]" $ - adjacencyList % edge 1 2 == [(1, [2]), (2, [1])] - - test "adjacencyList (star 2 [3,1]) == [(1, [2]), (2, [1,3]), (3, [2])]" $ - adjacencyList % star 2 [3,1] == [(1, [2]), (2, [1,3]), (3, [2])] - -testVertexSet :: Testsuite -> IO () -testVertexSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexSet ============" - test "vertexSet empty == Set.empty" $ - vertexSet % empty == Set.empty - - test "vertexSet . vertex == Set.singleton" $ \x -> - vertexSet % vertex x == Set.singleton x - - test "vertexSet . vertices == Set.fromList" $ \xs -> - vertexSet % vertices xs == Set.fromList xs - -testVertexIntSet :: Testsuite -> IO () -testVertexIntSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexIntSet ============" - test "vertexIntSet empty == IntSet.empty" $ - vertexIntSet % empty == IntSet.empty - - test "vertexIntSet . vertex == IntSet.singleton" $ \x -> - vertexIntSet % vertex x == IntSet.singleton x - - test "vertexIntSet . vertices == IntSet.fromList" $ \xs -> - vertexIntSet % vertices xs == IntSet.fromList xs - - test "vertexIntSet . clique == IntSet.fromList" $ \xs -> - vertexIntSet % clique xs == IntSet.fromList xs - -testEdgeSet :: Testsuite -> IO () -testEdgeSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet % empty == Set.empty - - test "edgeSet (vertex x) == Set.empty" $ \x -> - edgeSet % vertex x == Set.empty - - test "edgeSet (edge x y) == Set.singleton (x,y)" $ \x y -> - edgeSet % edge x y == Set.singleton (x,y) - - test "edgeSet . edges == Set.fromList" $ \xs -> - edgeSet % edges xs == Set.fromList xs - -testSymmetricEdgeSet :: Testsuite -> IO () -testSymmetricEdgeSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet % empty == Set.empty - - test "edgeSet (vertex x) == Set.empty" $ \x -> - edgeSet % vertex x == Set.empty - - test "edgeSet ('edge' x y) == Set.'Set.singleton' (min x y, max x y)" $ \x y -> - edgeSet % edge x y == Set.singleton (min x y, max x y) - -testPreSet :: Testsuite -> IO () -testPreSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "preSet ============" - test "preSet x empty == Set.empty" $ \x -> - preSet x % empty == Set.empty - - test "preSet x (vertex x) == Set.empty" $ \x -> - preSet x % vertex x == Set.empty - - test "preSet 1 (edge 1 2) == Set.empty" $ - preSet 1 % edge 1 2 == Set.empty - - test "preSet y (edge x y) == Set.fromList [x]" $ \x y -> - preSet y % edge x y == Set.fromList [x] - -testPostSet :: Testsuite -> IO () -testPostSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "postSet ============" - test "postSet x empty == Set.empty" $ \x -> - postSet x % empty == Set.empty - - test "postSet x (vertex x) == Set.empty" $ \x -> - postSet x % vertex x == Set.empty - - test "postSet x (edge x y) == Set.fromList [y]" $ \x y -> - postSet x % edge x y == Set.fromList [y] - - test "postSet 2 (edge 1 2) == Set.empty" $ - postSet 2 % edge 1 2 == Set.empty - -testPreIntSet :: Testsuite -> IO () -testPreIntSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "preIntSet ============" - test "preIntSet x empty == IntSet.empty" $ \x -> - preIntSet x % empty == IntSet.empty - - test "preIntSet x (vertex x) == IntSet.empty" $ \x -> - preIntSet x % vertex x == IntSet.empty - - test "preIntSet 1 (edge 1 2) == IntSet.empty" $ - preIntSet 1 % edge 1 2 == IntSet.empty - - test "preIntSet y (edge x y) == IntSet.fromList [x]" $ \x y -> - preIntSet y % edge x y == IntSet.fromList [x] - -testPostIntSet :: Testsuite -> IO () -testPostIntSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "postIntSet ============" - test "postIntSet x empty == IntSet.empty" $ \x -> - postIntSet x % empty == IntSet.empty - - test "postIntSet x (vertex x) == IntSet.empty" $ \x -> - postIntSet x % vertex x == IntSet.empty - - test "postIntSet 2 (edge 1 2) == IntSet.empty" $ - postIntSet 2 % edge 1 2 == IntSet.empty - - test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> - postIntSet x % edge x y == IntSet.fromList [y] - -testNeighbours :: Testsuite -> IO () -testNeighbours (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "neighbours ============" - test "neighbours x empty == Set.empty" $ \x -> - neighbours x % empty == Set.empty - - test "neighbours x (vertex x) == Set.empty" $ \x -> - neighbours x % vertex x == Set.empty - - test "neighbours x (edge x y) == Set.fromList [y]" $ \x y -> - neighbours x % edge x y == Set.fromList [y] - - test "neighbours y (edge x y) == Set.fromList [x]" $ \x y -> - neighbours y % edge x y == Set.fromList [x] - -testPath :: Testsuite -> IO () -testPath (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "path ============" - test "path [] == empty" $ - path [] == id % empty - - test "path [x] == vertex x" $ \x -> - path [x] == id % vertex x - - test "path [x,y] == edge x y" $ \x y -> - path [x,y] == id % edge x y - -testSymmetricPath :: Testsuite -> IO () -testSymmetricPath t@(Testsuite _ (%)) = do - testPath t - test "path == path . reverse" $ \xs -> - path xs == id % path (reverse xs) - -testCircuit :: Testsuite -> IO () -testCircuit (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "circuit ============" - test "circuit [] == empty" $ - circuit [] == id % empty - - test "circuit [x] == edge x x" $ \x -> - circuit [x] == id % edge x x - - test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> - circuit [x,y] == id % edges [(x,y), (y,x)] - -testSymmetricCircuit :: Testsuite -> IO () -testSymmetricCircuit t@(Testsuite _ (%)) = do - testCircuit t - test "circuit == circuit . reverse" $ \xs -> - circuit xs == id % circuit (reverse xs) - -testClique :: Testsuite -> IO () -testClique (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "clique ============" - test "clique [] == empty" $ - clique [] == id % empty - - test "clique [x] == vertex x" $ \x -> - clique [x] == id % vertex x - - test "clique [x,y] == edge x y" $ \x y -> - clique [x,y] == id % edge x y - - test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \x y z -> - clique [x,y,z] == id % edges [(x,y), (x,z), (y,z)] - - test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys -> - clique (xs ++ ys) == connect (clique xs) % clique ys - -testSymmetricClique :: Testsuite -> IO () -testSymmetricClique t@(Testsuite _ (%)) = do - testClique t - test "clique == clique . reverse" $ \xs-> - clique xs == id % clique (reverse xs) - -testBiclique :: Testsuite -> IO () -testBiclique (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] == id % empty - - test "biclique [x] [] == vertex x" $ \x -> - biclique [x] [] == id % vertex x - - test "biclique [] [y] == vertex y" $ \y -> - biclique [] [y] == id % vertex y - - test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \x1 x2 y1 y2 -> - biclique [x1,x2] [y1,y2] == id % edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] - - test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> - biclique xs ys == connect (vertices xs) % vertices ys - -testStar :: Testsuite -> IO () -testStar (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "star ============" - test "star x [] == vertex x" $ \x -> - star x [] == id % vertex x - - test "star x [y] == edge x y" $ \x y -> - star x [y] == id % edge x y - - test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> - star x [y,z] == id % edges [(x,y), (x,z)] - - test "star x ys == connect (vertex x) (vertices ys)" $ \x ys -> - star x ys == connect (vertex x) % (vertices ys) - -testTree :: Testsuite -> IO () -testTree (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "tree ============" - test "tree (Node x []) == vertex x" $ \x -> - tree (Node x []) == id % vertex x - - test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \x y z -> - tree (Node x [Node y [Node z []]]) == id % path [x,y,z] - - test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \x y z -> - tree (Node x [Node y [], Node z []]) == id % star x [y,z] - - test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ - tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == id % edges [(1,2), (1,3), (3,4), (3,5)] - -testForest :: Testsuite -> IO () -testForest (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "forest ============" - test "forest [] == empty" $ - forest [] == id % empty - - test "forest [x] == tree x" $ \x -> - forest [x] == id % tree x - - test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ - forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == id % edges [(1,2), (1,3), (4,5)] - - test "forest == overlays . map tree" $ \x -> - forest x == id % (overlays . map tree) x - -testRemoveVertex :: Testsuite -> IO () -testRemoveVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "removeVertex ============" - test "removeVertex x (vertex x) == empty" $ \x -> - removeVertex x % vertex x == empty - - test "removeVertex 1 (vertex 2) == vertex 2" $ - removeVertex 1 % (vertex 2) == vertex 2 - - test "removeVertex x (edge x x) == empty" $ \x -> - removeVertex x % (edge x x) == empty - - test "removeVertex 1 (edge 1 2) == vertex 2" $ - removeVertex 1 % (edge 1 2) == vertex 2 - - test "removeVertex x . removeVertex x == removeVertex x" $ \x y -> - (removeVertex x . removeVertex x) y == removeVertex x % y - -testRemoveEdge :: Testsuite -> IO () -testRemoveEdge (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "removeEdge ============" - test "removeEdge x y (edge x y) == vertices [x,y]" $ \x y -> - removeEdge x y % edge x y == vertices [x,y] - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> - (removeEdge x y . removeEdge x y) z == removeEdge x y % z - - test "removeEdge x y . removeVertex x == removeVertex x" $ \x y z -> - (removeEdge x y . removeVertex x) z == removeVertex x % z - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 % (1 * 1 * 2 * 2) == 1 * 2 * 2 - - test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ - removeEdge 1 2 % (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 - - -- TODO: Ouch. Generic tests are becoming awkward. We need a better way. - when (prefix == "Fold." || prefix == "Graph.") $ do - test "size (removeEdge x y z) <= 3 * size z" $ \x y z -> - size % (removeEdge x y z) <= 3 * size z - -testSymmetricRemoveEdge :: Testsuite -> IO () -testSymmetricRemoveEdge t@(Testsuite _ (%)) = do - testRemoveEdge t - test "removeEdge x y == removeEdge y x" $ \x y z -> - removeEdge x y z == removeEdge y x % z - -testReplaceVertex :: Testsuite -> IO () -testReplaceVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "replaceVertex ============" - test "replaceVertex x x == id" $ \x y -> - replaceVertex x x % y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \x y -> - replaceVertex x y % vertex x == vertex y - - test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> - replaceVertex x y % z == mergeVertices (== x) y z - -testMergeVertices :: Testsuite -> IO () -testMergeVertices (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "mergeVertices ============" - test "mergeVertices (const False) x == id" $ \x y -> - mergeVertices (const False) x % y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \x y z -> - mergeVertices (== x) y % z == replaceVertex x y z - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 % (0 * 2) == 1 * 1 - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 % (3 + 4 * 5) == 4 * 1 - -testTranspose :: Testsuite -> IO () -testTranspose (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "transpose ============" - test "transpose empty == empty" $ - transpose % empty == empty - - test "transpose (vertex x) == vertex x" $ \x -> - transpose % vertex x == vertex x - - test "transpose (edge x y) == edge y x" $ \x y -> - transpose % edge x y == edge y x - - test "transpose . transpose == id" $ size10 $ \x -> - (transpose . transpose) % x == x - - test "edgeList . transpose == sort . map swap . edgeList" $ \x -> - edgeList % transpose x == (sort . map swap . edgeList) x - -testGmap :: Testsuite -> IO () -testGmap (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "gmap ============" - test "gmap f empty == empty" $ \(apply -> f) -> - gmap f % empty == empty - - test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> - gmap f % vertex x == vertex (f x) - - test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) x y -> - gmap f % edge x y == edge (f x) (f y) - - test "gmap id == id" $ \x -> - gmap id % x == x - - test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> - (gmap f . gmap g) x == gmap (f . g) % x - -testInduce :: Testsuite -> IO () -testInduce (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "induce ============" - test "induce (const True ) x == x" $ \x -> - induce (const True ) % x == x - - test "induce (const False) x == empty" $ \x -> - induce (const False) % x == empty - - test "induce (/= x) == removeVertex x" $ \x y -> - induce (/= x) % y == removeVertex x y - - test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) y -> - (induce p . induce q) % y == induce (\x -> p x && q x) y - - test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> - isSubgraphOf (induce p x) % x == True - -testCompose :: Testsuite -> IO () -testCompose (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "compose ============" - test "compose empty x == empty" $ \x -> - compose empty % x == empty - - test "compose x empty == empty" $ \x -> - compose x % empty == empty - - test "compose (vertex x) y == empty" $ \x y -> - compose (vertex x) % y == empty - - test "compose x (vertex y) == empty" $ \x y -> - compose x % (vertex y) == empty - - test "compose x (compose y z) == compose (compose x y) z" $ size10 $ \x y z -> - compose x % (compose y z) == compose (compose x y) z - - test "compose x (overlay y z) == overlay (compose x y) (compose x z)" $ size10 $ \x y z -> - compose x % (overlay y z) == overlay (compose x y) (compose x z) - - test "compose (overlay x y) z == overlay (compose x z) (compose y z)" $ size10 $ \x y z -> - compose (overlay x y) % z == overlay (compose x z) (compose y z) - - test "compose (edge x y) (edge y z) == edge x z" $ \x y z -> - compose (edge x y) % (edge y z) == edge x z - - test "compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)]" $ - compose (path [1..5])%(path [1..5]) == edges [(1,3),(2,4),(3,5)] - - test "compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4]" $ - compose (circuit [1..5])%(circuit [1..5]) == circuit [1,3,5,2,4] - -testClosure :: Testsuite -> IO () -testClosure (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "closure ============" - test "closure empty == empty" $ - closure % empty == empty - - test "closure (vertex x) == edge x x" $ \x -> - closure % (vertex x) == edge x x - - test "closure (edge x x) == edge x x" $ \x -> - closure % (edge x x) == edge x x - - test "closure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> - closure % (edge x y) == edges [(x,x), (x,y), (y,y)] - - test "closure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \xs -> - closure % (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs) - - test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> - closure % x == (reflexiveClosure . transitiveClosure) x - - test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> - closure % x == (transitiveClosure . reflexiveClosure) x - - test "closure . closure == closure" $ size10 $ \x -> - (closure . closure) % x == closure x - - test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \x y -> - postSet x % (closure y) == Set.fromList (reachable x y) - -testReflexiveClosure :: Testsuite -> IO () -testReflexiveClosure (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "reflexiveClosure ============" - test "reflexiveClosure empty == empty" $ - reflexiveClosure % empty == empty - - test "reflexiveClosure (vertex x) == edge x x" $ \x -> - reflexiveClosure % vertex x == edge x x - - test "reflexiveClosure (edge x x) == edge x x" $ \x -> - reflexiveClosure % edge x x == edge x x - - test "reflexiveClosure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> - reflexiveClosure % edge x y == edges [(x,x), (x,y), (y,y)] - - test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ \x -> - (reflexiveClosure . reflexiveClosure) x == reflexiveClosure % x - -testSymmetricClosure :: Testsuite -> IO () -testSymmetricClosure (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "symmetricClosure ============" - test "symmetricClosure empty == empty" $ - symmetricClosure % empty == empty - - test "symmetricClosure (vertex x) == vertex x" $ \x -> - symmetricClosure % vertex x == vertex x - - test "symmetricClosure (edge x y) == edges [(x,y), (y,x)]" $ \x y -> - symmetricClosure % edge x y == edges [(x,y), (y,x)] - - test "symmetricClosure x == overlay x (transpose x)" $ \x -> - symmetricClosure % x == overlay x (transpose x) - - test "symmetricClosure . symmetricClosure == symmetricClosure" $ \x -> - (symmetricClosure . symmetricClosure) x == symmetricClosure % x - -testTransitiveClosure :: Testsuite -> IO () -testTransitiveClosure (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "transitiveClosure ============" - test "transitiveClosure empty == empty" $ - transitiveClosure % empty == empty - - test "transitiveClosure (vertex x) == vertex x" $ \x -> - transitiveClosure % (vertex x) == vertex x - - test "transitiveClosure (edge x y) == edge x y" $ \x y -> - transitiveClosure % (edge x y) == edge x y - - test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \xs -> - transitiveClosure % (path $ nubOrd xs) == clique (nubOrd xs) - - test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> - (transitiveClosure . transitiveClosure) x == transitiveClosure % x - -testSplitVertex :: Testsuite -> IO () -testSplitVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "splitVertex ============" - test "splitVertex x [] == removeVertex x" $ \x y -> - splitVertex x [] % y == removeVertex x y - - test "splitVertex x [x] == id" $ \x y -> - splitVertex x [x] % y == y - - test "splitVertex x [y] == replaceVertex x y" $ \x y z -> - splitVertex x [y] % z == replaceVertex x y z - - test "splitVertex 1 [0, 1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ - splitVertex 1 [0, 1] % (1 * (2 + 3)) == (0 + 1) * (2 + 3) - -testBind :: Testsuite -> IO () -testBind (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "bind ============" - test "bind empty f == empty" $ \(apply -> f) -> - bind empty f == id % empty - - test "bind (vertex x) f == f x" $ \(apply -> f) x -> - bind (vertex x) f == id % f x - - test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> - bind (edge x y) f == connect (f x) % f y - - test "bind (vertices xs) f == overlays (map f xs)" $ size10 $ \xs (apply -> f) -> - bind (vertices xs) f == id % overlays (map f xs) - - test "bind x (const empty) == empty" $ \x -> - bind x (const empty) == id % empty - - test "bind x vertex == x" $ \x -> - bind x vertex == id % x - - test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ size10 $ \x (apply -> f) (apply -> g) -> - bind (bind x f) g == bind (id % x) (\y -> bind (f y) g) - -testSimplify :: Testsuite -> IO () -testSimplify (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "simplify ============" - test "simplify == id" $ \x -> - simplify % x == x - - test "size (simplify x) <= size x" $ \x -> - size % simplify x <= size x - - -testDfsForest :: Testsuite -> IO () -testDfsForest (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfsForest ============" - test "dfsForest empty == []" $ - dfsForest % empty == [] - - test "forest (dfsForest $ edge 1 1) == vertex 1" $ - forest (dfsForest % edge 1 1) == id % vertex 1 - - test "forest (dfsForest $ edge 1 2) == edge 1 2" $ - forest (dfsForest % edge 1 2) == id % edge 1 2 - - test "forest (dfsForest $ edge 2 1) == vertices [1,2]" $ - forest (dfsForest % edge 2 1) == id % vertices [1,2] - - test "isSubgraphOf (forest $ dfsForest x) x == True" $ \x -> - isSubgraphOf (forest $ dfsForest x) % x == True - - test "isDfsForestOf (dfsForest x) x == True" $ \x -> - isDfsForestOf (dfsForest x) % x == True - - test "dfsForest . forest . dfsForest == dfsForest" $ \x -> - dfsForest % forest (dfsForest x) == dfsForest % x - - test "dfsForest (vertices vs) == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> - dfsForest % vertices vs == map (\v -> Node v []) (nub $ sort vs) - - test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ - dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 3 - , subForest = [ Node { rootLabel = 4 - , subForest = [] }]}] - -testDfsForestFrom :: Testsuite -> IO () -testDfsForestFrom (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfsForestFrom ============" - test "dfsForestFrom vs empty == []" $ \vs -> - dfsForestFrom vs % empty == [] - - test "forest (dfsForestFrom [1] $ edge 1 1) == vertex 1" $ - forest (dfsForestFrom [1] % edge 1 1) == id % vertex 1 - - test "forest (dfsForestFrom [1] $ edge 1 2) == edge 1 2" $ - forest (dfsForestFrom [1] % edge 1 2) == id % edge 1 2 - - test "forest (dfsForestFrom [2] $ edge 1 2) == vertex 2" $ - forest (dfsForestFrom [2] % edge 1 2) == id % vertex 2 - - test "forest (dfsForestFrom [3] $ edge 1 2) == empty" $ - forest (dfsForestFrom [3] % edge 1 2) == id % empty - - test "forest (dfsForestFrom [2,1] $ edge 1 2) == vertices [1,2]" $ - forest (dfsForestFrom [2,1] % edge 1 2) == id % vertices [1,2] - - test "isSubgraphOf (forest $ dfsForestFrom vs x) x == True" $ \vs x -> - isSubgraphOf (forest $ dfsForestFrom vs x) % x == True - - test "isDfsForestOf (dfsForestFrom (vertexList x) x) x == True" $ \x -> - isDfsForestOf (dfsForestFrom (vertexList x) x) % x == True - - test "dfsForestFrom (vertexList x) x == dfsForest x" $ \x -> - dfsForestFrom (vertexList x) % x == dfsForest % x - - test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> - dfsForestFrom vs % vertices vs == map (\v -> Node v []) (nub vs) - - test "dfsForestFrom [] x == []" $ \x -> - dfsForestFrom [] % x == [] - - test "dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == " $ - dfsForestFrom [1,4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 4 - , subForest = [] }] - -testDfs :: Testsuite -> IO () -testDfs (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfs ============" - test "dfs vs $ empty == []" $ \vs -> - dfs vs % empty == [] - - test "dfs [1] $ edge 1 1 == [1]" $ - dfs [1] % edge 1 1 == [1] - - test "dfs [1] $ edge 1 2 == [1,2]" $ - dfs [1] % edge 1 2 == [1,2] - - test "dfs [2] $ edge 1 2 == [2]" $ - dfs [2] % edge 1 2 == [2] - - test "dfs [3] $ edge 1 2 == []" $ - dfs [3] % edge 1 2 == [] - - test "dfs [1,2] $ edge 1 2 == [1,2]" $ - dfs [1,2] % edge 1 2 == [1,2] - - test "dfs [2,1] $ edge 1 2 == [2,1]" $ - dfs [2,1] % edge 1 2 == [2,1] - - test "dfs [] $ x == []" $ \x -> - dfs [] % x == [] - - test "dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4]" $ - dfs [1,4] % (3 * (1 + 4) * (1 + 5)) == [1,5,4] - - test "isSubgraphOf (vertices $ dfs vs x) x == True" $ \vs x -> - isSubgraphOf (vertices $ dfs vs x) % x == True - -testReachable :: Testsuite -> IO () -testReachable (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfs ============" - test "reachable x $ empty == []" $ \x -> - reachable x % empty == [] - - test "reachable 1 $ vertex 1 == [1]" $ - reachable 1 % vertex 1 == [1] - - test "reachable 1 $ vertex 2 == []" $ - reachable 1 % vertex 2 == [] - - test "reachable 1 $ edge 1 1 == [1]" $ - reachable 1 % edge 1 1 == [1] - - test "reachable 1 $ edge 1 2 == [1,2]" $ - reachable 1 % edge 1 2 == [1,2] - - test "reachable 4 $ path [1..8] == [4..8]" $ - reachable 4 % path [1..8] == [4..8] - - test "reachable 4 $ circuit [1..8] == [4..8] ++ [1..3]" $ - reachable 4 % circuit [1..8] == [4..8] ++ [1..3] - - test "reachable 8 $ clique [8,7..1] == [8] ++ [1..7]" $ - reachable 8 % clique [8,7..1] == [8] ++ [1..7] - - test "isSubgraphOf (vertices $ reachable x y) y == True" $ \x y -> - isSubgraphOf (vertices $ reachable x y) % y == True - -testTopSort :: Testsuite -> IO () -testTopSort (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "topSort ============" - test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ - topSort % (1 * 2 + 3 * 1) == Just [3,1,2] - - test "topSort (1 * 2 + 2 * 1) == Nothing" $ - topSort % (1 * 2 + 2 * 1) == Nothing - - test "fmap (flip isTopSortOf x) (topSort x) /= Just False" $ \x -> - fmap (flip isTopSortOf x) (topSort % x) /= Just False - -testIsAcyclic :: Testsuite -> IO () -testIsAcyclic (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "testIsAcyclic ============" - test "isAcyclic (1 * 2 + 3 * 1) == True" $ - isAcyclic % (1 * 2 + 3 * 1) == True - - test "isAcyclic (1 * 2 + 2 * 1) == False" $ - isAcyclic % (1 * 2 + 2 * 1) == False - - test "isAcyclic . circuit == null" $ \xs -> - isAcyclic % circuit xs == null xs - - test "isAcyclic == isJust . topSort" $ \x -> - isAcyclic % x == isJust (topSort x) - -testIsDfsForestOf :: Testsuite -> IO () -testIsDfsForestOf (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isDfsForestOf ============" - test "isDfsForestOf [] empty == True" $ - isDfsForestOf [] % empty == True - - test "isDfsForestOf [] (vertex 1) == False" $ - isDfsForestOf [] % (vertex 1) == False - - test "isDfsForestOf [Node 1 []] (vertex 1) == True" $ - isDfsForestOf [Node 1 []] % (vertex 1) == True - - test "isDfsForestOf [Node 1 []] (vertex 2) == False" $ - isDfsForestOf [Node 1 []] % (vertex 2) == False - - test "isDfsForestOf [Node 1 [], Node 1 []] (vertex 1) == False" $ - isDfsForestOf [Node 1 [], Node 1 []] % (vertex 1) == False - - test "isDfsForestOf [Node 1 []] (edge 1 1) == True" $ - isDfsForestOf [Node 1 []] % (edge 1 1) == True - - test "isDfsForestOf [Node 1 []] (edge 1 2) == False" $ - isDfsForestOf [Node 1 []] % (edge 1 2) == False - - test "isDfsForestOf [Node 1 [], Node 2 []] (edge 1 2) == False" $ - isDfsForestOf [Node 1 [], Node 2 []] % (edge 1 2) == False - - test "isDfsForestOf [Node 2 [], Node 1 []] (edge 1 2) == True" $ - isDfsForestOf [Node 2 [], Node 1 []] % (edge 1 2) == True - - test "isDfsForestOf [Node 1 [Node 2 []]] (edge 1 2) == True" $ - isDfsForestOf [Node 1 [Node 2 []]] % (edge 1 2) == True - - test "isDfsForestOf [Node 1 [], Node 2 []] (vertices [1,2]) == True" $ - isDfsForestOf [Node 1 [], Node 2 []] % (vertices [1,2]) == True - - test "isDfsForestOf [Node 2 [], Node 1 []] (vertices [1,2]) == True" $ - isDfsForestOf [Node 2 [], Node 1 []] % (vertices [1,2]) == True - - test "isDfsForestOf [Node 1 [Node 2 []]] (vertices [1,2]) == False" $ - isDfsForestOf [Node 1 [Node 2 []]] % (vertices [1,2]) == False - - test "isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] (path [1,2,3]) == True" $ - isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] % (path [1,2,3]) == True - - test "isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] (path [1,2,3]) == False" $ - isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] % (path [1,2,3]) == False - - test "isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] (path [1,2,3]) == True" $ - isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] % (path [1,2,3]) == True - - test "isDfsForestOf [Node 2 [Node 3 []], Node 1 []] (path [1,2,3]) == True" $ - isDfsForestOf [Node 2 [Node 3 []], Node 1 []] % (path [1,2,3]) == True - - test "isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] (path [1,2,3]) == False" $ - isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] % (path [1,2,3]) == False - -testIsTopSortOf :: Testsuite -> IO () -testIsTopSortOf (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isTopSortOf ============" - test "isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True" $ - isTopSortOf [3,1,2] % (1 * 2 + 3 * 1) == True - - test "isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False" $ - isTopSortOf [1,2,3] % (1 * 2 + 3 * 1) == False - - test "isTopSortOf [] (1 * 2 + 3 * 1) == False" $ - isTopSortOf [] % (1 * 2 + 3 * 1) == False - - test "isTopSortOf [] empty == True" $ - isTopSortOf [] % empty == True - - test "isTopSortOf [x] (vertex x) == True" $ \x -> - isTopSortOf [x] % vertex x == True - - test "isTopSortOf [x] (edge x x) == False" $ \x -> - isTopSortOf [x] % edge x x == False +{-# LANGUAGE RecordWildCards, GADTs, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Generic +-- Copyright : (c) Andrey Mokhov 2016-2019 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Generic graph API testing. +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Generic where + +import Control.Monad (when) +import Data.Either +import Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Tree +import Data.Tuple + +import Algebra.Graph.Test +import Algebra.Graph.Test.API + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet + +type ModulePrefix = String +type Testsuite g c = (ModulePrefix, API g c) +type TestsuiteInt g = (ModulePrefix, API g ((~) Int)) + +testBasicPrimitives :: TestsuiteInt g -> IO () +testBasicPrimitives = mconcat [ testOrd + , testEmpty + , testVertex + , testEdge + , testOverlay + , testConnect + , testVertices + , testEdges + , testOverlays + , testConnects ] + +testSymmetricBasicPrimitives :: TestsuiteInt g -> IO () +testSymmetricBasicPrimitives = mconcat [ testSymmetricOrd + , testEmpty + , testVertex + , testSymmetricEdge + , testOverlay + , testSymmetricConnect + , testVertices + , testSymmetricEdges + , testOverlays + , testSymmetricConnects ] + +testToGraph :: TestsuiteInt g -> IO () +testToGraph = mconcat [ testToGraphDefault + , testFoldg + , testIsEmpty + , testHasVertex + , testHasEdge + , testVertexCount + , testEdgeCount + , testVertexList + , testVertexSet + , testVertexIntSet + , testEdgeList + , testEdgeSet + , testAdjacencyList + , testPreSet + , testPreIntSet + , testPostSet + , testPostIntSet ] + +testSymmetricToGraph :: TestsuiteInt g -> IO () +testSymmetricToGraph = mconcat [ testSymmetricToGraphDefault + , testIsEmpty + , testHasVertex + , testSymmetricHasEdge + , testVertexCount + , testEdgeCount + , testVertexList + , testVertexSet + , testVertexIntSet + , testSymmetricEdgeList + , testSymmetricEdgeSet + , testSymmetricAdjacencyList + , testNeighbours ] + +testRelational :: TestsuiteInt g -> IO () +testRelational = mconcat [ testCompose + , testClosure + , testReflexiveClosure + , testSymmetricClosure + , testTransitiveClosure ] + +testGraphFamilies :: TestsuiteInt g -> IO () +testGraphFamilies = mconcat [ testPath + , testCircuit + , testClique + , testBiclique + , testStar + , testStars + , testTree + , testForest ] + +testSymmetricGraphFamilies :: TestsuiteInt g -> IO () +testSymmetricGraphFamilies = mconcat [ testSymmetricPath + , testSymmetricCircuit + , testSymmetricClique + , testBiclique + , testStar + , testStars + , testTree + , testForest ] + +testTransformations :: TestsuiteInt g -> IO () +testTransformations = mconcat [ testRemoveVertex + , testRemoveEdge + , testReplaceVertex + , testMergeVertices + , testTranspose + , testGmap + , testInduce ] + +testSymmetricTransformations :: TestsuiteInt g -> IO () +testSymmetricTransformations = mconcat [ testRemoveVertex + , testSymmetricRemoveEdge + , testReplaceVertex + , testMergeVertices + , testGmap + , testInduce ] + +testConsistent :: TestsuiteInt g -> IO () +testConsistent (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "consistent ============" + test "Consistency of the Arbitrary instance" $ \x -> consistent x + + putStrLn "" + test "consistent empty == True" $ + consistent empty == True + + test "consistent (vertex x) == True" $ \x -> + consistent (vertex x) == True + + test "consistent (overlay x y) == True" $ \x y -> + consistent (overlay x y) == True + + test "consistent (connect x y) == True" $ \x y -> + consistent (connect x y) == True + + test "consistent (edge x y) == True" $ \x y -> + consistent (edge x y) == True + + test "consistent (edges xs) == True" $ \xs -> + consistent (edges xs) == True + + test "consistent (stars xs) == True" $ \xs -> + consistent (stars xs) == True + +testShow :: TestsuiteInt g -> IO () +testShow (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "Show ============" + test "show (empty ) == \"empty\"" $ + show (empty ) == "empty" + + test "show (1 ) == \"vertex 1\"" $ + show (1 `asTypeOf` empty) == "vertex 1" + + test "show (1 + 2 ) == \"vertices [1,2]\"" $ + show (1 + 2 `asTypeOf` empty) == "vertices [1,2]" + + test "show (1 * 2 ) == \"edge 1 2\"" $ + show (1 * 2 `asTypeOf` empty) == "edge 1 2" + + test "show (1 * 2 * 3) == \"edges [(1,2),(1,3),(2,3)]\"" $ + show (1 * 2 * 3 `asTypeOf` empty) == "edges [(1,2),(1,3),(2,3)]" + + test "show (1 * 2 + 3) == \"overlay (vertex 3) (edge 1 2)\"" $ + show (1 * 2 + 3 `asTypeOf` empty) == "overlay (vertex 3) (edge 1 2)" + + putStrLn "" + test "show (vertex (-1) ) == \"vertex (-1)\"" $ + show (vertex (-1) ) == "vertex (-1)" + + test "show (vertex (-1) + vertex (-2) ) == \"vertices [-2,-1]\"" $ + show (vertex (-1) + vertex (-2) ) == "vertices [-2,-1]" + + test "show (vertex (-2) * vertex (-1) ) == \"edge (-2) (-1)\"" $ + show (vertex (-2) * vertex (-1) ) == "edge (-2) (-1)" + + test "show (vertex (-3) * vertex (-2) * vertex (-1)) == \"edges [(-3,-2),(-3,-1),(-2,-1)]\"" $ + show (vertex (-3) * vertex (-2) * vertex (-1)) == "edges [(-3,-2),(-3,-1),(-2,-1)]" + + test "show (vertex (-3) * vertex (-2) + vertex (-1)) == \"overlay (vertex (-1)) (edge (-3) (-2))\"" $ + show (vertex (-3) * vertex (-2) + vertex (-1)) == "overlay (vertex (-1)) (edge (-3) (-2))" + +testSymmetricShow :: TestsuiteInt g -> IO () +testSymmetricShow t@(_, API{..}) = do + testShow t + putStrLn "" + test "show (2 * 1 ) == \"edge 1 2\"" $ + show (2 * 1 `asTypeOf` empty) == "edge 1 2" + + test "show (1 * 2 * 1) == \"edges [(1,1),(1,2)]\"" $ + show (1 * 2 * 1 `asTypeOf` empty) == "edges [(1,1),(1,2)]" + + test "show (3 * 2 * 1) == \"edges [(1,2),(1,3),(2,3)]\"" $ + show (3 * 2 * 1 `asTypeOf` empty) == "edges [(1,2),(1,3),(2,3)]" + +testOrd :: TestsuiteInt g -> IO () +testOrd (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "Ord ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex 2 + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 2 + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 1 + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 2 + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 2 + + test "edge 1 2 < edge 1 3" $ + edge 1 2 < edge 1 3 + + test "x <= x + y" $ \x y -> + x <= x + (y `asTypeOf` empty) + + test "x + y <= x * y" $ \x y -> + x + y <= x * (y `asTypeOf` empty) + +testSymmetricOrd :: TestsuiteInt g -> IO () +testSymmetricOrd (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "Ord ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex 2 + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 2 + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 1 + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 2 + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 2 + + test "edge 2 1 < edge 1 3" $ + edge 2 1 < edge 1 3 + + test "edge 1 2 == edge 2 1" $ + edge 1 2 == edge 2 1 + + test "x <= x + y" $ \x y -> + x <= x + (y `asTypeOf` empty) + + test "x + y <= x * y" $ \x y -> + x + y <= x * (y `asTypeOf` empty) + +testEmpty :: TestsuiteInt g -> IO () +testEmpty (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "empty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "hasVertex x empty == False" $ \x -> + hasVertex x empty == False + + test "vertexCount empty == 0" $ + vertexCount empty == 0 + + test "edgeCount empty == 0" $ + edgeCount empty == 0 + +testVertex :: TestsuiteInt g -> IO () +testVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertex ============" + test "isEmpty (vertex x) == False" $ \x -> + isEmpty (vertex x) == False + + test "hasVertex x (vertex y) == (x == y)" $ \x y -> + hasVertex x (vertex y) == (x == y) + + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount (vertex x) == 1 + + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount (vertex x) == 0 + +testEdge :: TestsuiteInt g -> IO () +testEdge (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \x y -> + edge x y == connect (vertex x) (vertex y) + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount (edge x y) == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount (edge 1 1) == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount (edge 1 2) == 2 + +testSymmetricEdge :: TestsuiteInt g -> IO () +testSymmetricEdge (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \x y -> + edge x y == connect (vertex x) (vertex y) + + test "edge x y == edge y x" $ \x y -> + edge x y == edge y x + + test "edge x y == edges [(x,y), (y,x)]" $ \x y -> + edge x y == edges [(x,y), (y,x)] + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount (edge x y) == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount (edge 1 1) == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount (edge 1 2) == 2 + +testOverlay :: TestsuiteInt g -> IO () +testOverlay (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "overlay ============" + test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (overlay x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (overlay x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> + vertexCount (overlay x y) >= vertexCount x + + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + + test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> + edgeCount (overlay x y) >= edgeCount x + + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + test "vertexCount (overlay 1 2) == 2" $ + vertexCount (overlay 1 2) == 2 + + test "edgeCount (overlay 1 2) == 0" $ + edgeCount (overlay 1 2) == 0 + +testConnect :: TestsuiteInt g -> IO () +testConnect (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "connect ============" + test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (connect x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (connect x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect x y) >= vertexCount x" $ \x y -> + vertexCount (connect x y) >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \x y -> + edgeCount (connect x y) >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \x y -> + edgeCount (connect x y) >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \x y -> + edgeCount (connect x y) >= vertexCount x * vertexCount y + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount (connect 1 2) == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount (connect 1 2) == 1 + +testSymmetricConnect :: TestsuiteInt g -> IO () +testSymmetricConnect (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "connect ============" + test "connect x y == connect y x" $ \x y -> + connect x y == connect y x + + test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (connect x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (connect x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect x y) >= vertexCount x" $ \x y -> + vertexCount (connect x y) >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \x y -> + edgeCount (connect x y) >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \x y -> + edgeCount (connect x y) >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y `div` 2" $ \x y -> + edgeCount (connect x y) >= vertexCount x * vertexCount y `div` 2 + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount (connect 1 2) == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount (connect 1 2) == 1 + +testVertices :: TestsuiteInt g -> IO () +testVertices (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertices ============" + test "vertices [] == empty" $ + vertices [] == empty + + test "vertices [x] == vertex x" $ \x -> + vertices [x] == vertex x + + test "hasVertex x . vertices == elem x" $ \x xs -> + (hasVertex x . vertices) xs == elem x xs + + test "vertexCount . vertices == length . nub" $ \xs -> + (vertexCount . vertices) xs == (length . nubOrd) xs + + test "vertexSet . vertices == Set.fromList" $ \xs -> + (vertexSet . vertices) xs == Set.fromList xs + +testEdges :: TestsuiteInt g -> IO () +testEdges (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edges ============" + test "edges [] == empty" $ + edges [] == empty + + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == edge x y + + test "edges == overlays . map (uncurry edge)" $ \xs -> + edges xs == (overlays . map (uncurry edge)) xs + + test "edgeCount . edges == length . nub" $ \xs -> + (edgeCount . edges) xs == (length . nubOrd) xs + +testSymmetricEdges :: TestsuiteInt g -> IO () +testSymmetricEdges (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edges ============" + test "edges [] == empty" $ + edges [] == empty + + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == edge x y + + test "edges [(x,y), (y,x)] == edge x y" $ \x y -> + edges [(x,y), (y,x)] == edge x y + +testOverlays :: TestsuiteInt g -> IO () +testOverlays (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "overlays ============" + test "overlays [] == empty" $ + overlays [] == empty + + test "overlays [x] == x" $ \x -> + overlays [x] == x + + test "overlays [x,y] == overlay x y" $ \x y -> + overlays [x,y] == overlay x y + + test "overlays == foldr overlay empty" $ size10 $ \xs -> + overlays xs == foldr overlay empty xs + + test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> + (isEmpty . overlays) xs == all isEmpty xs + +testConnects :: TestsuiteInt g -> IO () +testConnects (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "connects ============" + test "connects [] == empty" $ + connects [] == empty + + test "connects [x] == x" $ \x -> + connects [x] == x + + test "connects [x,y] == connect x y" $ \x y -> + connects [x,y] == connect x y + + test "connects == foldr connect empty" $ size10 $ \xs -> + connects xs == foldr connect empty xs + + test "isEmpty . connects == all isEmpty" $ size10 $ \xs -> + (isEmpty . connects) xs == all isEmpty xs + +testSymmetricConnects :: TestsuiteInt g -> IO () +testSymmetricConnects t@(_, API{..}) = do + testConnects t + test "connects == connects . reverse" $ size10 $ \xs -> + connects xs == connects (reverse xs) + +testStars :: TestsuiteInt g -> IO () +testStars (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "stars ============" + test "stars [] == empty" $ + stars [] == empty + + test "stars [(x, [])] == vertex x" $ \x -> + stars [(x, [])] == vertex x + + test "stars [(x, [y])] == edge x y" $ \x y -> + stars [(x, [y])] == edge x y + + test "stars [(x, ys)] == star x ys" $ \x ys -> + stars [(x, ys)] == star x ys + + test "stars == overlays . map (uncurry star)" $ \xs -> + stars xs == overlays (map (uncurry star) xs) + + test "stars . adjacencyList == id" $ \x -> + (stars . adjacencyList) x == id x + + test "overlay (stars xs) (stars ys) == stars (xs ++ ys)" $ \xs ys -> + overlay (stars xs) (stars ys) == stars (xs ++ ys) + +testFromAdjacencySets :: TestsuiteInt g -> IO () +testFromAdjacencySets (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencySets ============" + test "fromAdjacencySets [] == empty" $ + fromAdjacencySets [] == empty + + test "fromAdjacencySets [(x, Set.empty)] == vertex x" $ \x -> + fromAdjacencySets [(x, Set.empty)] == vertex x + + test "fromAdjacencySets [(x, Set.singleton y)] == edge x y" $ \x y -> + fromAdjacencySets [(x, Set.singleton y)] == edge x y + + test "fromAdjacencySets . map (fmap Set.fromList) == stars" $ \x -> + (fromAdjacencySets . map (fmap Set.fromList)) x == stars x + + test "overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys) + +testFromAdjacencyIntSets :: TestsuiteInt g -> IO () +testFromAdjacencyIntSets (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyIntSets ============" + test "fromAdjacencyIntSets [] == empty" $ + fromAdjacencyIntSets [] == empty + + test "fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x" $ \x -> + fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x + + test "fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y" $ \x y -> + fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y + + test "fromAdjacencyIntSets . map (fmap IntSet.fromList) == stars" $ \x -> + (fromAdjacencyIntSets . map (fmap IntSet.fromList)) x == stars x + + test "overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys) + +testIsSubgraphOf :: TestsuiteInt g -> IO () +testIsSubgraphOf (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \x -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \x -> + isSubgraphOf (vertex x) empty == False + + test "isSubgraphOf x (overlay x y) == True" $ \x y -> + isSubgraphOf x (overlay x y) == True + + test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> + isSubgraphOf (overlay x y) (connect x y) == True + + test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> + isSubgraphOf (path xs) (circuit xs) == True + + test "isSubgraphOf x y ==> x <= y" $ \x z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + +testSymmetricIsSubgraphOf :: TestsuiteInt g -> IO () +testSymmetricIsSubgraphOf t@(_, API{..}) = do + testIsSubgraphOf t + test "isSubgraphOf (edge x y) (edge y x) == True" $ \x y -> + isSubgraphOf (edge x y) (edge y x) == True + +testToGraphDefault :: TestsuiteInt g -> IO () +testToGraphDefault (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" + test "toGraph == foldg Empty Vertex Overlay Connect" $ \x -> + toGraph x == foldg G.Empty G.Vertex G.Overlay G.Connect x + + test "foldg == Algebra.Graph.foldg . toGraph" $ \e (apply -> v) (applyFun2 -> o) (applyFun2 -> c) x -> + foldg e v o c x == (G.foldg (e :: Int) v o c . toGraph) x + + test "isEmpty == foldg True (const False) (&&) (&&)" $ \x -> + isEmpty x == foldg True (const False) (&&) (&&) x + + test "size == foldg 1 (const 1) (+) (+)" $ \x -> + size x == foldg 1 (const 1) (+) (+) x + + test "hasVertex x == foldg False (==x) (||) (||)" $ \x y -> + hasVertex x y == foldg False (==x) (||) (||) y + + test "hasEdge x y == Algebra.Graph.hasEdge x y . toGraph" $ \x y z -> + hasEdge x y z == (G.hasEdge x y . toGraph) z + + test "vertexCount == Set.size . vertexSet" $ \x -> + vertexCount x == (Set.size . vertexSet) x + + test "edgeCount == Set.size . edgeSet" $ \x -> + edgeCount x == (Set.size . edgeSet) x + + test "vertexList == Set.toAscList . vertexSet" $ \x -> + vertexList x == (Set.toAscList . vertexSet) x + + test "edgeList == Set.toAscList . edgeSet" $ \x -> + edgeList x == (Set.toAscList . edgeSet) x + + test "vertexSet == foldg Set.empty Set.singleton Set.union Set.union" $ \x -> + vertexSet x == foldg Set.empty Set.singleton Set.union Set.union x + + test "vertexIntSet == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union" $ \x -> + vertexIntSet x == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union x + + test "edgeSet == Algebra.Graph.AdjacencyMap.edgeSet . foldg empty vertex overlay connect" $ \x -> + edgeSet x == (AM.edgeSet . foldg AM.empty AM.vertex AM.overlay AM.connect) x + + test "preSet x == Algebra.Graph.AdjacencyMap.preSet x . toAdjacencyMap" $ \x y -> + preSet x y == (AM.preSet x . toAdjacencyMap) y + + test "preIntSet x == Algebra.Graph.AdjacencyIntMap.preIntSet x . toAdjacencyIntMap" $ \x y -> + preIntSet x y == (AIM.preIntSet x . toAdjacencyIntMap) y + + test "postSet x == Algebra.Graph.AdjacencyMap.postSet x . toAdjacencyMap" $ \x y -> + postSet x y == (AM.postSet x . toAdjacencyMap) y + + test "postIntSet x == Algebra.Graph.AdjacencyIntMap.postIntSet x . toAdjacencyIntMap" $ \x y -> + postIntSet x y == (AIM.postIntSet x . toAdjacencyIntMap) y + + test "adjacencyList == Algebra.Graph.AdjacencyMap.adjacencyList . toAdjacencyMap" $ \x -> + adjacencyList x == (AM.adjacencyList . toAdjacencyMap) x + + test "adjacencyMap == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMap" $ \x -> + adjacencyMap x == (AM.adjacencyMap . toAdjacencyMap) x + + test "adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMap" $ \x -> + adjacencyIntMap x == (AIM.adjacencyIntMap . toAdjacencyIntMap) x + + test "adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMapTranspose" $ \x -> + adjacencyMapTranspose x == (AM.adjacencyMap . toAdjacencyMapTranspose) x + + test "adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMapTranspose" $ \x -> + adjacencyIntMapTranspose x == (AIM.adjacencyIntMap . toAdjacencyIntMapTranspose) x + + test "dfsForest == Algebra.Graph.AdjacencyMap.dfsForest . toAdjacencyMap" $ \x -> + dfsForest x == (AM.dfsForest . toAdjacencyMap) x + + test "dfsForestFrom vs == Algebra.Graph.AdjacencyMap.dfsForestFrom vs . toAdjacencyMap" $ \vs x -> + dfsForestFrom vs x == (AM.dfsForestFrom vs . toAdjacencyMap) x + + test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> + dfs vs x == (AM.dfs vs . toAdjacencyMap) x + + test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable x . toAdjacencyMap) y + + test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> + topSort x == (AM.topSort . toAdjacencyMap) x + + test "isAcyclic == Algebra.Graph.AdjacencyMap.isAcyclic . toAdjacencyMap" $ \x -> + isAcyclic x == (AM.isAcyclic . toAdjacencyMap) x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) x + + test "toAdjacencyMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyMap x == foldg AM.empty AM.vertex AM.overlay AM.connect x + + test "toAdjacencyMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyMapTranspose x == foldg AM.empty AM.vertex AM.overlay (flip AM.connect) x + + test "toAdjacencyIntMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyIntMap x == foldg AIM.empty AIM.vertex AIM.overlay AIM.connect x + + test "toAdjacencyIntMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyIntMapTranspose x == foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) x + + test "isDfsForestOf f == Algebra.Graph.AdjacencyMap.isDfsForestOf f . toAdjacencyMap" $ \f x -> + isDfsForestOf f x == (AM.isDfsForestOf f . toAdjacencyMap) x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) x + +-- TODO: We currently do not test 'edgeSet'. +testSymmetricToGraphDefault :: TestsuiteInt g -> IO () +testSymmetricToGraphDefault (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" + test "toGraph == foldg Empty Vertex Overlay Connect" $ \x -> + toGraph x == foldg G.Empty G.Vertex G.Overlay G.Connect x + + test "foldg == Algebra.Graph.foldg . toGraph" $ \e (apply -> v) (applyFun2 -> o) (applyFun2 -> c) x -> + foldg e v o c x == (G.foldg (e :: Int) v o c . toGraph) x + + test "isEmpty == foldg True (const False) (&&) (&&)" $ \x -> + isEmpty x == foldg True (const False) (&&) (&&) x + + test "size == foldg 1 (const 1) (+) (+)" $ \x -> + size x == foldg 1 (const 1) (+) (+) x + + test "hasVertex x == foldg False (==x) (||) (||)" $ \x y -> + hasVertex x y == foldg False (==x) (||) (||) y + + test "hasEdge x y == Algebra.Graph.hasEdge x y . toGraph" $ \x y z -> + hasEdge x y z == (G.hasEdge x y . toGraph) z + + test "vertexCount == Set.size . vertexSet" $ \x -> + vertexCount x == (Set.size . vertexSet) x + + test "edgeCount == Set.size . edgeSet" $ \x -> + edgeCount x == (Set.size . edgeSet) x + + test "vertexList == Set.toAscList . vertexSet" $ \x -> + vertexList x == (Set.toAscList . vertexSet) x + + test "edgeList == Set.toAscList . edgeSet" $ \x -> + edgeList x == (Set.toAscList . edgeSet) x + + test "vertexSet == foldg Set.empty Set.singleton Set.union Set.union" $ \x -> + vertexSet x == foldg Set.empty Set.singleton Set.union Set.union x + + test "vertexIntSet == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union" $ \x -> + vertexIntSet x == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union x + + test "adjacencyList == Algebra.Graph.AdjacencyMap.adjacencyList . toAdjacencyMap" $ \x -> + adjacencyList x == (AM.adjacencyList . toAdjacencyMap) x + + test "adjacencyMap == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMap" $ \x -> + adjacencyMap x == (AM.adjacencyMap . toAdjacencyMap) x + + test "adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMap" $ \x -> + adjacencyIntMap x == (AIM.adjacencyIntMap . toAdjacencyIntMap) x + + test "adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMapTranspose" $ \x -> + adjacencyMapTranspose x == (AM.adjacencyMap . toAdjacencyMapTranspose) x + + test "adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMapTranspose" $ \x -> + adjacencyIntMapTranspose x == (AIM.adjacencyIntMap . toAdjacencyIntMapTranspose) x + + test "dfsForest == Algebra.Graph.AdjacencyMap.dfsForest . toAdjacencyMap" $ \x -> + dfsForest x == (AM.dfsForest . toAdjacencyMap) x + + test "dfsForestFrom vs == Algebra.Graph.AdjacencyMap.dfsForestFrom vs . toAdjacencyMap" $ \vs x -> + dfsForestFrom vs x == (AM.dfsForestFrom vs . toAdjacencyMap) x + + test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> + dfs vs x == (AM.dfs vs . toAdjacencyMap) x + + test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable x . toAdjacencyMap) y + + test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> + topSort x == (AM.topSort . toAdjacencyMap) x + + test "isAcyclic == Algebra.Graph.AdjacencyMap.isAcyclic . toAdjacencyMap" $ \x -> + isAcyclic x == (AM.isAcyclic . toAdjacencyMap) x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) x + + test "toAdjacencyMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyMap x == foldg AM.empty AM.vertex AM.overlay AM.connect x + + test "toAdjacencyMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyMapTranspose x == foldg AM.empty AM.vertex AM.overlay (flip AM.connect) x + + test "toAdjacencyIntMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyIntMap x == foldg AIM.empty AIM.vertex AIM.overlay AIM.connect x + + test "toAdjacencyIntMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyIntMapTranspose x == foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) x + + test "isDfsForestOf f == Algebra.Graph.AdjacencyMap.isDfsForestOf f . toAdjacencyMap" $ \f x -> + isDfsForestOf f x == (AM.isDfsForestOf f . toAdjacencyMap) x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) x + +testFoldg :: TestsuiteInt g -> IO () +testFoldg (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "foldg ============" + test "foldg empty vertex overlay connect == id" $ \x -> + foldg empty vertex overlay connect x == id x + + test "foldg empty vertex overlay (flip connect) == transpose" $ \x -> + foldg empty vertex overlay (flip connect) x == transpose x + + test "foldg 1 (const 1) (+) (+) == size" $ \x -> + foldg 1 (const 1) (+) (+) x == size x + + test "foldg True (const False) (&&) (&&) == isEmpty" $ \x -> + foldg True (const False) (&&) (&&) x == isEmpty x + +testIsEmpty :: TestsuiteInt g -> IO () +testIsEmpty (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty) == True + + test "isEmpty (vertex x) == False" $ \x -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \x -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge x y $ edge x y) == False" $ \x y -> + isEmpty (removeEdge x y $ edge x y) == False + +testSize :: TestsuiteInt g -> IO () +testSize (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "size ============" + test "size empty == 1" $ + size empty == 1 + + test "size (vertex x) == 1" $ \x -> + size (vertex x) == 1 + + test "size (overlay x y) == size x + size y" $ \x y -> + size (overlay x y) == size x + size y + + test "size (connect x y) == size x + size y" $ \x y -> + size (connect x y) == size x + size y + + test "size x >= 1" $ \x -> + size x >= 1 + + test "size x >= vertexCount x" $ \x -> + size x >= vertexCount x + +testHasVertex :: TestsuiteInt g -> IO () +testHasVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "hasVertex ============" + test "hasVertex x empty == False" $ \x -> + hasVertex x empty == False + + test "hasVertex x (vertex y) == (x == y)" $ \x y -> + hasVertex x (vertex y) == (x == y) + + test "hasVertex x . removeVertex x == const False" $ \x y -> + (hasVertex x . removeVertex x) y == const False y + +testHasEdge :: TestsuiteInt g -> IO () +testHasEdge (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "hasEdge ============" + test "hasEdge x y empty == False" $ \x y -> + hasEdge x y empty == False + + test "hasEdge x y (vertex z) == False" $ \x y z -> + hasEdge x y (vertex z) == False + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + + test "hasEdge x y . removeEdge x y == const False" $ \x y z -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do + let es = edgeList z + (x, y) <- elements ((x, y) : es) + return $ hasEdge x y z == elem (x, y) es + +testSymmetricHasEdge :: TestsuiteInt g -> IO () +testSymmetricHasEdge (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "hasEdge ============" + test "hasEdge x y empty == False" $ \x y -> + hasEdge x y empty == False + + test "hasEdge x y (vertex z) == False" $ \x y z -> + hasEdge x y (vertex z) == False + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + + test "hasEdge x y (edge y x) == True" $ \x y -> + hasEdge x y (edge y x) == True + + test "hasEdge x y . removeEdge x y == const False" $ \x y z -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == elem (min x y, max x y) . edgeList" $ \x y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (min u v, max u v) (edgeList z) + +testVertexCount :: TestsuiteInt g -> IO () +testVertexCount (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount empty == 0 + + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount (vertex x) == 1 + + test "vertexCount == length . vertexList" $ \x -> + vertexCount x == (length . vertexList) x + + test "vertexCount x < vertexCount y ==> x < y" $ \x y -> + if vertexCount x < vertexCount y + then property (x < y) + else (vertexCount x > vertexCount y ==> x > y) + +testEdgeCount :: TestsuiteInt g -> IO () +testEdgeCount (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount (edge x y) == 1 + + test "edgeCount == length . edgeList" $ \x -> + edgeCount x == (length . edgeList) x + +testVertexList :: TestsuiteInt g -> IO () +testVertexList (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexList ============" + test "vertexList empty == []" $ + vertexList empty == [] + + test "vertexList (vertex x) == [x]" $ \x -> + vertexList (vertex x) == [x] + + test "vertexList . vertices == nub . sort" $ \xs -> + (vertexList . vertices) xs == (nubOrd . sort) xs + +testEdgeList :: TestsuiteInt g -> IO () +testEdgeList (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeList ============" + test "edgeList empty == []" $ + edgeList empty == [] + + test "edgeList (vertex x) == []" $ \x -> + edgeList (vertex x) == [] + + test "edgeList (edge x y) == [(x,y)]" $ \x y -> + edgeList (edge x y) == [(x,y)] + + test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ + edgeList (star 2 [3,1]) == [(2,1), (2,3)] + + test "edgeList . edges == nub . sort" $ \xs -> + (edgeList . edges) xs == (nubOrd . sort) xs + +testSymmetricEdgeList :: TestsuiteInt g -> IO () +testSymmetricEdgeList (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeList ============" + test "edgeList empty == []" $ + edgeList empty == [] + + test "edgeList (vertex x) == []" $ \x -> + edgeList (vertex x) == [] + + test "edgeList (edge x y) == [(min x y, max y x)]" $ \x y -> + edgeList (edge x y) == [(min x y, max y x)] + + test "edgeList (star 2 [3,1]) == [(1,2), (2,3)]" $ + edgeList (star 2 [3,1]) == [(1,2), (2,3)] + +testAdjacencyList :: TestsuiteInt g -> IO () +testAdjacencyList (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "adjacencyList ============" + test "adjacencyList empty == []" $ + adjacencyList empty == [] + + test "adjacencyList (vertex x) == [(x, [])]" $ \x -> + adjacencyList (vertex x) == [(x, [])] + + test "adjacencyList (edge 1 2) == [(1, [2]), (2, [])]" $ + adjacencyList (edge 1 2) == [(1, [2]), (2, [])] + + test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ + adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] + +testSymmetricAdjacencyList :: TestsuiteInt g -> IO () +testSymmetricAdjacencyList (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "adjacencyList ============" + test "adjacencyList empty == []" $ + adjacencyList empty == [] + + test "adjacencyList (vertex x) == [(x, [])]" $ \x -> + adjacencyList (vertex x) == [(x, [])] + + test "adjacencyList (edge 1 2) == [(1, [2]), (2, [1])]" $ + adjacencyList (edge 1 2) == [(1, [2]), (2, [1])] + + test "adjacencyList (star 2 [3,1]) == [(1, [2]), (2, [1,3]), (3, [2])]" $ + adjacencyList (star 2 [3,1]) == [(1, [2]), (2, [1,3]), (3, [2])] + +testVertexSet :: TestsuiteInt g -> IO () +testVertexSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet empty == Set.empty + + test "vertexSet . vertex == Set.singleton" $ \x -> + (vertexSet . vertex) x == Set.singleton x + + test "vertexSet . vertices == Set.fromList" $ \xs -> + (vertexSet . vertices) xs == Set.fromList xs + +testVertexIntSet :: TestsuiteInt g -> IO () +testVertexIntSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexIntSet ============" + test "vertexIntSet empty == IntSet.empty" $ + vertexIntSet empty == IntSet.empty + + test "vertexIntSet . vertex == IntSet.singleton" $ \x -> + (vertexIntSet . vertex) x == IntSet.singleton x + + test "vertexIntSet . vertices == IntSet.fromList" $ \xs -> + (vertexIntSet . vertices) xs == IntSet.fromList xs + + test "vertexIntSet . clique == IntSet.fromList" $ \xs -> + (vertexIntSet . clique) xs == IntSet.fromList xs + +testEdgeSet :: TestsuiteInt g -> IO () +testEdgeSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet empty == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \x -> + edgeSet (vertex x) == Set.empty + + test "edgeSet (edge x y) == Set.singleton (x,y)" $ \x y -> + edgeSet (edge x y) == Set.singleton (x,y) + + test "edgeSet . edges == Set.fromList" $ \xs -> + (edgeSet . edges) xs == Set.fromList xs + +testSymmetricEdgeSet :: TestsuiteInt g -> IO () +testSymmetricEdgeSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet empty == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \x -> + edgeSet (vertex x) == Set.empty + + test "edgeSet (edge x y) == Set.singleton (min x y, max x y)" $ \x y -> + edgeSet (edge x y) == Set.singleton (min x y, max x y) + +testPreSet :: TestsuiteInt g -> IO () +testPreSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "preSet ============" + test "preSet x empty == Set.empty" $ \x -> + preSet x empty == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + preSet x (vertex x) == Set.empty + + test "preSet 1 (edge 1 2) == Set.empty" $ + preSet 1 (edge 1 2) == Set.empty + + test "preSet y (edge x y) == Set.fromList [x]" $ \x y -> + preSet y (edge x y) == Set.fromList [x] + +testPostSet :: TestsuiteInt g -> IO () +testPostSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "postSet ============" + test "postSet x empty == Set.empty" $ \x -> + postSet x empty == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + postSet x (vertex x) == Set.empty + + test "postSet x (edge x y) == Set.fromList [y]" $ \x y -> + postSet x (edge x y) == Set.fromList [y] + + test "postSet 2 (edge 1 2) == Set.empty" $ + postSet 2 (edge 1 2) == Set.empty + +testPreIntSet :: TestsuiteInt g -> IO () +testPreIntSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "preIntSet ============" + test "preIntSet x empty == IntSet.empty" $ \x -> + preIntSet x empty == IntSet.empty + + test "preIntSet x (vertex x) == IntSet.empty" $ \x -> + preIntSet x (vertex x) == IntSet.empty + + test "preIntSet 1 (edge 1 2) == IntSet.empty" $ + preIntSet 1 (edge 1 2) == IntSet.empty + + test "preIntSet y (edge x y) == IntSet.fromList [x]" $ \x y -> + preIntSet y (edge x y) == IntSet.fromList [x] + +testPostIntSet :: TestsuiteInt g -> IO () +testPostIntSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "postIntSet ============" + test "postIntSet x empty == IntSet.empty" $ \x -> + postIntSet x empty == IntSet.empty + + test "postIntSet x (vertex x) == IntSet.empty" $ \x -> + postIntSet x (vertex x) == IntSet.empty + + test "postIntSet 2 (edge 1 2) == IntSet.empty" $ + postIntSet 2 (edge 1 2) == IntSet.empty + + test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> + postIntSet x (edge x y) == IntSet.fromList [y] + +testNeighbours :: TestsuiteInt g -> IO () +testNeighbours (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "neighbours ============" + test "neighbours x empty == Set.empty" $ \x -> + neighbours x empty == Set.empty + + test "neighbours x (vertex x) == Set.empty" $ \x -> + neighbours x (vertex x) == Set.empty + + test "neighbours x (edge x y) == Set.fromList [y]" $ \x y -> + neighbours x (edge x y) == Set.fromList [y] + + test "neighbours y (edge x y) == Set.fromList [x]" $ \x y -> + neighbours y (edge x y) == Set.fromList [x] + +testPath :: TestsuiteInt g -> IO () +testPath (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "path ============" + test "path [] == empty" $ + path [] == empty + + test "path [x] == vertex x" $ \x -> + path [x] == vertex x + + test "path [x,y] == edge x y" $ \x y -> + path [x,y] == edge x y + +testSymmetricPath :: TestsuiteInt g -> IO () +testSymmetricPath t@(_, API{..}) = do + testPath t + test "path == path . reverse" $ \xs -> + path xs ==(path . reverse) xs + +testCircuit :: TestsuiteInt g -> IO () +testCircuit (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "circuit ============" + test "circuit [] == empty" $ + circuit [] == empty + + test "circuit [x] == edge x x" $ \x -> + circuit [x] == edge x x + + test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> + circuit [x,y] == edges [(x,y), (y,x)] + +testSymmetricCircuit :: TestsuiteInt g -> IO () +testSymmetricCircuit t@(_, API{..}) = do + testCircuit t + test "circuit == circuit . reverse" $ \xs -> + circuit xs ==(circuit . reverse) xs + +testClique :: TestsuiteInt g -> IO () +testClique (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "clique ============" + test "clique [] == empty" $ + clique [] == empty + + test "clique [x] == vertex x" $ \x -> + clique [x] == vertex x + + test "clique [x,y] == edge x y" $ \x y -> + clique [x,y] == edge x y + + test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \x y z -> + clique [x,y,z] == edges [(x,y), (x,z), (y,z)] + + test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys -> + clique (xs ++ ys) == connect (clique xs) (clique ys) + +testSymmetricClique :: TestsuiteInt g -> IO () +testSymmetricClique t@(_, API{..}) = do + testClique t + test "clique == clique . reverse" $ \xs-> + clique xs ==(clique . reverse) xs + +testBiclique :: TestsuiteInt g -> IO () +testBiclique (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "biclique ============" + test "biclique [] [] == empty" $ + biclique [] [] == empty + + test "biclique [x] [] == vertex x" $ \x -> + biclique [x] [] == vertex x + + test "biclique [] [y] == vertex y" $ \y -> + biclique [] [y] == vertex y + + test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \x1 x2 y1 y2 -> + biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] + + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> + biclique xs ys == connect (vertices xs) (vertices ys) + +testStar :: TestsuiteInt g -> IO () +testStar (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "star ============" + test "star x [] == vertex x" $ \x -> + star x [] == vertex x + + test "star x [y] == edge x y" $ \x y -> + star x [y] == edge x y + + test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> + star x [y,z] == edges [(x,y), (x,z)] + + test "star x ys == connect (vertex x) (vertices ys)" $ \x ys -> + star x ys == connect (vertex x) (vertices ys) + +testTree :: TestsuiteInt g -> IO () +testTree (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "tree ============" + test "tree (Node x []) == vertex x" $ \x -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \x y z -> + tree (Node x [Node y [Node z []]]) == path [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \x y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)] + +testForest :: TestsuiteInt g -> IO () +testForest (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "forest ============" + test "forest [] == empty" $ + forest [] == empty + + test "forest [x] == tree x" $ \x -> + forest [x] == tree x + + test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ + forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)] + + test "forest == overlays . map tree" $ \x -> + forest x ==(overlays . map tree) x + +testMesh :: Testsuite g Ord -> IO () +testMesh (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "mesh ============" + test "mesh xs [] == empty" $ \(xs :: [Int]) -> + mesh xs ([] :: [Int]) == empty + + test "mesh [] ys == empty" $ \(ys :: [Int]) -> + mesh ([] :: [Int]) ys == empty + + test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> + mesh [x] [y] == vertex (x, y) + + test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + mesh xs ys == box (path xs) (path ys) + + test "mesh [1..3] \"ab\" == " $ + mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) + , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ] + + test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs :: [Int]) (ys :: [Int]) -> + size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) + +testTorus :: Testsuite g Ord -> IO () +testTorus (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "torus ============" + test "torus xs [] == empty" $ \(xs :: [Int]) -> + torus xs ([] :: [Int]) == empty + + test "torus [] ys == empty" $ \(ys :: [Int]) -> + torus ([] :: [Int]) ys == empty + + test "torus [x] [y] == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> + torus [x] [y] == edge (x,y) (x,y) + + test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + torus xs ys == box (circuit xs) (circuit ys) + + test "torus [1,2] \"ab\" == " $ + torus [1,2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) + , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ] + + test "size (torus xs ys) == max 1 (3 * length xs * length ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + size (torus xs ys) == max 1 (3 * length xs * length ys) + +testDeBruijn :: Testsuite g Ord -> IO () +testDeBruijn (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "deBruijn ============" + test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> + deBruijn 0 xs == edge [] [] + + test "n > 0 ==> deBruijn n [] == empty" $ \n -> + n > 0 ==> deBruijn n ([] :: [Int]) == empty + + test " deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ + deBruijn 1 [0,1::Int] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] + + test " deBruijn 2 \"0\" == edge \"00\" \"00\"" $ + deBruijn 2 "0" == edge "00" "00" + + test " deBruijn 2 \"01\" == " $ + deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") + , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] + + test " transpose (deBruijn n xs) == gmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + transpose (deBruijn n xs) == gmap reverse (deBruijn n xs) + + test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n + + test "n > 0 ==> edgeCount (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + n > 0 ==> edgeCount (deBruijn n xs) == (length $ nubOrd xs)^(n + 1) + +testBox :: Testsuite g Ord -> IO () +testBox (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "box ============" + let unit = gmap $ \(a :: Int, () ) -> a + comm = gmap $ \(a :: Int, b :: Int) -> (b, a) + test "box x y ~~ box y x" $ mapSize (min 10) $ \x y -> + comm (box x y) == box y x + + test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \x y z -> + let _ = x + y + z + vertex (0 :: Int) in + box x (overlay y z) == overlay (box x y) (box x z) + + test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \x -> + unit(box x (vertex ())) == (x `asTypeOf` empty) + + test "box x empty ~~ empty" $ mapSize (min 10) $ \x -> + unit(box x empty) == empty + + let assoc = gmap $ \(a :: Int, (b :: Int, c :: Int)) -> ((a, b), c) + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \x y z -> + assoc (box x (box y z)) == box (box x y) z + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \x y -> + let _ = x + y + vertex (0 :: Int) in + transpose (box x y) == box (transpose x) (transpose y) + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \x y -> + let _ = x + y + vertex (0 :: Int) in + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \x y -> + let _ = x + y + vertex (0 :: Int) in + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + +testRemoveVertex :: TestsuiteInt g -> IO () +testRemoveVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == empty + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == vertex 2 + + test "removeVertex x (edge x x) == empty" $ \x -> + removeVertex x (edge x x) == empty + + test "removeVertex 1 (edge 1 2) == vertex 2" $ + removeVertex 1 (edge 1 2) == vertex 2 + + test "removeVertex x . removeVertex x == removeVertex x" $ \x y -> + (removeVertex x . removeVertex x) y == removeVertex x y + +testRemoveEdge :: TestsuiteInt g -> IO () +testRemoveEdge (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "removeEdge ============" + test "removeEdge x y (edge x y) == vertices [x,y]" $ \x y -> + removeEdge x y (edge x y) == vertices [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y z -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 + + -- TODO: Ouch. Generic tests are becoming awkward. We need a better way. + when (prefix == "Fold." || prefix == "Graph.") $ do + test "size (removeEdge x y z) <= 3 * size z" $ \x y z -> + size (removeEdge x y z) <= 3 * size z + +testSymmetricRemoveEdge :: TestsuiteInt g -> IO () +testSymmetricRemoveEdge t@(_, API{..}) = do + testRemoveEdge t + test "removeEdge x y == removeEdge y x" $ \x y z -> + removeEdge x y z == removeEdge y x z + +testReplaceVertex :: TestsuiteInt g -> IO () +testReplaceVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == id y + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == vertex y + + test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> + replaceVertex x y z == mergeVertices (== x) y z + +testMergeVertices :: TestsuiteInt g -> IO () +testMergeVertices (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "mergeVertices ============" + test "mergeVertices (const False) x == id" $ \x y -> + mergeVertices (const False) x y == id y + + test "mergeVertices (== x) y == replaceVertex x y" $ \x y z -> + mergeVertices (== x) y z == replaceVertex x y z + + test "mergeVertices even 1 (0 * 2) == 1 * 1" $ + mergeVertices even 1 (0 * 2) == 1 * 1 + + test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ + mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 + +testTranspose :: TestsuiteInt g -> IO () +testTranspose (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "transpose ============" + test "transpose empty == empty" $ + transpose empty == empty + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == vertex x + + test "transpose (edge x y) == edge y x" $ \x y -> + transpose (edge x y) == edge y x + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == id x + + test "edgeList . transpose == sort . map swap . edgeList" $ \x -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + +testGmap :: TestsuiteInt g -> IO () +testGmap (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "gmap ============" + test "gmap f empty == empty" $ \(apply -> f) -> + gmap f empty == empty + + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + gmap f (vertex x) == vertex (f x) + + test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) x y -> + gmap f (edge x y) == edge (f x) (f y) + + test "gmap id == id" $ \x -> + gmap id x == id x + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f :: Int -> Int) (apply -> g :: Int -> Int) x -> + (gmap f . gmap g) x == gmap (f . g) x + +testInduce :: TestsuiteInt g -> IO () +testInduce (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "induce ============" + test "induce (const True ) x == x" $ \x -> + induce (const True ) x == x + + test "induce (const False) x == empty" $ \x -> + induce (const False) x == empty + + test "induce (/= x) == removeVertex x" $ \x y -> + induce (/= x) y == removeVertex x y + + test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) y -> + (induce p . induce q) y == induce (\x -> p x && q x) y + + test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> + isSubgraphOf (induce p x) x == True + +testInduceJust :: Testsuite g Ord -> IO () +testInduceJust (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "induceJust ============" + test "induceJust (vertex Nothing) == empty" $ + induceJust (vertex (Nothing :: Maybe Int)) == empty + + test "induceJust (edge (Just x) Nothing) == vertex x" $ \x -> + induceJust (edge (Just x) (Nothing :: Maybe Int)) == vertex x + + test "induceJust . gmap Just == id" $ \(x :: g Int) -> + (induceJust . gmap Just) x == id x + + test "induceJust . gmap (\\x -> if p x then Just x else Nothing) == induce p" $ \(x :: g Int) (apply -> p) -> + (induceJust . gmap (\x -> if p x then Just x else Nothing)) x == induce p x + +testCompose :: TestsuiteInt g -> IO () +testCompose (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "compose ============" + test "compose empty x == empty" $ \x -> + compose empty x == empty + + test "compose x empty == empty" $ \x -> + compose x empty == empty + + test "compose (vertex x) y == empty" $ \x y -> + compose (vertex x) y == empty + + test "compose x (vertex y) == empty" $ \x y -> + compose x (vertex y) == empty + + test "compose x (compose y z) == compose (compose x y) z" $ size10 $ \x y z -> + compose x (compose y z) == compose (compose x y) z + + test "compose x (overlay y z) == overlay (compose x y) (compose x z)" $ size10 $ \x y z -> + compose x (overlay y z) == overlay (compose x y) (compose x z) + + test "compose (overlay x y) z == overlay (compose x z) (compose y z)" $ size10 $ \x y z -> + compose (overlay x y) z == overlay (compose x z) (compose y z) + + test "compose (edge x y) (edge y z) == edge x z" $ \x y z -> + compose (edge x y) (edge y z) == edge x z + + test "compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)]" $ + compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)] + + test "compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4]" $ + compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4] + +testClosure :: TestsuiteInt g -> IO () +testClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "closure ============" + test "closure empty == empty" $ + closure empty == empty + + test "closure (vertex x) == edge x x" $ \x -> + closure (vertex x) == edge x x + + test "closure (edge x x) == edge x x" $ \x -> + closure (edge x x) == edge x x + + test "closure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> + closure (edge x y) == edges [(x,x), (x,y), (y,y)] + + test "closure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \xs -> + closure (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure x == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure x == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure x + + test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \x y -> + postSet x (closure y) == Set.fromList (reachable x y) + +testReflexiveClosure :: TestsuiteInt g -> IO () +testReflexiveClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == empty + + test "reflexiveClosure (vertex x) == edge x x" $ \x -> + reflexiveClosure (vertex x) == edge x x + + test "reflexiveClosure (edge x x) == edge x x" $ \x -> + reflexiveClosure (edge x x) == edge x x + + test "reflexiveClosure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> + reflexiveClosure (edge x y) == edges [(x,x), (x,y), (y,y)] + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure x + +testSymmetricClosure :: TestsuiteInt g -> IO () +testSymmetricClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == empty + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == vertex x + + test "symmetricClosure (edge x y) == edges [(x,y), (y,x)]" $ \x y -> + symmetricClosure (edge x y) == edges [(x,y), (y,x)] + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == overlay x (transpose x) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure x + +testTransitiveClosure :: TestsuiteInt g -> IO () +testTransitiveClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == empty + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == vertex x + + test "transitiveClosure (edge x y) == edge x y" $ \x y -> + transitiveClosure (edge x y) == edge x y + + test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \xs -> + transitiveClosure (path $ nubOrd xs) == clique (nubOrd xs) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure x + +testSplitVertex :: TestsuiteInt g -> IO () +testSplitVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "splitVertex ============" + test "splitVertex x [] == removeVertex x" $ \x y -> + splitVertex x [] y == removeVertex x y + + test "splitVertex x [x] == id" $ \x y -> + splitVertex x [x] y == id y + + test "splitVertex x [y] == replaceVertex x y" $ \x y z -> + splitVertex x [y] z == replaceVertex x y z + + test "splitVertex 1 [0, 1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ + splitVertex 1 [0, 1] (1 * (2 + 3)) == (0 + 1) * (2 + 3) + +testBind :: TestsuiteInt g -> IO () +testBind (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "bind ============" + test "bind empty f == empty" $ \(apply -> f) -> + bind empty f == empty + + test "bind (vertex x) f == f x" $ \(apply -> f) x -> + bind (vertex x) f == f x + + test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> + bind (edge x y) f == connect (f x) (f y) + + test "bind (vertices xs) f == overlays (map f xs)" $ size10 $ \xs (apply -> f) -> + bind (vertices xs) f == overlays (map f xs) + + test "bind x (const empty) == empty" $ \x -> + bind x (const empty) == empty + + test "bind x vertex == x" $ \x -> + bind x vertex == x + + test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ size10 $ \x (apply -> f) (apply -> g) -> + bind (bind x f) g == bind x (\y -> bind (f y) g) + +testSimplify :: TestsuiteInt g -> IO () +testSimplify (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "simplify ============" + test "simplify == id" $ \x -> + simplify x == id x + + test "size (simplify x) <= size x" $ \x -> + size (simplify x) <= size x + +testBfsForest :: TestsuiteInt g -> IO () +testBfsForest (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "bfsForest ============" + test "bfsForest vs empty == []" $ \vs -> + bfsForest vs empty == [] + + test "forest (bfsForest [1] $ edge 1 1) == vertex 1" $ + forest (bfsForest [1] $ edge 1 1) == vertex 1 + + test "forest (bfsForest [1] $ edge 1 2) == edge 1 2" $ + forest (bfsForest [1] $ edge 1 2) == edge 1 2 + + test "forest (bfsForest [2] $ edge 1 2) == vertex 2" $ + forest (bfsForest [2] $ edge 1 2) == vertex 2 + + test "forest (bfsForest [3] $ edge 1 2) == empty" $ + forest (bfsForest [3] $ edge 1 2) == empty + + test "forest (bfsForest [2,1] $ edge 1 2) == vertices [1,2]" $ + forest (bfsForest [2,1] $ edge 1 2) == vertices [1,2] + + test "isSubgraphOf (forest $ bfsForest vs x) x == True" $ \vs x -> + isSubgraphOf (forest $ bfsForest vs x) x == True + + test "bfsForest (vertexList g) g == " $ \g -> + bfsForest (vertexList g) g == + map (\v -> Node v []) (nub $ vertexList g) + + test "bfsForest [] x == []" $ \x -> + bfsForest [] x == [] + + test "bfsForest [1,4] $ 3 * (1 + 4) * (1 + 5) == " $ + bfsForest [1,4] (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + + test "bfsForest [3] (circuit [1..5] + (circuit [5,4..1])) == " $ + bfsForest [3] (circuit [1..5] + (circuit [5,4..1])) == + [ Node { rootLabel = 3 + , subForest = [ Node { rootLabel = 2 + , subForest = [ Node { rootLabel = 1 + , subForest = []}]} + , Node { rootLabel = 4 + , subForest = [ Node { rootLabel = 5 + , subForest = []}]}]}] + +testBfs :: TestsuiteInt g -> IO () +testBfs (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "bfs ============" + + test "bfs vs $ empty == []" $ \vs -> + bfs vs empty == [] + + test "bfs [] g == []" $ \g -> + bfs [] g == [] + + test "bfs [1] (edge 1 1) == [[1]]" $ + bfs [1] (edge 1 1) == [[1]] + + test "bfs [1] (edge 1 2) == [[1],[2]]" $ + bfs [1] (edge 1 2) == [[1],[2]] + + test "bfs [2] (edge 1 2) == [[2]]" $ + bfs [2] (edge 1 2) == [[2]] + + test "bfs [1,2] (edge 1 2) == [[1,2]]" $ + bfs [1,2] (edge 1 2) == [[1,2]] + + test "bfs [2,1] (edge 1 2) == [[2,1]]" $ + bfs [2,1] (edge 1 2) == [[2,1]] + + test "bfs [3] (edge 1 2) == []" $ + bfs [3] (edge 1 2) == [] + + test "bfs [1,2] ((1*2) + (3*4) + (5*6)) == [[1,2]]" $ + bfs [1,2] ((1*2) + (3*4) + (5*6)) == [[1,2]] + + test "bfs [1,3] ((1*2) + (3*4) + (5*6)) == [[1,3],[2,4]]" $ + bfs [1,3] ((1*2) + (3*4) + (5*6)) == [[1,3],[2,4]] + + test "bfs [3] (3 * (1 + 4) * (1 + 5)) == [[3],[1,4,5]]" $ + bfs [3] (3 * (1 + 4) * (1 + 5)) == [[3],[1,4,5]] + + test "bfs [2] (circuit [1..5] + (circuit [5,4..1])) == [[2],[1,3],[5,4]]" $ + bfs [2] (circuit [1..5] + (circuit [5,4..1])) == [[2],[1,3],[5,4]] + + test "concat (bfs [3] $ circuit [1..5] + circuit [5,4..1]) == [3,2,4,1,5]" $ + concat (bfs [3] $ circuit [1..5] + circuit [5,4..1]) == [3,2,4,1,5] + + test "isSubgraphOf (vertices $ concat $ bfs vs x) x == True" $ \vs x -> + isSubgraphOf (vertices $ concat $ bfs vs x) x == True + + test "bfs vs == map concat . List.transpose . map levels . bfsForest vs" $ \vs g -> + (bfs vs) g == (map concat . List.transpose . map levels . bfsForest vs) g + +testDfsForest :: TestsuiteInt g -> IO () +testDfsForest (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfsForest ============" + test "dfsForest empty == []" $ + dfsForest empty == [] + + test "forest (dfsForest $ edge 1 1) == vertex 1" $ + forest (dfsForest $ edge 1 1) == vertex 1 + + test "forest (dfsForest $ edge 1 2) == edge 1 2" $ + forest (dfsForest $ edge 1 2) == edge 1 2 + + test "forest (dfsForest $ edge 2 1) == vertices [1,2]" $ + forest (dfsForest $ edge 2 1) == vertices [1,2] + + test "isSubgraphOf (forest $ dfsForest x) x == True" $ \x -> + isSubgraphOf (forest $ dfsForest x) x == True + + test "isDfsForestOf (dfsForest x) x == True" $ \x -> + isDfsForestOf (dfsForest x) x == True + + test "dfsForest . forest . dfsForest == dfsForest" $ \x -> + (dfsForest . forest . dfsForest) x == dfsForest x + + test "dfsForest (vertices vs) == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> + dfsForest (vertices vs) == map (\v -> Node v []) (nub $ sort vs) + + test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ + dfsForest (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 3 + , subForest = [ Node { rootLabel = 4 + , subForest = [] }]}] + test "forest (dfsForest $ circuit [1..5] + circuit [5,4..1]) == path [1,2,3,4,5]" $ + forest (dfsForest $ circuit [1..5] + circuit [5,4..1]) == path [1,2,3,4,5] + +testDfsForestFrom :: TestsuiteInt g -> IO () +testDfsForestFrom (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfsForestFrom ============" + test "dfsForestFrom vs empty == []" $ \vs -> + dfsForestFrom vs empty == [] + + test "forest (dfsForestFrom [1] $ edge 1 1) == vertex 1" $ + forest (dfsForestFrom [1] $ edge 1 1) == vertex 1 + + test "forest (dfsForestFrom [1] $ edge 1 2) == edge 1 2" $ + forest (dfsForestFrom [1] $ edge 1 2) == edge 1 2 + + test "forest (dfsForestFrom [2] $ edge 1 2) == vertex 2" $ + forest (dfsForestFrom [2] $ edge 1 2) == vertex 2 + + test "forest (dfsForestFrom [3] $ edge 1 2) == empty" $ + forest (dfsForestFrom [3] $ edge 1 2) == empty + + test "forest (dfsForestFrom [2,1] $ edge 1 2) == vertices [1,2]" $ + forest (dfsForestFrom [2,1] $ edge 1 2) == vertices [1,2] + + test "isSubgraphOf (forest $ dfsForestFrom vs x) x == True" $ \vs x -> + isSubgraphOf (forest $ dfsForestFrom vs x) x == True + + test "isDfsForestOf (dfsForestFrom (vertexList x) x) x == True" $ \x -> + isDfsForestOf (dfsForestFrom (vertexList x) x) x == True + + test "dfsForestFrom (vertexList x) x == dfsForest x" $ \x -> + dfsForestFrom (vertexList x) x == dfsForest x + + test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> + dfsForestFrom vs (vertices vs) == map (\v -> Node v []) (nub vs) + + test "dfsForestFrom [] x == []" $ \x -> + dfsForestFrom [] x == [] + + test "dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == " $ + dfsForestFrom [1,4] (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + test "forest (dfsForestFrom [3] $ circuit [1..5] + circuit [5,4..1]) == path [3,2,1,5,4]" $ + forest (dfsForestFrom [3] $ circuit [1..5] + circuit [5,4..1]) == path [3,2,1,5,4] + + +testDfs :: TestsuiteInt g -> IO () +testDfs (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfs ============" + test "dfs vs $ empty == []" $ \vs -> + dfs vs empty == [] + + test "dfs [1] $ edge 1 1 == [1]" $ + dfs [1] (edge 1 1) == [1] + + test "dfs [1] $ edge 1 2 == [1,2]" $ + dfs [1] (edge 1 2) == [1,2] + + test "dfs [2] $ edge 1 2 == [2]" $ + dfs [2] (edge 1 2) == [2] + + test "dfs [3] $ edge 1 2 == []" $ + dfs [3] (edge 1 2) == [] + + test "dfs [1,2] $ edge 1 2 == [1,2]" $ + dfs [1,2] (edge 1 2) == [1,2] + + test "dfs [2,1] $ edge 1 2 == [2,1]" $ + dfs [2,1] (edge 1 2) == [2,1] + + test "dfs [] $ x == []" $ \x -> + dfs [] x == [] + + test "dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4]" $ + dfs [1,4] (3 * (1 + 4) * (1 + 5)) == [1,5,4] + + test "isSubgraphOf (vertices $ dfs vs x) x == True" $ \vs x -> + isSubgraphOf (vertices $ dfs vs x) x == True + + test "dfs [3] (circuit [1..5] + circuit [5,4..1]) == [3,2,1,5,4]" $ + dfs [3] (circuit [1..5] + circuit [5,4..1]) == [3,2,1,5,4] + +testReachable :: TestsuiteInt g -> IO () +testReachable (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfs ============" + test "reachable x $ empty == []" $ \x -> + reachable x empty == [] + + test "reachable 1 $ vertex 1 == [1]" $ + reachable 1 (vertex 1) == [1] + + test "reachable 1 $ vertex 2 == []" $ + reachable 1 (vertex 2) == [] + + test "reachable 1 $ edge 1 1 == [1]" $ + reachable 1 (edge 1 1) == [1] + + test "reachable 1 $ edge 1 2 == [1,2]" $ + reachable 1 (edge 1 2) == [1,2] + + test "reachable 4 $ path [1..8] == [4..8]" $ + reachable 4 (path [1..8]) == [4..8] + + test "reachable 4 $ circuit [1..8] == [4..8] ++ [1..3]" $ + reachable 4 (circuit [1..8]) == [4..8] ++ [1..3] + + test "reachable 8 $ clique [8,7..1] == [8] ++ [1..7]" $ + reachable 8 (clique [8,7..1]) == [8] ++ [1..7] + + test "isSubgraphOf (vertices $ reachable x y) y == True" $ \x y -> + isSubgraphOf (vertices $ reachable x y) y == True + +testTopSort :: TestsuiteInt g -> IO () +testTopSort (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "topSort ============" + test "topSort (1 * 2 + 3 * 1) == Right [3,1,2]" $ + topSort (1 * 2 + 3 * 1) == Right [3,1,2] + + test "topSort (path [1..5]) == Right [1..5]" $ + topSort (path [1..5]) == Right [1..5] + + test "topSort (3 * (1 * 4 + 2 * 5)) == Right [3,1,2,4,5]" $ + topSort (3 * (1 * 4 + 2 * 5)) == Right [3,1,2,4,5] + + test "topSort (1 * 2 + 2 * 1) == Left (2 :| [1])" $ + topSort (1 * 2 + 2 * 1) == Left (2 :| [1]) + + test "topSort (path [5,4..1] + edge 2 4) == Left (4 :| [3,2])" $ + topSort (path [5,4..1] + edge 2 4) == Left (4 :| [3,2]) + + test "topSort (circuit [1..5]) == Left (3 :| [1,2])" $ + topSort (circuit [1..3]) == Left (3 :| [1,2]) + + test "topSort (circuit [1..3] + circuit [3,2,1]) == Left (3 :| [2])" $ + topSort (circuit [1..3] + circuit [3,2,1]) == Left (3 :| [2]) + + test "topSort (1*2 + 2*1 + 3*4 + 4*3 + 5*1) == Left (1 :| [2])" $ + topSort (1*2 + 2*1 + 3*4 + 4*3 + 5*1) == Left (1 :| [2]) + + test "fmap (flip isTopSortOf x) (topSort x) /= Right False" $ \x -> + fmap (flip isTopSortOf x) (topSort x) /= Right False + + test "topSort . vertices == Right . nub . sort" $ \vs -> + (topSort . vertices) vs == (Right . nubOrd . sort) vs + + + +testIsAcyclic :: TestsuiteInt g -> IO () +testIsAcyclic (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "testIsAcyclic ============" + test "isAcyclic (1 * 2 + 3 * 1) == True" $ + isAcyclic (1 * 2 + 3 * 1) == True + + test "isAcyclic (1 * 2 + 2 * 1) == False" $ + isAcyclic (1 * 2 + 2 * 1) == False + + test "isAcyclic . circuit == null" $ \xs -> + (isAcyclic . circuit) xs == null xs + + test "isAcyclic == isRight . topSort" $ \x -> + isAcyclic x == isRight (topSort x) + +testIsDfsForestOf :: TestsuiteInt g -> IO () +testIsDfsForestOf (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isDfsForestOf ============" + test "isDfsForestOf [] empty == True" $ + isDfsForestOf [] empty == True + + test "isDfsForestOf [] (vertex 1) == False" $ + isDfsForestOf [] (vertex 1) == False + + test "isDfsForestOf [Node 1 []] (vertex 1) == True" $ + isDfsForestOf [Node 1 []] (vertex 1) == True + + test "isDfsForestOf [Node 1 []] (vertex 2) == False" $ + isDfsForestOf [Node 1 []] (vertex 2) == False + + test "isDfsForestOf [Node 1 [], Node 1 []] (vertex 1) == False" $ + isDfsForestOf [Node 1 [], Node 1 []] (vertex 1) == False + + test "isDfsForestOf [Node 1 []] (edge 1 1) == True" $ + isDfsForestOf [Node 1 []] (edge 1 1) == True + + test "isDfsForestOf [Node 1 []] (edge 1 2) == False" $ + isDfsForestOf [Node 1 []] (edge 1 2) == False + + test "isDfsForestOf [Node 1 [], Node 2 []] (edge 1 2) == False" $ + isDfsForestOf [Node 1 [], Node 2 []] (edge 1 2) == False + + test "isDfsForestOf [Node 2 [], Node 1 []] (edge 1 2) == True" $ + isDfsForestOf [Node 2 [], Node 1 []] (edge 1 2) == True + + test "isDfsForestOf [Node 1 [Node 2 []]] (edge 1 2) == True" $ + isDfsForestOf [Node 1 [Node 2 []]] (edge 1 2) == True + + test "isDfsForestOf [Node 1 [], Node 2 []] (vertices [1,2]) == True" $ + isDfsForestOf [Node 1 [], Node 2 []] (vertices [1,2]) == True + + test "isDfsForestOf [Node 2 [], Node 1 []] (vertices [1,2]) == True" $ + isDfsForestOf [Node 2 [], Node 1 []] (vertices [1,2]) == True + + test "isDfsForestOf [Node 1 [Node 2 []]] (vertices [1,2]) == False" $ + isDfsForestOf [Node 1 [Node 2 []]] (vertices [1,2]) == False + + test "isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] (path [1,2,3]) == True" $ + isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] (path [1,2,3]) == True + + test "isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] (path [1,2,3]) == False" $ + isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] (path [1,2,3]) == False + + test "isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] (path [1,2,3]) == True" $ + isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] (path [1,2,3]) == True + + test "isDfsForestOf [Node 2 [Node 3 []], Node 1 []] (path [1,2,3]) == True" $ + isDfsForestOf [Node 2 [Node 3 []], Node 1 []] (path [1,2,3]) == True + + test "isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] (path [1,2,3]) == False" $ + isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] (path [1,2,3]) == False + +testIsTopSortOf :: TestsuiteInt g -> IO () +testIsTopSortOf (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isTopSortOf ============" + test "isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True" $ + isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True + + test "isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False" $ + isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False + + test "isTopSortOf [] (1 * 2 + 3 * 1) == False" $ + isTopSortOf [] (1 * 2 + 3 * 1) == False + + test "isTopSortOf [] empty == True" $ + isTopSortOf [] empty == True + + test "isTopSortOf [x] (vertex x) == True" $ \x -> + isTopSortOf [x] (vertex x) == True + + test "isTopSortOf [x] (edge x x) == False" $ \x -> + isTopSortOf [x] (edge x x) == False diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs --- a/test/Algebra/Graph/Test/Graph.hs +++ b/test/Algebra/Graph/Test/Graph.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Graph --- 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 @@ -12,30 +12,31 @@ module Algebra.Graph.Test.Graph ( -- * Testsuite testGraph - ) where - -import Prelude () -import Prelude.Compat + ) where import Data.Either import Algebra.Graph import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, graphAPI) import Algebra.Graph.Test.Generic import Algebra.Graph.ToGraph (reachable) import qualified Data.Graph as KL -t :: Testsuite -t = testsuite "Graph." empty +tPoly :: Testsuite Graph Ord +tPoly = ("Graph.", graphAPI) +t :: TestsuiteInt Graph +t = fmap toIntAPI tPoly + type G = Graph Int testGraph :: IO () testGraph = do putStrLn "\n============ Graph ============" - test "Axioms of graphs" (axioms :: GraphTestsuite G) - test "Theorems of graphs" (theorems :: GraphTestsuite G) + test "Axioms of graphs" (axioms @ G) + test "Theorems of graphs" (theorems @ G) testBasicPrimitives t testIsSubgraphOf t @@ -43,6 +44,7 @@ testSize t testGraphFamilies t testTransformations t + testInduceJust tPoly ---------------------------------------------------------------- -- Generic relational composition tests, plus an additional one @@ -67,103 +69,14 @@ test "x + y === x * y == False" $ \(x :: G) y -> (x + y === x * y) == False - putStrLn "\n============ Graph.mesh ============" - test "mesh xs [] == empty" $ \xs -> - mesh xs [] == (empty :: Graph (Int, Int)) - test "mesh [] ys == empty" $ \ys -> - mesh [] ys == (empty :: Graph (Int, Int)) - - test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> - mesh [x] [y] == vertex (x, y) - - test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - mesh xs ys == box (path xs) (path ys) - - test "mesh [1..3] \"ab\" == " $ - mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) - , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ] - test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs :: [Int]) (ys :: [Int]) -> - size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) - - putStrLn "\n============ Graph.torus ============" - test "torus xs [] == empty" $ \xs -> - torus xs [] == (empty :: Graph (Int, Int)) - - test "torus [] ys == empty" $ \ys -> - torus [] ys == (empty :: Graph (Int, Int)) - - test "torus [x] [y] == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> - torus [x] [y] == edge (x,y) (x,y) - - test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - torus xs ys == box (circuit xs) (circuit ys) - - test "torus [1,2] \"ab\" == " $ - torus [1,2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) - , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ] - - test "size (torus xs ys) == max 1 (3 * length xs * length ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - size (torus xs ys) == max 1 (3 * length xs * length ys) - - - putStrLn "\n============ Graph.deBruijn ============" - test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> - deBruijn 0 xs ==(edge [] [] :: Graph [Int]) - - test "n > 0 ==> deBruijn n [] == empty" $ \n -> - n > 0 ==> deBruijn n [] == (empty :: Graph [Int]) - - test " deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ - deBruijn 1 [0,1::Int] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] - - test " deBruijn 2 \"0\" == edge \"00\" \"00\"" $ - deBruijn 2 "0" == edge "00" "00" - - test " deBruijn 2 \"01\" == " $ - deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") - , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] - - test " transpose (deBruijn n xs) == fmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - transpose (deBruijn n xs) == fmap reverse (deBruijn n xs) - - test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n - - test "n > 0 ==> edgeCount (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - n > 0 ==> edgeCount (deBruijn n xs) == (length $ nubOrd xs)^(n + 1) - + testMesh tPoly + testTorus tPoly + testDeBruijn tPoly testSplitVertex t testBind t testSimplify t - - putStrLn "\n============ Graph.box ============" - let unit = fmap $ \(a, ()) -> a - comm = fmap $ \(a, b) -> (b, a) - test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - comm (box x y) == box y x - - test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z -> - box x (overlay y z) == overlay (box x y) (box x z) - - test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: G) -> - unit(box x (vertex ())) == x - - test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: G) -> - unit(box x empty) == empty - - let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) - test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: G) (y :: G) (z :: G) -> - assoc (box x (box y z)) == box (box x y) z - - test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - transpose (box x y) == box (transpose x) (transpose y) - - test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - vertexCount (box x y) == vertexCount x * vertexCount y - - test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + testBox tPoly putStrLn "\n============ Graph.sparsify ============" test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> @@ -198,7 +111,7 @@ let x = vertices [1..n] `overlay` edges es return $ length (KL.edges $ sparsifyKL n x) <= 3 * size x - putStrLn "\n============ Labelled.Graph.context ============" + putStrLn "\n============ Graph.context ============" test "context (const False) x == Nothing" $ \x -> context (const False) (x :: G) == Nothing @@ -213,3 +126,22 @@ test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [3,1] [1,5])" $ context (== 4) (3 * 1 * 4 * 1 * 5 :: G) == Just (Context [3,1] [1,5]) + + putStrLn "\n============ Graph.buildg ============" + test "buildg (\\e _ _ _ -> e) == empty" $ + buildg (\e _ _ _ -> e) == (empty :: G) + + test "buildg (\\_ v _ _ -> v x) == vertex x" $ \(x :: Int) -> + buildg (\_ v _ _ -> v x) == vertex x + + test "buildg (\\e v o c -> o (foldg e v o c x) (foldg e v o c y)) == overlay x y" $ \(x :: G) y -> + buildg (\e v o c -> o (foldg e v o c x) (foldg e v o c y)) == overlay x y + + test "buildg (\\e v o c -> c (foldg e v o c x) (foldg e v o c y)) == connect x y" $ \(x :: G) y -> + buildg (\e v o c -> c (foldg e v o c x) (foldg e v o c y)) == connect x y + + test "buildg (\\e v o _ -> foldr o e (map v xs)) == vertices xs" $ \(xs :: [Int]) -> + buildg (\e v o _ -> foldr o e (map v xs)) == vertices xs + + test "buildg (\\e v o c -> foldg e v o (flip c) g) == transpose g" $ \(g :: G) -> + buildg (\e v o c -> foldg e v o (flip c) g) == transpose g diff --git a/test/Algebra/Graph/Test/Internal.hs b/test/Algebra/Graph/Test/Internal.hs --- a/test/Algebra/Graph/Test/Internal.hs +++ b/test/Algebra/Graph/Test/Internal.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, OverloadedLists #-} +{-# LANGUAGE OverloadedLists #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Internal --- 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 @@ -12,19 +12,11 @@ module Algebra.Graph.Test.Internal ( -- * Testsuite testInternal - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - -import Control.Applicative (pure) + ) where import Algebra.Graph.Internal import Algebra.Graph.Test +import Data.Semigroup ((<>)) testInternal :: IO () testInternal = do diff --git a/test/Algebra/Graph/Test/Label.hs b/test/Algebra/Graph/Test/Label.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Label.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedLists #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Label +-- Copyright : (c) Andrey Mokhov 2016-2020 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Label". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Label ( + -- * Testsuite + testLabel + ) where + +import Algebra.Graph.Test +import Algebra.Graph.Label +import Data.Monoid + +type Unary a = a -> a +type Binary a = a -> a -> a +type Additive a = Binary a +type Multiplicative a = Binary a +type Star a = Unary a +type Identity a = a +type Zero a = a +type One a = a + +associative :: Eq a => Binary a -> a -> a -> a -> Property +associative (<>) a b c = (a <> b) <> c == a <> (b <> c) // "Associative" + +commutative :: Eq a => Binary a -> a -> a -> Property +commutative (<>) a b = a <> b == b <> a // "Commutative" + +idempotent :: Eq a => Binary a -> a -> Property +idempotent (<>) a = a <> a == a // "Idempotent" + +annihilatingZero :: Eq a => Binary a -> Zero a -> a -> Property +annihilatingZero (<>) z a = conjoin + [ a <> z == z // "Left" + , z <> a == z // "Right" ] // "Annihilating zero" + +closure :: Eq a => Additive a -> Multiplicative a -> One a -> Star a -> a -> Property +closure (+) (*) o s a = conjoin + [ s a == o + (a * s a) // "Left" + , s a == o + (s a * a) // "Right" ] // "Closure" + +leftDistributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property +leftDistributive (+) (*) a b c = + a * (b + c) == (a * b) + (a * c) // "Left distributive" + +rightDistributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property +rightDistributive (+) (*) a b c = + (a + b) * c == (a * c) + (b * c) // "Right distributive" + +distributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property +distributive p m a b c = conjoin + [ leftDistributive p m a b c + , rightDistributive p m a b c ] // "Distributive" + +identity :: Eq a => Binary a -> Identity a -> a -> Property +identity (<>) e a = conjoin + [ a <> e == a // "Left" + , e <> a == a // "Right" ] // "Identity" + +semigroup :: Eq a => Binary a -> a -> a -> a -> Property +semigroup f a b c = associative f a b c // "Semigroup" + +monoid :: Eq a => Binary a -> Identity a -> a -> a -> a -> Property +monoid f e a b c = conjoin + [ semigroup f a b c + , identity f e a ] // "Monoid" + +commutativeMonoid :: Eq a => Binary a -> Identity a -> a -> a -> a -> Property +commutativeMonoid f e a b c = conjoin + [ monoid f e a b c + , commutative f a b ] // "Commutative monoid" + +leftNearRing :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property +leftNearRing (+) z (*) o a b c = conjoin + [ commutativeMonoid (+) z a b c + , monoid (*) o a b c + , leftDistributive (+) (*) a b c + , annihilatingZero (*) z a ] // "Left near ring" + +semiring :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property +semiring (+) z (*) o a b c = conjoin + [ commutativeMonoid (+) z a b c + , monoid (*) o a b c + , distributive (+) (*) a b c + , annihilatingZero (*) z a ] // "Semiring" + +dioid :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property +dioid (+) z (*) o a b c = conjoin + [ semiring (+) z (*) o a b c + , idempotent (+) a ] // "Dioid" + +starSemiring :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> Star a -> a -> a -> a -> Property +starSemiring (+) z (*) o s a b c = conjoin + [ semiring (+) z (*) o a b c + , closure (+) (*) o s a ] // "Star semiring" + +testLeftNearRing :: (Eq a, Semiring a) => a -> a -> a -> Property +testLeftNearRing = leftNearRing (<+>) zero (<.>) one + +testSemiring :: (Eq a, Semiring a) => a -> a -> a -> Property +testSemiring = semiring (<+>) zero (<.>) one + +testDioid :: (Eq a, Dioid a) => a -> a -> a -> Property +testDioid = dioid (<+>) zero (<.>) one + +testStarSemiring :: (Eq a, StarSemiring a) => a -> a -> a -> Property +testStarSemiring = starSemiring (<+>) zero (<.>) one star + +testLabel :: IO () +testLabel = do + putStrLn "\n============ Graph.Label ============" + putStrLn "\n============ Any: instances ============" + test "Semiring" $ testSemiring @Any + test "StarSemiring" $ testStarSemiring @Any + test "Dioid" $ testDioid @Any + + putStrLn "\n============ Distance Int: instances ============" + test "Semiring" $ testSemiring @(Distance Int) + test "StarSemiring" $ testStarSemiring @(Distance Int) + test "Dioid" $ testDioid @(Distance Int) + + putStrLn "\n============ Capacity Int: instances ============" + test "Semiring" $ testSemiring @(Capacity Int) + test "StarSemiring" $ testStarSemiring @(Capacity Int) + test "Dioid" $ testDioid @(Capacity Int) + + putStrLn "\n============ Minimum (Path Int): instances ============" + test "LeftNearRing" $ testLeftNearRing @(Minimum (Path Int)) + + putStrLn "\n============ PowerSet (Path Int): instances ============" + test "Semiring" $ size10 $ testSemiring @(PowerSet (Path Int)) + test "Dioid" $ size10 $ testDioid @(PowerSet (Path Int)) + + putStrLn "\n============ Count Int: instances ============" + test "Semiring" $ testSemiring @(Count Int) + test "StarSemiring" $ testStarSemiring @(Count Int) diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.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 @@ -18,8 +18,8 @@ import Algebra.Graph.Label import Algebra.Graph.Labelled.AdjacencyMap -import Algebra.Graph.Labelled.AdjacencyMap.Internal import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, labelledAdjacencyMapAPI) import Algebra.Graph.Test.Generic import Algebra.Graph.ToGraph (reachable) @@ -27,9 +27,12 @@ import qualified Data.Map as Map import qualified Data.Set as Set -t :: Testsuite -t = testsuite "Labelled.AdjacencyMap." (empty :: LAI) +tPoly :: Testsuite (AdjacencyMap Any) Ord +tPoly = ("Labelled.AdjacencyMap.", labelledAdjacencyMapAPI) +t :: TestsuiteInt (AdjacencyMap Any) +t = fmap toIntAPI tPoly + type S = Sum Int type D = Distance Int @@ -39,7 +42,7 @@ testLabelledAdjacencyMap :: IO () testLabelledAdjacencyMap = do - putStrLn "\n============ Labelled.AdjacencyMap.Internal.consistent ============" + putStrLn "\n============ Labelled.AdjacencyMap.consistent ============" test "arbitraryLabelledAdjacencyMap" $ \x -> consistent (x :: LAS) test "empty" $ consistent (empty :: LAS) test "vertex" $ \x -> consistent (vertex x :: LAS) @@ -350,7 +353,7 @@ test "transpose (edge e x y) == edge e y x" $ \e x y -> transpose (edge e x y) == (edge e y x :: LAS) - test "transpose . transpose == id" $ size10 $ \x -> + test "transpose . transpose == id" $ size10 $ \x -> (transpose . transpose) x == (x :: LAS) putStrLn "\n============ Labelled.AdjacencyMap.gmap ============" @@ -403,6 +406,7 @@ in (emap g . emap h) x == (emap (g . h) x :: LAS) testInduce t + testInduceJust tPoly putStrLn "\n============ Labelled.AdjacencyMap.closure ============" test "closure empty == empty" $ diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs --- a/test/Algebra/Graph/Test/Labelled/Graph.hs +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -19,14 +19,18 @@ import Algebra.Graph.Label import Algebra.Graph.Labelled import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, labelledGraphAPI) import Algebra.Graph.Test.Generic import qualified Algebra.Graph.ToGraph as T import qualified Data.Set as Set -t :: Testsuite -t = testsuite "Labelled.Graph." (empty :: LAI) +tPoly :: Testsuite (Graph Any) Ord +tPoly = ("Labelled.Graph.", labelledGraphAPI) +t :: TestsuiteInt (Graph Any) +t = fmap toIntAPI tPoly + type S = Sum Int type D = Distance Int @@ -376,7 +380,8 @@ g = (l*) in (emap g . emap h) x == (emap (g . h) x :: LAS) - testInduce t + testInduce t + testInduceJust tPoly putStrLn "\n============ Labelled.Graph.closure ============" test "closure empty == empty" $ diff --git a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, OverloadedLists, ViewPatterns #-} +{-# LANGUAGE OverloadedLists, ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.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 @@ -12,22 +12,16 @@ module Algebra.Graph.Test.NonEmpty.AdjacencyMap ( -- * Testsuite testNonEmptyAdjacencyMap - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif + ) where import Control.Monad +import Data.Semigroup ((<>)) import Data.Tree import Data.Tuple import Algebra.Graph.NonEmpty.AdjacencyMap import Algebra.Graph.Test hiding (axioms, theorems) -import Algebra.Graph.ToGraph (toAdjacencyMap, reachable) +import Algebra.Graph.ToGraph (reachable) import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty @@ -119,15 +113,19 @@ show (vertex (-1) * vertex (-2) + vertex (-3) :: AdjacencyMap Int) == "overlay (vertex (-3)) (edge (-1) (-2))" putStrLn $ "\n============ NonEmpty.AdjacencyMap.toNonEmpty ============" - test "toNonEmpty empty == Nothing" $ + test "toNonEmpty empty == Nothing" $ toNonEmpty (AM.empty :: AM.AdjacencyMap Int) == Nothing - test "toNonEmpty (toAdjacencyMap x) == Just (x :: NonEmpty.AdjacencyMap a)" $ \x -> - toNonEmpty (toAdjacencyMap x) == Just (x :: G) + test "toNonEmpty . fromNonEmpty == Just" $ \(x :: G) -> + (toNonEmpty . fromNonEmpty) x == Just x + putStrLn $ "\n============ NonEmpty.AdjacencyMap.fromNonEmpty ============" + test "isEmpty . fromNonEmpty == const False" $ \(x :: G) -> + (AM.isEmpty . fromNonEmpty) x == const False x + putStrLn $ "\n============ NonEmpty.AdjacencyMap.vertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) test "vertexCount (vertex x) == 1" $ \(x :: Int) -> vertexCount (vertex x) == 1 @@ -221,6 +219,10 @@ test "edges1 [(x,y)] == edge x y" $ \(x :: Int) y -> edges1 [(x,y)] == edge x y + test "edges1 == overlays1 . fmap (uncurry edge)" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in edges1 xs == (overlays1 . fmap (uncurry edge)) xs + test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> let xs = NonEmpty.fromList (getNonEmpty xs') in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs @@ -255,11 +257,8 @@ in isSubgraphOf x y ==> x <= y putStrLn $ "\n============ NonEmpty.AdjacencyMap.hasVertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: G) == False + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) putStrLn $ "\n============ NonEmpty.AdjacencyMap.hasEdge ============" test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> @@ -545,6 +544,19 @@ test "induce1 p >=> induce1 q == induce1 (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: G) -> (induce1 p >=> induce1 q) y == induce1 (\x -> p x && q x) y + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.induceJust1 ============" + test "induceJust1 (vertex Nothing) == Nothing" $ + induceJust1 (vertex (Nothing :: Maybe Int)) == Nothing + + test "induceJust1 (edge (Just x) Nothing) == Just (vertex x)" $ \(x :: G) -> + induceJust1 (edge (Just x) Nothing) == Just (vertex x) + + test "induceJust1 . gmap Just == Just" $ \(x :: G) -> + (induceJust1 . gmap Just) x == Just x + + test "induceJust1 . gmap (\\x -> if p x then Just x else Nothing) == induce1 p" $ \(x :: G) (apply -> p) -> + (induceJust1 . gmap (\x -> if p x then Just x else Nothing)) x == induce1 p x putStrLn $ "\n============ NonEmpty.AdjacencyMap.closure ============" test "closure (vertex x) == edge x x" $ \(x :: Int) -> diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, OverloadedLists, ViewPatterns #-} +{-# LANGUAGE OverloadedLists, ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.NonEmpty.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 @@ -12,18 +12,12 @@ module Algebra.Graph.Test.NonEmpty.Graph ( -- * Testsuite testNonEmptyGraph - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif + ) where import Control.Monad import Data.Either import Data.Maybe +import Data.Semigroup ((<>)) import Data.Tree import Data.Tuple @@ -125,8 +119,8 @@ toNonEmpty (toGraph x) == Just (x :: G) putStrLn $ "\n============ NonEmpty.Graph.vertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) test "vertexCount (vertex x) == 1" $ \(x :: Int) -> vertexCount (vertex x) == 1 @@ -237,6 +231,10 @@ test "edges1 [(x,y)] == edge x y" $ \(x :: Int) y -> edges1 [(x,y)] == edge x y + test "edges1 == overlays1 . fmap (uncurry edge)" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in edges1 xs == (overlays1 . fmap (uncurry edge)) xs + test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> let xs = NonEmpty.fromList (getNonEmpty xs') in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs @@ -313,11 +311,8 @@ size x >= vertexCount x putStrLn $ "\n============ NonEmpty.Graph.hasVertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: G) == False + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) putStrLn $ "\n============ NonEmpty.Graph.hasEdge ============" test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> @@ -626,6 +621,19 @@ test "induce1 p >=> induce1 q == induce1 (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: G) -> (induce1 p >=> induce1 q) y == induce1 (\x -> p x && q x) y + + putStrLn $ "\n============ NonEmpty.Graph.induceJust1 ============" + test "induceJust1 (vertex Nothing) == Nothing" $ + induceJust1 (vertex (Nothing :: Maybe Int)) == Nothing + + test "induceJust1 (edge (Just x) Nothing) == Just (vertex x)" $ \(x :: G) -> + induceJust1 (edge (Just x) Nothing) == Just (vertex x) + + test "induceJust1 . fmap Just == Just" $ \(x :: G) -> + (induceJust1 . fmap Just) x == Just x + + test "induceJust1 . fmap (\\x -> if p x then Just x else Nothing) == induce1 p" $ \(x :: G) (apply -> p) -> + (induceJust1 . fmap (\x -> if p x then Just x else Nothing)) x == induce1 p x putStrLn $ "\n============ NonEmpty.Graph.simplify ============" test "simplify == id" $ \(x :: G) -> diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Relation --- 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 @@ -11,26 +11,30 @@ module Algebra.Graph.Test.Relation ( -- * Testsuite testRelation - ) where + ) where import Algebra.Graph.Relation import Algebra.Graph.Relation.Preorder import Algebra.Graph.Relation.Reflexive import Algebra.Graph.Relation.Transitive import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, relationAPI) import Algebra.Graph.Test.Generic import qualified Algebra.Graph.Class as C -t :: Testsuite -t = testsuite "Relation." empty +tPoly :: Testsuite Relation Ord +tPoly = ("Relation.", relationAPI) +t :: TestsuiteInt Relation +t = fmap toIntAPI tPoly + type RI = Relation Int testRelation :: IO () testRelation = do putStrLn "\n============ Relation ============" - test "Axioms of graphs" $ size10 (axioms :: GraphTestsuite RI) + test "Axioms of graphs" $ size10 $ axioms @ RI testConsistent t testShow t @@ -40,21 +44,22 @@ testGraphFamilies t testTransformations t testRelational t + testInduceJust tPoly putStrLn "\n============ ReflexiveRelation ============" - test "Axioms of reflexive graphs" $ size10 - (reflexiveAxioms :: GraphTestsuite (ReflexiveRelation Int)) + test "Axioms of reflexive graphs" $ size10 $ + reflexiveAxioms @ (ReflexiveRelation Int) putStrLn "\n============ TransitiveRelation ============" - test "Axioms of transitive graphs" $ size10 - (transitiveAxioms :: GraphTestsuite (TransitiveRelation Int)) + test "Axioms of transitive graphs" $ size10 $ + transitiveAxioms @ (TransitiveRelation Int) test "path xs == (clique xs :: TransitiveRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: TransitiveRelation Int) putStrLn "\n============ PreorderRelation ============" - test "Axioms of preorder graphs" $ size10 - (preorderAxioms :: GraphTestsuite (PreorderRelation Int)) + test "Axioms of preorder graphs" $ size10 $ + preorderAxioms @ (PreorderRelation Int) test "path xs == (clique xs :: PreorderRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: PreorderRelation Int) diff --git a/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs b/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs --- a/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs +++ b/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs @@ -1,35 +1,38 @@ ----------------------------------------------------------------------------- -- | --- Module : Algebra.Graph.Test.Relation --- Copyright : (c) Andrey Mokhov 2016-2019 +-- Module : Algebra.Graph.Test.Relation.SymmetricRelation +-- Copyright : (c) Andrey Mokhov 2016-2020 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Testsuite for "Algebra.Graph.Relation". +-- Testsuite for "Algebra.Graph.Relation.Symmetric". ----------------------------------------------------------------------------- module Algebra.Graph.Test.Relation.SymmetricRelation ( -- * Testsuite testSymmetricRelation - ) where + ) where import Algebra.Graph.Relation.Symmetric import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, symmetricRelationAPI) import Algebra.Graph.Test.Generic import qualified Algebra.Graph.Relation as R -t :: Testsuite -t = testsuite "Symmetric.Relation." empty +tPoly :: Testsuite Relation Ord +tPoly = ("Symmetric.Relation.", symmetricRelationAPI) +t :: TestsuiteInt Relation +t = fmap toIntAPI tPoly + type RI = R.Relation Int type SRI = Relation Int testSymmetricRelation :: IO () testSymmetricRelation = do putStrLn "\n============ Symmetric.Relation ============" - test "Axioms of undirected graphs" $ - size10 (undirectedAxioms :: GraphTestsuite SRI) + test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @ SRI testConsistent t testSymmetricShow t @@ -65,4 +68,5 @@ testSymmetricToGraph t testSymmetricGraphFamilies t testSymmetricTransformations t + testInduceJust tPoly diff --git a/test/Algebra/Graph/Test/RewriteRules.hs b/test/Algebra/Graph/Test/RewriteRules.hs --- a/test/Algebra/Graph/Test/RewriteRules.hs +++ b/test/Algebra/Graph/Test/RewriteRules.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, RankNTypes #-} + ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.RewriteRules @@ -13,114 +14,352 @@ import Data.Maybe (fromMaybe) +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Data.Set as Set + import Algebra.Graph hiding ((===)) import Algebra.Graph.Internal +import GHC.Base (build) + import Test.Inspection --- Naming convention: we use the suffix "R" to indicate the desired outcome of --- rewrite rules, and suffices "1", "2", etc. to indicate initial expressions. +type Build a = forall b. (a -> b -> b) -> b -> b +type Buildg a = forall b. b -> (a -> b) -> (b -> b ->b ) -> (b -> b-> b) -> b --- Testsuite for 'overlays' and 'connects'. -vertices1, verticesR :: [a] -> Graph a -vertices1 = overlays . map vertex -verticesR = fromMaybe Empty . foldr (maybeF Overlay . Vertex) Nothing +-- Naming convention +--- We use: +--- * the suffix "R" to indicate the desired outcome of rewrite rules. +--- * the suffix "C" when testing the "good consumer" property. +--- * the suffix "P" when testing the "good producer" property. +--- * the suffix "I" when testing inlining. +--- * the suffix "T" when testing specialisation for a type -inspect $ 'vertices1 === 'verticesR +-- 'foldg' +emptyI, emptyIR :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b +emptyI e v o c = foldg e v o c Empty +emptyIR e _ _ _ = e -clique1, cliqueR :: [a] -> Graph a -clique1 = connects . map vertex -cliqueR = fromMaybe Empty . foldr (maybeF Connect . Vertex) Nothing +inspect $ 'emptyI === 'emptyIR -inspect $ 'clique1 === 'cliqueR +vertexI, vertexIR :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> a -> b +vertexI e v o c x = foldg e v o c (Vertex x) +vertexIR _ v _ _ x = v x --- Testsuite for 'transpose'. -empty1, emptyR :: Graph a -empty1 = transpose Empty -emptyR = Empty +inspect $ 'vertexI === 'vertexIR -inspect $ 'empty1 === 'emptyR +overlayI, overlayIR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> Graph a -> b +overlayI e v o c x y = foldg e v o c (Overlay x y) +overlayIR e v o c x y = o (foldg e v o c x) (foldg e v o c y) -vertex1, vertexR :: a -> Graph a -vertex1 = transpose . vertex -vertexR = Vertex +inspect $ 'overlayI === 'overlayIR -inspect $ 'vertex1 === 'vertexR +connectI, connectIR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> Graph a -> b +connectI e v o c x y = foldg e v o c (Connect x y) +connectIR e v o c x y = c (foldg e v o c x) (foldg e v o c y) -overlay1, overlayR :: Graph a -> Graph a -> Graph a -overlay1 x y = transpose (Overlay x y) -overlayR x y = Overlay (transpose x) (transpose y) +inspect $ 'connectI === 'connectIR -inspect $ 'overlay1 === 'overlayR +-- overlays +overlaysC :: Build (Graph a) -> Graph a +overlaysC xs = overlays (build xs) -connect1, connectR :: Graph a -> Graph a -> Graph a -connect1 x y = transpose (Connect x y) -connectR x y = Connect (transpose y) (transpose x) +inspect $ 'overlaysC `hasNoType` ''[] -inspect $ 'connect1 === 'connectR +overlaysP, overlaysPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [Graph a] -> b +overlaysP e v o c xs = foldg e v o c (overlays xs) +overlaysPR e v o c xs = fromMaybe e (foldr (maybeF o . foldg e v o c) Nothing xs) -overlays1, overlaysR :: [Graph a] -> Graph a -overlays1 = transpose . overlays -overlaysR = overlays . map transpose +inspect $ 'overlaysP === 'overlaysPR -inspect $ 'overlays1 === 'overlaysR +-- vertices +verticesCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> b +verticesCP e v o c xs = foldg e v o c (vertices (build xs)) -connects1, connectsR :: [Graph a] -> Graph a -connects1 = transpose . connects -connectsR = fromMaybe Empty . foldr (maybeF (flip Connect) . transpose) Nothing +inspect $ 'verticesCP `hasNoType` ''[] +inspect $ 'verticesCP `hasNoType` ''Graph -inspect $ 'connects1 === 'connectsR +-- connects +connectsC :: Build (Graph a) -> Graph a +connectsC xs = connects (build xs) -vertices2 :: [a] -> Graph a -vertices2 = transpose . overlays . map vertex +inspect $ 'connectsC `hasNoType` ''[] -inspect $ 'vertices2 === 'vertices1 +connectsP, connectsPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [Graph a] -> b +connectsP e v o c xs = foldg e v o c (connects xs) +connectsPR e v o c xs = fromMaybe e (foldr (maybeF c . foldg e v o c) Nothing xs) --- Note that we currently have these three tests: --- * vertices2 === vertices1 --- * vertices1 === verticesR --- * vertices2 =/= verticesR --- This non-transitivity is awkward, and feels like a bug in the inspection --- testing library. See https://github.com/nomeata/inspection-testing/issues/23. -inspect $ 'vertices2 =/= 'verticesR +inspect $ 'connectsP === 'connectsPR -cliqueT1, cliqueTR :: [a] -> Graph a -cliqueT1 = transpose . connects . map vertex -cliqueTR = fromMaybe Empty . foldr (maybeF (flip Connect) . Vertex) Nothing +-- isSubgraphOf +isSubgraphOfC :: Ord a => Buildg a -> Buildg a -> Bool +isSubgraphOfC x y = isSubgraphOf (buildg x) (buildg y) -inspect $ 'cliqueT1 === 'cliqueTR +inspect $ 'isSubgraphOfC `hasNoType` ''Graph -starT1, starTR :: a -> [a] -> Graph a -starT1 x = transpose . star x -starTR a [] = vertex a -starTR a xs = connect (vertices xs) (vertex a) +-- clique +cliqueCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> b +cliqueCP e v o c xs = foldg e v o c (clique (build xs)) -inspect $ 'starT1 === 'starTR +inspect $ 'cliqueCP `hasNoType` ''[] +inspect $ 'cliqueCP `hasNoType` ''Graph -fmapFmap1, fmapFmapR :: Graph a -> (a -> b) -> (b -> c) -> Graph c -fmapFmap1 g f h = fmap h (fmap f g) -fmapFmapR g f h = fmap (h . f) g +-- edges +edgesCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build (a,a) -> b +edgesCP e v o c xs = foldg e v o c (edges (build xs)) -inspect $ 'fmapFmap1 === 'fmapFmapR +inspect $ 'edgesCP `hasNoType` ''[] +inspect $ 'edgesCP `hasNoType` ''Graph -bind2, bind2R :: (a -> Graph b) -> (b -> Graph c) -> Graph a -> Graph c -bind2 f g x = x >>= f >>= g -bind2R f g x = x >>= (\x -> f x >>= g) +-- star +starCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> a -> Build a -> b +starCP e v o c x xs = foldg e v o c (star x (build xs)) -inspect $ 'bind2 === 'bind2R +inspect $ 'starCP `hasNoType` ''[] +inspect $ 'starCP `hasNoType` ''Graph --- Ideally, we want this test to pass. --- Strangely, '<*>' in 'ovApR' does not inline and makes the test fail. --- --- This is corrected below, where '<*>' was inlined "by hand" -ovAp, ovApR :: Graph (a -> b) -> Graph (a -> b) -> Graph a -> Graph b -ovAp x y z = overlay x y <*> z -ovApR x y z = overlay (x <*> z) (y <*> z) +-- fmap +fmapCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> a) -> Buildg c -> b +fmapCP e v o c f g = foldg e v o c (fmap f (buildg g)) -inspect $ 'ovAp =/= 'ovApR +inspect $ 'fmapCP `hasNoType` ''Graph -ovAp', ovApR' :: Graph (a -> b) -> Graph (a -> b) -> Graph a -> Graph b -ovAp' x y z = overlay x y <*> z -ovApR' x y z = overlay (x >>= (<$> z)) (y >>= (<$> z)) +-- bind +bindC, bindCR :: (a -> Graph b) -> Buildg a -> Graph b +bindC f g = (buildg g) >>= f +bindCR f g = g Empty (\x -> f x) Overlay Connect -inspect $ 'ovAp' === 'ovApR' +inspect $ 'bindC === 'bindCR + +bindP, bindPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> Graph a) -> Graph c -> b +bindP e v o c f g = foldg e v o c (g >>= f) +bindPR e v o c f g = foldg e (foldg e v o c . f) o c g + +inspect $ 'bindP === 'bindPR + +-- ap +apC, apCR :: Buildg (a -> b) -> Graph a -> Graph b +apC f x = buildg f <*> x +apCR f x = f Empty (\v -> foldg Empty (Vertex . v) Overlay Connect x) Overlay Connect + +inspect $ 'apC === 'apCR + +apP, apPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph (c -> a) -> Graph c -> b +apP e v o c f x = foldg e v o c (f <*> x) +apPR e v o c f x = + foldg e (\w -> foldg e (v . w) o c x) o c f + +inspect $ 'apP === 'apPR + +-- eq +eqC :: Ord a => Buildg a -> Buildg a -> Bool +eqC x y = buildg x == buildg y + +inspect $ 'eqC `hasNoType` ''Graph + +eqT :: Graph Int -> Graph Int -> Bool +eqT x y = x == y + +inspect $ 'eqT `hasNoType` ''AM.AdjacencyMap + +-- ord +ordC :: Ord a => Buildg a -> Buildg a -> Ordering +ordC x y = compare (buildg x) (buildg y) + +inspect $ 'ordC `hasNoType` ''Graph + +ordT :: Graph Int -> Graph Int -> Ordering +ordT x y = compare x y + +inspect $ 'ordT `hasNoType` ''AM.AdjacencyMap + +-- isEmpty +isEmptyC :: Buildg a -> Bool +isEmptyC g = isEmpty (buildg g) + +inspect $ 'isEmptyC `hasNoType` ''Graph + +-- size +sizeC :: Buildg a -> Int +sizeC g = size (buildg g) + +inspect $ 'sizeC `hasNoType` ''Graph + +-- vertexSet +vertexSetC :: Ord a => Buildg a -> Set.Set a +vertexSetC g = vertexSet (buildg g) + +inspect $ 'vertexSetC `hasNoType` ''Graph + +-- vertexCount +vertexCountC :: Ord a => Buildg a -> Int +vertexCountC g = vertexCount (buildg g) + +inspect $ 'vertexSetC `hasNoType` ''Graph + +vertexCountT :: Graph Int -> Int +vertexCountT g = vertexCount g + +inspect $ 'vertexCountT `hasNoType` ''Set.Set + +-- edgeCount +edgeCountC :: Ord a => Buildg a -> Int +edgeCountC g = edgeCount (buildg g) + +inspect $ 'edgeCountC `hasNoType` ''Graph + +edgeCountT :: Graph Int -> Int +edgeCountT g = edgeCount g + +inspect $ 'edgeCountT `hasNoType` ''Set.Set + +-- vertexList +vertexListCP :: Ord a => (a -> b -> b) -> b -> Buildg a -> b +vertexListCP k c g = foldr k c (vertexList (buildg g)) + +inspect $ 'vertexListCP `hasNoType` ''Graph +inspect $ 'vertexListCP `hasNoType` ''[] + +vertexListT :: Graph Int -> [Int] +vertexListT g = vertexList g + +inspect $ 'vertexListT `hasNoType` ''Set.Set + +-- edgeSet +edgeSetC :: Ord a => Buildg a -> Set.Set (a,a) +edgeSetC g = edgeSet (buildg g) + +inspect $ 'edgeSetC `hasNoType` ''Graph + +edgeSetT :: Graph Int -> Set.Set (Int,Int) +edgeSetT g = edgeSet g + +inspect $ 'vertexListT `hasNoType` ''AM.AdjacencyMap + +-- edgeList +edgeListCP :: Ord a => ((a,a) -> b -> b) -> b -> Buildg a -> b +edgeListCP k c g = foldr k c (edgeList (buildg g)) + +inspect $ 'edgeListCP `hasNoType` ''Graph +inspect $ 'edgeListCP `hasNoType` ''[] + +edgeListT :: Graph Int -> [(Int,Int)] +edgeListT g = edgeList g + +inspect $ 'edgeListT `hasNoType` ''AM.AdjacencyMap + +-- hasVertex +hasVertexC :: Eq a => a -> Buildg a -> Bool +hasVertexC x g = hasVertex x (buildg g) + +inspect $ 'hasVertexC `hasNoType` ''Graph + +-- hasEdge +hasEdgeC :: Eq a => a -> a -> Buildg a -> Bool +hasEdgeC x y g = hasEdge x y (buildg g) + +inspect $ 'hasEdgeC `hasNoType` ''Graph + +-- adjacencyList +adjacencyListC :: Ord a => Buildg a -> [(a, [a])] +adjacencyListC g = adjacencyList (buildg g) + +inspect $ 'adjacencyListC `hasNoType` ''Graph + +-- path +pathP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [a] -> b +pathP e v o c xs = foldg e v o c (path xs) + +inspect $ 'pathP `hasNoType` ''Graph + +-- circuit +circuitP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [a] -> b +circuitP e v o c xs = foldg e v o c (circuit xs) + +inspect $ 'circuitP `hasNoType` ''Graph + +-- biclique +bicliqueCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> Build a -> b +bicliqueCP e v o c xs ys = foldg e v o c (biclique (build xs) (build ys)) + +inspect $ 'bicliqueCP `hasNoType` ''[] +inspect $ 'bicliqueCP `hasNoType` ''Graph + +-- replaceVertex +replaceVertexCP :: Eq a => a -> a -> + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +replaceVertexCP u v e v' o c g = + foldg e v' o c (replaceVertex u v (buildg g)) + +inspect $ 'replaceVertexCP `hasNoType` ''Graph + +-- mergeVertices +mergeVerticesCP :: (a -> Bool) -> a -> + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +mergeVerticesCP p v e v' o c g = + foldg e v' o c (mergeVertices p v (buildg g)) + +inspect $ 'mergeVerticesCP `hasNoType` ''Graph + +-- splitVertex +splitVertexCP :: Eq a => a -> Build a -> + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +splitVertexCP x us e v o c g = foldg e v o c (splitVertex x (build us) (buildg g)) + +inspect $ 'splitVertexCP `hasNoType` ''[] +inspect $ 'splitVertexCP `hasNoType` ''Graph + +-- transpose +transposeCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +transposeCP e v o c g = foldg e v o c (transpose (buildg g)) + +inspect $ 'transposeCP `hasNoType` ''Graph + +-- simplify +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 + +simplifyC, simplifyCR :: Ord a => Buildg a -> Graph a +simplifyC g = simplify (buildg g) +simplifyCR g = g Empty Vertex (simple Overlay) (simple Connect) + +inspect $ 'simplifyC === 'simplifyCR + +-- compose +composeCP :: Ord a => b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> Buildg a -> b +composeCP e v o c x y = foldg e v o c $ compose (buildg x) (buildg y) + +inspect $ 'composeCP `hasNoType` ''Graph + +-- induce +induceCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (a -> Bool) -> Buildg a -> b +induceCP e v o c p g = foldg e v o c (induce p (buildg g)) + +inspect $ 'induceCP `hasNoType` ''Graph + +-- induceJust +induceJustCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg (Maybe a) -> b +induceJustCP e v o c g = foldg e v o c (induceJust (buildg g)) + +inspect $ 'induceJustCP `hasNoType` ''Graph + +-- context +contextC :: (a -> Bool) -> Buildg a -> Maybe (Context a) +contextC p g = context p (buildg g) + +inspect $ 'contextC `hasNoType` ''Graph diff --git a/test/Algebra/Graph/Test/Undirected.hs b/test/Algebra/Graph/Test/Undirected.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Undirected.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Undirected +-- Copyright : (c) Andrey Mokhov 2016-2020 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Undirected". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Undirected ( + -- * Testsuite + testUndirected + ) where + +import Algebra.Graph.Undirected +import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, undirectedGraphAPI) +import Algebra.Graph.Test.Generic + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Undirected as U + +tPoly :: Testsuite Graph Ord +tPoly = ("Graph.Undirected.", undirectedGraphAPI) + +t :: TestsuiteInt Graph +t = fmap toIntAPI tPoly + +type G = Graph Int +type UGI = U.Graph Int +type AGI = G.Graph Int + +testUndirected :: IO () +testUndirected = do + putStrLn "\n============ Graph.Undirected ============" + test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @ G + + testSymmetricShow t + + putStrLn $ "\n============ Graph.Undirected.toUndirected ============" + test "toUndirected (edge 1 2) == edge 1 2" $ + toUndirected (G.edge 1 2) == edge 1 (2 :: Int) + + test "toUndirected . fromUndirected == id" $ \(x :: G) -> + (toUndirected . fromUndirected) x == id x + + test "vertexCount . toUndirected == vertexCount" $ \(x :: AGI) -> + vertexCount (toUndirected x) == G.vertexCount x + + test "(*2) . edgeCount . toUndirected >= edgeCount" $ \(x :: AGI) -> + ((*2) . edgeCount . toUndirected) x >= G.edgeCount x + + putStrLn $ "\n============ Graph.Undirected.fromUndirected ============" + test "fromUndirected (edge 1 2) == edges [(1,2),(2,1)]" $ + fromUndirected (edge 1 2) == G.edges [(1,2), (2,1 :: Int)] + + test "toUndirected . fromUndirected == id" $ \(x :: G) -> + (toUndirected . fromUndirected) x == id x + + test "vertexCount . fromUndirected == vertexCount" $ \(x :: G) -> + (G.vertexCount . fromUndirected) x == vertexCount x + + test "edgeCount . fromUndirected <= (*2) . edgeCount" $ \(x :: G) -> + (G.edgeCount . fromUndirected) x <= ((*2) . edgeCount) x + + putStrLn $ "\n============ Graph.Undirected.complement ================" + test "complement empty == empty" $ + complement (empty :: UGI) == empty + + test "complement (vertex x) == vertex x" $ \x -> + complement (vertex x :: UGI) == vertex x + + test "complement (edge 1 1) == edge 1 1" $ + complement (edge 1 1) == edge 1 (1 :: Int) + + test "complement (edge 1 2) == vertices [1, 2]" $ + complement (edge 1 2 :: UGI) == vertices [1, 2] + + test "complement (star 1 [2, 3]) == overlay (vertex 1) (edge 2 3)" $ + complement (star 1 [2, 3]) == overlay (vertex 1) (edge 2 3 :: UGI) + + test "complement . complement == id" $ \(x :: UGI) -> + (complement . complement $ x) == x + + testSymmetricBasicPrimitives t + testSymmetricIsSubgraphOf t + testSymmetricGraphFamilies t + testSymmetricTransformations t + testInduceJust tPoly diff --git a/test/Data/Graph/Test/Typed.hs b/test/Data/Graph/Test/Typed.hs --- a/test/Data/Graph/Test/Typed.hs +++ b/test/Data/Graph/Test/Typed.hs @@ -11,7 +11,7 @@ module Data.Graph.Test.Typed ( -- * Testsuite testTyped - ) where + ) where import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.AdjacencyIntMap as AIM @@ -26,6 +26,7 @@ type AI = AM.AdjacencyMap Int +-- TODO: Improve the alignment in the testsuite to match the documentation. (%) :: (GraphKL Int -> a) -> AM.AdjacencyMap Int -> a a % g = a $ fromAdjacencyMap g @@ -149,8 +150,8 @@ test "dfs [] % x == []" $ \x -> dfs [] % x == [] - test "dfs [1, 4] % 3 * (1 + 4) * (1 + 5) == [1, 5, 4]" $ - dfs [1, 4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] + test "dfs [1, 4] % 3 * (1 + 4) * (1 + 5) == [1,5,4]" $ + dfs [1, 4] % (3 * (1 + 4) * (1 + 5)) == [1,5,4] test "isSubgraphOf (vertices $ dfs vs % x) x == True" $ \vs x -> AM.isSubgraphOf (AM.vertices $ dfs vs % x) x == True diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,15 +1,18 @@ +import Algebra.Graph.Test.Acyclic.AdjacencyMap import Algebra.Graph.Test.AdjacencyIntMap import Algebra.Graph.Test.AdjacencyMap -import Algebra.Graph.Test.NonEmpty.AdjacencyMap +import Algebra.Graph.Test.Bipartite.Undirected.AdjacencyMap import Algebra.Graph.Test.Export -import Algebra.Graph.Test.Fold import Algebra.Graph.Test.Graph -import Algebra.Graph.Test.NonEmpty.Graph import Algebra.Graph.Test.Internal +import Algebra.Graph.Test.Label import Algebra.Graph.Test.Labelled.AdjacencyMap import Algebra.Graph.Test.Labelled.Graph +import Algebra.Graph.Test.NonEmpty.AdjacencyMap +import Algebra.Graph.Test.NonEmpty.Graph import Algebra.Graph.Test.Relation import Algebra.Graph.Test.Relation.SymmetricRelation +import Algebra.Graph.Test.Undirected import Data.Graph.Test.Typed import Control.Monad @@ -19,23 +22,26 @@ -- you would like to execute only some specific testsuites, you can specify -- their names in the command line. For example: -- --- stack test --test-arguments "Graph SymmetricRelation" +-- > stack test --test-arguments "Graph Symmetric.Relation" -- -- will test the modules "Algebra.Graph" and "Algebra.Graph.Symmetric.Relation". main :: IO () main = do selected <- getArgs let go current = when (null selected || current `elem` selected) - go "AdjacencyIntMap" testAdjacencyIntMap - go "AdjacencyMap" testAdjacencyMap - go "Export" testExport - go "Fold" testFold - go "Graph" testGraph - go "Internal" testInternal - go "LabelledAdjacencyMap" testLabelledAdjacencyMap - go "LabelledGraph" testLabelledGraph - go "NonEmptyAdjacencyMap" testNonEmptyAdjacencyMap - go "NonEmptyGraph" testNonEmptyGraph - go "Relation" testRelation - go "SymmetricRelation" testSymmetricRelation - go "Typed" testTyped + go "Acyclic.AdjacencyMap" testAcyclicAdjacencyMap + go "AdjacencyIntMap" testAdjacencyIntMap + go "AdjacencyMap" testAdjacencyMap + go "Bipartite.Undirected.AdjacencyMap" testBipartiteUndirectedAdjacencyMap + go "Export" testExport + go "Graph" testGraph + go "Internal" testInternal + go "Label" testLabel + go "Labelled.AdjacencyMap" testLabelledAdjacencyMap + go "Labelled.Graph" testLabelledGraph + go "NonEmpty.AdjacencyMap" testNonEmptyAdjacencyMap + go "NonEmpty.Graph" testNonEmptyGraph + go "Relation" testRelation + go "Symmetric.Relation" testSymmetricRelation + go "Typed" testTyped + go "Undirected" testUndirected