diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,15 @@ # Change log +## 0.8 + +* #305, #312: Support GHC 9.4, GHC 9.6 and GHC 9.8. +* #303, #314: Stop supporting GHC 8.4, GHC 8.6 and GHC 8.8. + +## 0.7 + +* #294: Change the argument order of `bfs*`, `dfs*` and `reachable` algorithms. +* #293: Fix the `ToGraph` instance of symmetric relations. + ## 0.6.1 * Drop dependency on `mtl`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2016-2022 Andrey Mokhov +Copyright (c) 2016-2025 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Algebraic graphs -[![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Build status](https://img.shields.io/github/workflow/status/snowleopard/alga/ci/master.svg)](https://github.com/snowleopard/alga/actions) +[![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Build status](https://img.shields.io/github/actions/workflow/status/snowleopard/alga/ci.yml?branch=master)](https://github.com/snowleopard/alga/actions) **Alga** is a library for algebraic construction and manipulation of graphs in Haskell. See [this Haskell Symposium paper](https://github.com/snowleopard/alga-paper) and the diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -1,18 +1,18 @@ cabal-version: 2.2 name: algebraic-graphs -version: 0.6.1 +version: 0.8 synopsis: A library for algebraic graph construction and transformation license: MIT license-file: LICENSE author: Andrey Mokhov , github: @snowleopard maintainer: Andrey Mokhov , github: @snowleopard, Alexandre Moine , github: @nobrakal -copyright: Andrey Mokhov, 2016-2022 +copyright: Andrey Mokhov, 2016-2025 homepage: https://github.com/snowleopard/alga bug-reports: https://github.com/snowleopard/alga/issues category: Algebra, Algorithms, Data Structures, Graphs build-type: Simple -tested-with: GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6, GHC==8.4 +tested-with: GHC==9.8.2, GHC==9.6.3, GHC==9.4.7, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7 description: is a library for algebraic construction and manipulation of graphs in Haskell. See @@ -68,10 +68,10 @@ common common-settings build-depends: array >= 0.4 && < 0.6, - base >= 4.11 && < 5, - containers >= 0.5.5.1 && < 0.8, - deepseq >= 1.3.0.1 && < 1.5, - transformers >= 0.4 && < 0.6 + base >= 4.12 && < 5, + containers >= 0.5.5.1 && < 0.9, + deepseq >= 1.3.0.1 && < 1.6, + transformers >= 0.4 && < 0.7 default-language: Haskell2010 default-extensions: ConstraintKinds DeriveFunctor @@ -86,6 +86,7 @@ TupleSections TypeApplications TypeFamilies + TypeOperators other-extensions: CPP OverloadedStrings RecordWildCards @@ -132,7 +133,7 @@ Algebra.Graph.ToGraph, Data.Graph.Typed -test-suite test-alga +test-suite main import: common-settings hs-source-dirs: test type: exitcode-stdio-1.0 @@ -161,7 +162,7 @@ Data.Graph.Test.Typed build-depends: algebraic-graphs, extra >= 1.4 && < 2, - inspection-testing >= 0.4.6.0 && < 0.5, - QuickCheck >= 2.14 && < 2.15 + inspection-testing >= 0.4.2.2 && < 0.7, + QuickCheck >= 2.14 && < 2.16 other-extensions: ConstrainedClassMethods TemplateHaskell diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -56,7 +56,7 @@ import Data.Foldable (toList) import Data.Maybe (fromMaybe) import Data.String -import Data.Tree +import Data.Tree (Tree (..)) import GHC.Generics import Algebra.Graph.Internal @@ -1291,15 +1291,15 @@ -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the -- original vertices (wrapping the latter in 'Right') such that the resulting --- graph is /sparse/, i.e. contains only O(s) edges, but preserves the +-- graph is /sparse/, i.e. contains only /O(s)/ edges, but preserves the -- reachability relation between the original vertices. Sparsification is useful -- when working with dense graphs, as it can reduce the number of edges from --- O(n^2) down to O(n) by replacing cliques, bicliques and similar densely +-- /O(n^2)/ down to /O(n)/ by replacing cliques, bicliques and similar densely -- connected structures by sparse subgraphs built out of intermediate vertices. --- Complexity: O(s) time, memory and size. +-- Complexity: /O(s)/ time, memory and size. -- -- @ --- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' ('Data.Either.Right' x) . sparsify +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' (sparsify x) . 'Data.Either.Right' -- 'vertexCount' (sparsify x) <= 'vertexCount' x + 'size' x + 1 -- 'edgeCount' (sparsify x) <= 3 * 'size' x -- 'size' (sparsify x) <= 3 * 'size' x @@ -1329,7 +1329,7 @@ -- contain a quadratic /O(s^2)/ number of edges. -- -- @ --- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' k == 'Data.List.sort' . 'filter' (<= n) . 'flip' 'Data.Graph.reachable' k . sparsifyKL n +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'filter' (<= n) . 'Data.Graph.reachable' (sparsifyKL n x) -- 'length' ('Data.Graph.vertices' $ sparsifyKL n x) <= 'vertexCount' x + 'size' x + 1 -- 'length' ('Data.Graph.edges' $ sparsifyKL n x) <= 3 * 'size' x -- @ diff --git a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs --- a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs +++ b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Acyclic.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyIntMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -51,7 +51,7 @@ import Data.List ((\\)) import Data.Monoid (Sum (..)) import Data.Set (Set) -import Data.Tree +import Data.Tree (Forest, Tree (..)) import GHC.Generics import qualified Data.IntMap.Strict as IntMap @@ -814,7 +814,7 @@ -- closure == 'reflexiveClosure' . 'transitiveClosure' -- closure == 'transitiveClosure' . 'reflexiveClosure' -- closure . closure == closure --- 'postIntSet' x (closure y) == IntSet.'IntSet.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- 'postIntSet' x (closure y) == IntSet.'IntSet.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ closure :: AdjacencyIntMap -> AdjacencyIntMap closure = reflexiveClosure . transitiveClosure 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyIntMap.Algorithm --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable @@ -44,82 +44,98 @@ import qualified Data.IntSet as IntSet -- | Compute the /breadth-first search/ forest of a graph, such that adjacent --- vertices are explored in increasing order according to their 'Ord' instance. --- The search is seeded by a list of vertices that will become the roots of the --- resulting forest. Duplicates in the list will have their first occurrence --- expanded and subsequent ones ignored. The seed vertices that do not belong to --- the graph are also ignored. +-- vertices are explored in the increasing order. The search is seeded by a list +-- of vertices that will become the roots of the resulting forest. Duplicates in +-- the list will have their first occurrence explored and subsequent ones +-- ignored. The seed vertices that do not belong to the graph are also ignored. -- --- Complexity: /O((L+m)*log n)/ time and /O(n)/ space, where /L/ is the number --- of seed vertices. +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. -- -- @ --- '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 +-- 'forest' $ bfsForest ('edge' 1 2) [0] == 'empty' +-- 'forest' $ bfsForest ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ bfsForest ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ bfsForest ('edge' 1 2) [0,1,2] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 2) [2,1,0] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 1) [1] == 'vertex' 1 +-- 'isSubgraphOf' ('forest' $ bfsForest x vs) x == True +-- bfsForest x ('vertexList' x) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'vertexList' x) +-- bfsForest x [] == [] +-- bfsForest 'empty' vs == [] +-- bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == [ 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] +-- 'forest' $ bfsForest ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == '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 +bfsForest :: AdjacencyIntMap -> [Int] -> Forest Int +bfsForest g vs= evalState (explore [ v | v <- vs, hasVertex v g ]) IntSet.empty + where + explore = filterM discovered >=> unfoldForestM_BF walk + 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 -- | A version of 'bfsForest' where the resulting forest is converted to a level --- structure. Adjacent vertices are explored in the increasing order according --- to their 'Ord' instance. Flattening the result via @'concat'@ @.@ @'bfs'@ @vs@ --- gives an enumeration of vertices reachable from @vs@ in the BFS order. +-- structure. Adjacent vertices are explored in the increasing order. Flattening +-- the result via @'concat'@ @.@ @'bfs'@ @x@ gives an enumeration of reachable +-- vertices in the breadth-first search order. -- --- Complexity: /O((L+m)*min(n,W))/ time and /O(n)/ space, where /L/ is the +-- Complexity: /O((L + m) * min(n,W))/ time and /O(n)/ space, where /L/ is the -- number of seed vertices. -- -- @ --- 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 ('edge' 1 2) [0] == [] +-- bfs ('edge' 1 2) [1] == [[1], [2]] +-- bfs ('edge' 1 2) [2] == [[2]] +-- bfs ('edge' 1 2) [1,2] == [[1,2]] +-- bfs ('edge' 1 2) [2,1] == [[2,1]] +-- bfs ('edge' 1 1) [1] == [[1]] +-- bfs 'empty' vs == [] +-- bfs x [] == [] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]] +-- bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]] +-- +-- bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [[2], [1,3], [5,4]] +-- 'concat' $ bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,4,1,5] +-- 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' x == bfs x -- @ -bfs :: [Int] -> AdjacencyIntMap -> [[Int]] -bfs vs = map concat . List.transpose . map levels . bfsForest vs +bfs :: AdjacencyIntMap -> [Int] -> [[Int]] +bfs g = map concat . List.transpose . map levels . bfsForest g +dfsForestFromImpl :: AdjacencyIntMap -> [Int] -> Forest Int +dfsForestFromImpl g vs = 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 /depth-first search/ forest of a graph, where adjacent vertices --- are explored in the increasing order according to their 'Ord' instance. +-- are explored in the increasing order. -- --- Complexity: /O((n+m)*min(n,W))/ time and /O(n)/ space. +-- 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 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] +-- 'forest' $ dfsForest 'empty' == 'empty' +-- 'forest' $ dfsForest ('edge' 1 1) == 'vertex' 1 +-- 'forest' $ dfsForest ('edge' 1 2) == 'edge' 1 2 +-- 'forest' $ dfsForest ('edge' 2 1) == 'vertices' [1,2] -- 'isSubgraphOf' ('forest' $ dfsForest x) x == True -- 'isDfsForestOf' (dfsForest x) x == True -- dfsForest . 'forest' . dfsForest == dfsForest -- dfsForest ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'dfsForestFrom' ('vertexList' x) x == dfsForest x -- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] }]} @@ -129,92 +145,84 @@ -- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5] -- @ dfsForest :: AdjacencyIntMap -> Forest Int -dfsForest g = dfsForestFrom' (vertexList g) g +dfsForest g = dfsForestFromImpl g (vertexList g) -- | Compute the /depth-first search/ forest of a graph starting from the given --- seed vertices, where adjacent vertices are explored in the increasing order --- according to their 'Ord' instance. Note that the resulting forest does not --- necessarily span the whole graph, as some vertices may be unreachable. The --- seed vertices which do not belong to the graph are ignored. +-- seed vertices, where adjacent vertices are explored in the increasing order. +-- Note that the resulting forest does not necessarily span the whole graph, as +-- some vertices may be unreachable. The seed vertices which do not belong to +-- the graph are ignored. -- --- Complexity: /O((L+m)*log n)/ time and /O(n)/ space, where /L/ be the number --- of seed vertices. +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. -- -- @ --- dfsForestFrom vs 'empty' == [] --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- 'forest' $ dfsForestFrom 'empty' vs == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 1) [1] == 'vertex' 1 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [0] == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1,2] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2,1] == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom x vs) x == True +-- 'isDfsForestOf' (dfsForestFrom x ('vertexList' x)) x == True +-- dfsForestFrom x ('vertexList' x) == 'dfsForest' x +-- dfsForestFrom x [] == [] +-- dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] } -- , Node { rootLabel = 4 -- , subForest = [] }] --- 'forest' (dfsForestFrom [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [3,2,1,5,4] +-- 'forest' $ dfsForestFrom ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1,5,4] -- @ -dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int -dfsForestFrom vs g = dfsForestFrom' [ v | v <- vs, hasVertex v g ] g +dfsForestFrom :: AdjacencyIntMap -> [Int] -> Forest Int +dfsForestFrom g vs = dfsForestFromImpl g [ v | v <- vs, hasVertex v g ] -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 -- | Return the list vertices visited by the /depth-first search/ in a graph, -- starting from the given seed vertices. Adjacent vertices are explored in the --- increasing order according to their 'Ord' instance. +-- increasing order. -- --- Complexity: /O((L+m)*log n)/ time and /O(n)/ space, where /L/ is the number --- of seed vertices. +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. -- -- @ --- dfs vs $ 'empty' == [] --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1,2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1,2] $ 'edge' 1 2 == [1,2] --- dfs [2,1] $ 'edge' 1 2 == [2,1] --- dfs [] $ x == [] --- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] --- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True --- dfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1] == [3,2,1,5,4] +-- dfs 'empty' vs == [] +-- dfs ('edge' 1 1) [1] == [1] +-- dfs ('edge' 1 2) [0] == [] +-- dfs ('edge' 1 2) [1] == [1,2] +-- dfs ('edge' 1 2) [2] == [2] +-- dfs ('edge' 1 2) [1,2] == [1,2] +-- dfs ('edge' 1 2) [2,1] == [2,1] +-- dfs x [] == [] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- dfs x vs ] == True +-- dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4] +-- dfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,1,5,4] -- @ -dfs :: [Int] -> AdjacencyIntMap -> [Int] -dfs vs = dfsForestFrom vs >=> flatten +dfs :: AdjacencyIntMap -> [Int] -> [Int] +dfs x = concatMap flatten . dfsForestFrom x --- | Return 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/. +-- | Return the list of vertices /reachable/ from a source vertex in a graph. +-- The vertices in the resulting list appear in the /depth-first search order/. -- --- Complexity: /O(m*log n)/ time and /O(n)/ space. +-- Complexity: /O(m * log n)/ time and /O(n)/ space. -- -- @ --- reachable x $ 'empty' == [] --- reachable 1 $ 'vertex' 1 == [1] --- reachable 1 $ 'vertex' 2 == [] --- reachable 1 $ 'edge' 1 1 == [1] --- reachable 1 $ 'edge' 1 2 == [1,2] --- reachable 4 $ 'path' [1..8] == [4..8] --- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] --- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] --- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- reachable 'empty' x == [] +-- reachable ('vertex' 1) 1 == [1] +-- reachable ('edge' 1 1) 1 == [1] +-- reachable ('edge' 1 2) 0 == [] +-- reachable ('edge' 1 2) 1 == [1,2] +-- reachable ('edge' 1 2) 2 == [2] +-- reachable ('path' [1..8] ) 4 == [4..8] +-- reachable ('circuit' [1..8] ) 4 == [4..8] ++ [1..3] +-- reachable ('clique' [8,7..1]) 8 == [8] ++ [1..7] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- reachable x y ] == True -- @ -reachable :: Int -> AdjacencyIntMap -> [Int] -reachable x = dfs [x] +reachable :: AdjacencyIntMap -> Int -> [Int] +reachable x y = dfs x [y] type Cycle = NonEmpty type Result = Either (Cycle Int) [Int] @@ -223,8 +231,8 @@ , entry :: IntMap.IntMap NodeState , order :: [Int] } -topSort' :: AdjacencyIntMap -> StateT S (Cont Result) Result -topSort' g = liftCallCC' callCC $ \cyclic -> +topSortImpl :: AdjacencyIntMap -> StateT S (Cont Result) Result +topSortImpl g = liftCallCC' callCC $ \cyclic -> do let vertices = map fst $ IntMap.toDescList $ adjacencyIntMap g adjacent = IntSet.toDescList . flip postIntSet g dfsRoot x = nodeState x >>= \case @@ -262,7 +270,7 @@ -- 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. +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. -- -- @ -- topSort (1 * 2 + 3 * 1) == Right [3,1,2] @@ -272,18 +280,18 @@ -- 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]) +-- topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 ':|' [2]) -- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Right False -- topSort . 'vertices' == Right . 'nub' . 'sort' -- @ topSort :: AdjacencyIntMap -> Either (Cycle Int) [Int] -topSort g = runCont (evalStateT (topSort' g) initialState) id +topSort g = runCont (evalStateT (topSortImpl 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. +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. -- -- @ -- isAcyclic (1 * 2 + 3 * 1) == True 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,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -55,7 +55,7 @@ import Data.Monoid import Data.Set (Set) import Data.String -import Data.Tree +import Data.Tree (Forest, Tree (..)) import GHC.Generics import qualified Data.Map.Strict as Map @@ -853,7 +853,7 @@ -- closure == 'reflexiveClosure' . 'transitiveClosure' -- closure == 'transitiveClosure' . 'reflexiveClosure' -- closure . closure == closure --- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ closure :: Ord a => AdjacencyMap a -> AdjacencyMap a closure = reflexiveClosure . transitiveClosure 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap.Algorithm --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable @@ -33,10 +33,9 @@ import Data.Either import Data.List.NonEmpty (NonEmpty(..), (<|)) import Data.Maybe -import Data.Tree +import Data.Tree (Forest, Tree (..), flatten, levels, unfoldForestM_BF) import Algebra.Graph.AdjacencyMap -import Algebra.Graph.Internal import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty import qualified Data.Array as Array @@ -48,79 +47,96 @@ -- vertices are explored in increasing order according to their 'Ord' instance. -- The search is seeded by a list of vertices that will become the roots of the -- resulting forest. Duplicates in the list will have their first occurrence --- expanded and subsequent ones ignored. The seed vertices that do not belong to +-- explored and subsequent ones ignored. The seed vertices that do not belong to -- the graph are also ignored. -- --- Complexity: /O((L+m)*log n)/ time and /O(n)/ space, where /L/ is the number --- of seed vertices. +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. -- -- @ --- '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 +-- 'forest' $ bfsForest ('edge' 1 2) [0] == 'empty' +-- 'forest' $ bfsForest ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ bfsForest ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ bfsForest ('edge' 1 2) [0,1,2] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 2) [2,1,0] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 1) [1] == 'vertex' 1 +-- 'isSubgraphOf' ('forest' $ bfsForest x vs) x == True +-- bfsForest x ('vertexList' x) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'vertexList' x) +-- bfsForest x [] == [] +-- bfsForest 'empty' vs == [] +-- bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == [ 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] +-- 'forest' $ bfsForest ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == '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 +bfsForest :: Ord a => AdjacencyMap a -> [a] -> Forest a +bfsForest x vs = evalState (explore [ v | v <- vs, hasVertex v x ]) Set.empty + where + explore = filterM discovered >=> unfoldForestM_BF walk + walk v = (v,) <$> adjacentM v + adjacentM v = filterM discovered $ Set.toList (postSet v x) + discovered v = do new <- gets (not . Set.member v) + when new $ modify' (Set.insert v) + return new -- | A version of 'bfsForest' where the resulting forest is converted to a level -- structure. Adjacent vertices are explored in the increasing order according --- to their 'Ord' instance. Flattening the result via @'concat'@ @.@ @'bfs'@ @vs@ --- gives an enumeration of vertices reachable from @vs@ in the BFS order. +-- to their 'Ord' instance. Flattening the result via @'concat'@ @.@ @'bfs'@ @x@ +-- gives an enumeration of reachable vertices in the breadth-first search order. -- --- Complexity: /O((L+m)*min(n,W))/ time and /O(n)/ space, where /L/ is the +-- Complexity: /O((L + m) * min(n,W))/ time and /O(n)/ space, where /L/ is the -- number of seed vertices. -- -- @ --- 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 ('edge' 1 2) [0] == [] +-- bfs ('edge' 1 2) [1] == [[1], [2]] +-- bfs ('edge' 1 2) [2] == [[2]] +-- bfs ('edge' 1 2) [1,2] == [[1,2]] +-- bfs ('edge' 1 2) [2,1] == [[2,1]] +-- bfs ('edge' 1 1) [1] == [[1]] +-- bfs 'empty' vs == [] +-- bfs x [] == [] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]] +-- bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]] +-- +-- bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [[2], [1,3], [5,4]] +-- 'concat' $ bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,4,1,5] +-- 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' x == bfs x -- @ -bfs :: Ord a => [a] -> AdjacencyMap a -> [[a]] -bfs vs = map concat . List.transpose . map levels . bfsForest vs +bfs :: Ord a => AdjacencyMap a -> [a] -> [[a]] +bfs x = map concat . List.transpose . map levels . bfsForest x +dfsForestFromImpl :: Ord a => AdjacencyMap a -> [a] -> Forest a +dfsForestFromImpl g vs = 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 /depth-first search/ forest of a graph, where adjacent vertices -- are explored in the increasing order according to their 'Ord' instance. -- --- Complexity: /O((n+m)*min(n,W))/ time and /O(n)/ space. +-- 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 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] +-- 'forest' $ dfsForest 'empty' == 'empty' +-- 'forest' $ dfsForest ('edge' 1 1) == 'vertex' 1 +-- 'forest' $ dfsForest ('edge' 1 2) == 'edge' 1 2 +-- 'forest' $ dfsForest ('edge' 2 1) == 'vertices' [1,2] -- 'isSubgraphOf' ('forest' $ dfsForest x) x == True -- 'isDfsForestOf' (dfsForest x) x == True -- dfsForest . 'forest' . dfsForest == dfsForest -- dfsForest ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'dfsForestFrom' ('vertexList' x) x == dfsForest x -- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] }]} @@ -130,7 +146,7 @@ -- '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 = dfsForestFromImpl g (vertexList g) -- | Compute the /depth-first search/ forest of a graph starting from the given -- seed vertices, where adjacent vertices are explored in the increasing order @@ -138,84 +154,75 @@ -- necessarily span the whole graph, as some vertices may be unreachable. The -- seed vertices which do not belong to the graph are ignored. -- --- Complexity: /O((L+m)*log n)/ time and /O(n)/ space, where /L/ be the number --- of seed vertices. +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. -- -- @ --- dfsForestFrom vs 'empty' == [] --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- 'forest' $ dfsForestFrom 'empty' vs == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 1) [1] == 'vertex' 1 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [0] == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1,2] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2,1] == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom x vs) x == True +-- 'isDfsForestOf' (dfsForestFrom x ('vertexList' x)) x == True +-- dfsForestFrom x ('vertexList' x) == 'dfsForest' x +-- dfsForestFrom x [] == [] +-- dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] } -- , Node { rootLabel = 4 -- , subForest = [] }] --- 'forest' (dfsForestFrom [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [3,2,1,5,4] +-- 'forest' $ dfsForestFrom ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1,5,4] -- @ -dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a -dfsForestFrom vs g = dfsForestFrom' [ v | v <- vs, hasVertex v g ] g - -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 +dfsForestFrom :: Ord a => AdjacencyMap a -> [a] -> Forest a +dfsForestFrom g vs = dfsForestFromImpl g [ v | v <- vs, hasVertex v g ] -- | Return the list vertices visited by the /depth-first search/ in a graph, -- starting from the given seed vertices. Adjacent vertices are explored in the -- increasing order according to their 'Ord' instance. -- --- Complexity: /O((L+m)*log n)/ time and /O(n)/ space, where /L/ is the number --- of seed vertices. +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. -- -- @ --- dfs vs $ 'empty' == [] --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1,2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1,2] $ 'edge' 1 2 == [1,2] --- dfs [2,1] $ 'edge' 1 2 == [2,1] --- dfs [] $ x == [] --- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] --- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True --- dfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1] == [3,2,1,5,4] +-- dfs 'empty' vs == [] +-- dfs ('edge' 1 1) [1] == [1] +-- dfs ('edge' 1 2) [0] == [] +-- dfs ('edge' 1 2) [1] == [1,2] +-- dfs ('edge' 1 2) [2] == [2] +-- dfs ('edge' 1 2) [1,2] == [1,2] +-- dfs ('edge' 1 2) [2,1] == [2,1] +-- dfs x [] == [] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- dfs x vs ] == True +-- dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4] +-- dfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,1,5,4] -- @ -dfs :: Ord a => [a] -> AdjacencyMap a -> [a] -dfs vs = dfsForestFrom vs >=> flatten +dfs :: Ord a => AdjacencyMap a -> [a] -> [a] +dfs x = concatMap flatten . dfsForestFrom x --- | Return 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/. +-- | Return the list of vertices /reachable/ from a source vertex in a graph. +-- The vertices in the resulting list appear in the /depth-first search order/. -- --- Complexity: /O(m*log n)/ time and /O(n)/ space. +-- Complexity: /O(m * log n)/ time and /O(n)/ space. -- -- @ --- reachable x $ 'empty' == [] --- reachable 1 $ 'vertex' 1 == [1] --- reachable 1 $ 'vertex' 2 == [] --- reachable 1 $ 'edge' 1 1 == [1] --- reachable 1 $ 'edge' 1 2 == [1,2] --- reachable 4 $ 'path' [1..8] == [4..8] --- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] --- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] --- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- reachable 'empty' x == [] +-- reachable ('vertex' 1) 1 == [1] +-- reachable ('edge' 1 1) 1 == [1] +-- reachable ('edge' 1 2) 0 == [] +-- reachable ('edge' 1 2) 1 == [1,2] +-- reachable ('edge' 1 2) 2 == [2] +-- reachable ('path' [1..8] ) 4 == [4..8] +-- reachable ('circuit' [1..8] ) 4 == [4..8] ++ [1..3] +-- reachable ('clique' [8,7..1]) 8 == [8] ++ [1..7] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- reachable x y ] == True -- @ -reachable :: Ord a => a -> AdjacencyMap a -> [a] -reachable x = dfs [x] +reachable :: Ord a => AdjacencyMap a -> a -> [a] +reachable x y = dfs x [y] type Cycle = NonEmpty type Result a = Either (Cycle a) [a] @@ -224,8 +231,8 @@ , entry :: Map.Map a NodeState , order :: [a] } -topSort' :: Ord a => AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a) -topSort' g = liftCallCC' callCC $ \cyclic -> +topSortImpl :: Ord a => AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a) +topSortImpl g = liftCallCC' callCC $ \cyclic -> do let vertices = map fst $ Map.toDescList $ adjacencyMap g adjacent = Set.toDescList . flip postSet g dfsRoot x = nodeState x >>= \case @@ -263,7 +270,7 @@ -- 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. +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. -- -- @ -- topSort (1 * 2 + 3 * 1) == Right [3,1,2] @@ -273,13 +280,13 @@ -- 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]) +-- topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 ':|' [2]) -- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Right False -- 'isRight' . topSort == 'isAcyclic' -- topSort . 'vertices' == Right . 'nub' . 'sort' -- @ topSort :: Ord a => AdjacencyMap a -> Either (Cycle a) [a] -topSort g = runCont (evalStateT (topSort' g) initialState) id +topSort g = runCont (evalStateT (topSortImpl g) initialState) id where initialState = S Map.empty Map.empty [] @@ -373,23 +380,25 @@ -- 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 + exit v = do boundaryStack <- gets boundaryStack + case boundaryStack of + (p_top, top) : newBoundaryStack | v == top -> do + insertComponent p_top top newBoundaryStack + return True - insertComponent v = modify' - (\(SCC pre scc bnd pth pres sccs gs es_i es_o) -> + _ -> return False + + insertComponent p_v v newBoundaryStack = modify' + (\(SCC pre scc _oldBoundaryStack 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 + pth' = drop 1 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) + in SCC pre scc' newBoundaryStack pth' pres sccs' gs' es_i' es_o) inedge uv = modify' (\(SCC pre scc bnd pth pres sccs gs es_i es_o) -> diff --git a/src/Algebra/Graph/Bipartite/AdjacencyMap.hs b/src/Algebra/Graph/Bipartite/AdjacencyMap.hs --- a/src/Algebra/Graph/Bipartite/AdjacencyMap.hs +++ b/src/Algebra/Graph/Bipartite/AdjacencyMap.hs @@ -1,7 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Bipartite.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -53,19 +53,13 @@ consistent ) where -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State import Data.Either -import Data.Foldable (asum) import Data.List ((\\), sort) import Data.Map.Strict (Map) -import Data.Maybe import Data.Set (Set) import GHC.Exts (IsList(..)) import GHC.Generics -import qualified Algebra.Graph as G import qualified Algebra.Graph.AdjacencyMap as AM import qualified Data.Map.Strict as Map diff --git a/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs --- a/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs +++ b/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs @@ -2,7 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Bipartite.AdjacencyMap.Algorithm --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Class --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -46,7 +46,7 @@ path, circuit, clique, biclique, star, tree, forest ) where -import Data.Tree +import Data.Tree (Forest, Tree (..)) import Algebra.Graph.Label (Dioid, one) diff --git a/src/Algebra/Graph/Example/Todo.hs b/src/Algebra/Graph/Example/Todo.hs --- a/src/Algebra/Graph/Example/Todo.hs +++ b/src/Algebra/Graph/Example/Todo.hs @@ -1,6 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -module Algebra.Graph.Example.Todo (Todo, todo, low, high, (~*~), (>*<), priority) where +module Algebra.Graph.Example.Todo ( + -- * Creating and manipulating to-do lists + Todo, todo, low, high, (~*~), (>*<), priority, + -- * Examples + shopping, holiday + ) where + +-- Based on https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ + import Data.Map (Map) import Data.String @@ -13,10 +21,10 @@ data Todo a = T (Map a Int) (AdjacencyMap a) deriving Show instance Ord a => Eq (Todo a) where - x == y = todo x == todo y + x == y = todo x == todo y instance (IsString a, Ord a) => IsString (Todo a) where - fromString = C.vertex . fromString + fromString = C.vertex . fromString -- Lower the priority of items in a given todo list low :: Todo a -> Todo a @@ -39,8 +47,7 @@ x >*< y = high x `C.connect` low y todo :: forall a. Ord a => Todo a -> Maybe [a] -todo (T p g) = - case AM.topSort $ gmap prioritise g of +todo (T p g) = case AM.topSort $ gmap prioritise g of Left _ -> Nothing Right xs -> Just $ map snd xs where @@ -48,16 +55,26 @@ prioritise x = (negate $ Map.findWithDefault 0 x p, x) instance (IsString a, Ord a) => Num (Todo a) where - fromInteger i = fromString $ show (fromInteger i :: Integer) - (+) = C.overlay - (*) = C.connect - signum = const C.empty - abs = id - negate = id + fromInteger i = fromString $ show (fromInteger i :: Integer) + (+) = C.overlay + (*) = C.connect + signum = const C.empty + abs = id + negate = id instance Ord a => Graph (Todo a) where - type Vertex (Todo a) = a - empty = T Map.empty AM.empty - vertex x = T (Map.singleton x 0) (C.vertex x) - overlay (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.overlay g1 g2) - connect (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.connect g1 g2) + type Vertex (Todo a) = a + empty = T Map.empty AM.empty + vertex x = T (Map.singleton x 0) (C.vertex x) + overlay (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.overlay g1 g2) + connect (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.connect g1 g2) + +-- λ> todo shopping +-- Just ["coat","presents","phone wife","scarf"] +shopping :: Todo String +shopping = "presents" + "coat" + "phone wife" ~*~ "scarf" + +-- λ> todo holiday +-- Just ["coat","presents","phone wife","scarf","pack","travel"] +holiday :: Todo String +holiday = shopping * "pack" * "travel" 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -37,7 +37,7 @@ -- implementation uses difference lists). Here @s@ is the type of abstract -- symbols or strings (text or binary). 'Doc' @s@ is a 'Monoid', therefore -- 'mempty' corresponds to the /empty document/ and two documents can be --- concatenated with 'mappend' (or operator 'Data.Monoid.<>'). Documents +-- concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Documents -- comprising a single symbol or string can be constructed using the function -- 'literal'. Alternatively, you can construct documents as string literals, -- e.g. simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To @@ -91,7 +91,7 @@ -- constructed directly from string literals (see the second example below). -- -- @ --- literal "Hello, " 'Data.Monoid.<>' literal "World!" == literal "Hello, World!" +-- literal "Hello, " 'Data.Semigroup.<>' literal "World!" == literal "Hello, World!" -- literal "I am just a string literal" == "I am just a string literal" -- 'render' . literal == 'id' -- @ @@ -101,8 +101,8 @@ -- | Render the document as a single string. An inverse of the function 'literal'. -- -- @ --- render ('literal' "al" 'Data.Monoid.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s --- render ('literal' "al" 'Data.Monoid.<>' 'literal' "ga") == "alga" +-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s +-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") == "alga" -- render 'mempty' == 'mempty' -- render . 'literal' == 'id' -- @ 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Export.Dot --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -21,7 +21,7 @@ export, exportAsIs, exportViaShow ) where -import Data.List (map, null, intersperse) +import Data.List (intersperse) import Data.Monoid import Data.String hiding (unlines) import Prelude hiding (unlines) 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,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.HigherKinded.Class --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -54,7 +54,7 @@ import Control.Applicative (Alternative(empty, (<|>))) import Control.Monad (MonadPlus, mfilter) -import Data.Tree +import Data.Tree (Forest, Tree (..)) import qualified Algebra.Graph as G 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Internal --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -29,13 +29,11 @@ import Data.Coerce import Data.Foldable -import Data.IntSet (IntSet) import Data.Semigroup (Endo (..)) import Data.Set (Set) -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set -import qualified GHC.Exts as Exts +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. 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Label --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -22,17 +22,16 @@ NonNegative, finite, finiteWord, unsafeFinite, infinite, getFinite, Distance, distance, getDistance, Capacity, capacity, getCapacity, Count, count, getCount, PowerSet (..), Minimum, getMinimum, noMinimum, - Path, Label, isZero, RegularExpression, + Path, Label, symbol, symbols, isZero, RegularExpression, -- * Combining edge labels Optimum (..), ShortestPath, AllShortestPaths, CountShortestPaths, WidestPath ) where -import Control.Applicative import Control.Monad import Data.Coerce import Data.Maybe -import Data.Monoid (Any (..), Monoid (..), Sum (..)) +import Data.Monoid (Any (..), Sum (..)) import Data.Semigroup (Max (..), Min (..)) import Data.Set (Set) import GHC.Exts (IsList (..)) @@ -72,7 +71,7 @@ > x <.> (y <+> z) == x <.> y <+> x <.> z > (x <+> y) <.> z == x <.> z <+> y <.> z -} -class (Monoid a, Semigroup a) => Semiring a where +class Monoid a => Semiring a where one :: a (<.>) :: a -> a -> a @@ -285,11 +284,11 @@ instance (Num a, Eq a) => Num (Extended a) where fromInteger = Finite . fromInteger - (+) = liftA2 (+) + (+) = liftM2 (+) Finite 0 * _ = Finite 0 _ * Finite 0 = Finite 0 - x * y = liftA2 (*) x y + x * y = liftM2 (*) x y negate = fmap negate signum = fmap signum @@ -331,7 +330,7 @@ instance (Monoid a, Ord a) => Semiring (Minimum a) where one = pure mempty - (<.>) = liftA2 mappend + (<.>) = liftM2 mappend instance (Monoid a, Ord a) => Dioid (Minimum a) @@ -364,8 +363,8 @@ instance (Monoid a, Ord a) => Dioid (PowerSet a) where --- | The type of /free labels/ over the underlying set of symbols @a@. This data --- type is an instance of classes 'StarSemiring' and 'Dioid'. +-- | The type of /free labels/ over the underlying set of symbols @a@. 'Label' values +-- can be manipulated via its 'Semigroup', 'Monoid' and 'StarSemiring' class instances. data Label a = Zero | One | Symbol a @@ -377,9 +376,17 @@ infixl 6 :+: infixl 7 :*: +-- | Wrap a value into a 'Symbol' constructor +symbol :: a -> Label a +symbol = Symbol + +-- | Wrap a list of values into 'Symbol' constructors terminated by 'Zero' +symbols :: Foldable t => t a -> Label a +symbols = foldr ((<>) . Symbol) Zero + instance IsList (Label a) where type Item (Label a) = a - fromList = foldr ((<>) . Symbol) Zero + fromList = symbols toList = error "Label.toList cannot be given a reasonable definition" instance Show a => Show (Label a) where 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,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -52,10 +52,12 @@ import Algebra.Graph.Label import qualified Algebra.Graph.Labelled.AdjacencyMap as AM -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified GHC.Exts as Exts +import qualified Algebra.Graph.ToGraph as T +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified GHC.Exts as Exts + -- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. -- For example, 'Graph' @Bool@ @a@ is isomorphic to unlabelled graphs defined in -- the top-level module "Algebra.Graph.Graph", where @False@ and @True@ denote @@ -68,7 +70,7 @@ instance (Eq e, Monoid e, Ord a) => Eq (Graph e a) where x == y = toAdjacencyMap x == toAdjacencyMap y -instance (Eq e, Monoid e, Ord a, Ord e) => Ord (Graph e a) where +instance (Monoid e, Ord a, Ord e) => Ord (Graph e a) where compare x y = compare (toAdjacencyMap x) (toAdjacencyMap y) -- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' @@ -100,6 +102,17 @@ instance Monoid e => Monoid (Graph e a) where mempty = empty +-- TODO: Add tests. +instance (Eq e, Monoid e, Ord a) => T.ToGraph (Graph e a) where + type ToVertex (Graph e a) = a + foldg e v o c = foldg e v (\e -> if e == mempty then o else c) + vertexList = vertexList + vertexSet = vertexSet + toAdjacencyMap = AM.skeleton . toAdjacencyMap + toAdjacencyMapTranspose = T.toAdjacencyMap . transpose + toAdjacencyIntMap = T.toAdjacencyIntMap . toAdjacencyMap + toAdjacencyIntMapTranspose = T.toAdjacencyIntMap . T.toAdjacencyMapTranspose + -- TODO: This is a very inefficient implementation. Find a way to construct an -- adjacency map directly, without building intermediate representations for all -- subgraphs. @@ -558,7 +571,7 @@ -- closure == 'reflexiveClosure' . 'transitiveClosure' -- closure == 'transitiveClosure' . 'reflexiveClosure' -- closure . closure == closure --- 'Algebra.Graph.ToGraph.postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- 'Algebra.Graph.ToGraph.postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ closure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a closure = fromAdjacencyMap . AM.closure . toAdjacencyMap 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,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -52,9 +52,12 @@ import Algebra.Graph.Label import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set +import qualified Algebra.Graph.ToGraph as T +import qualified Data.IntSet as IntSet +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@ @@ -121,6 +124,30 @@ instance (Ord a, Eq e, Monoid e) => Monoid (AdjacencyMap e a) where mempty = empty +-- TODO: Add tests. +-- | Defined via 'skeleton' and the 'T.ToGraph' instance of 'AM.AdjacencyMap'. +instance (Eq e, Monoid e, Ord a) => T.ToGraph (AdjacencyMap e a) where + type ToVertex (AdjacencyMap e a) = a + toGraph = T.toGraph . skeleton + foldg e v o c = T.foldg e v o c . skeleton + isEmpty = isEmpty + hasVertex = hasVertex + hasEdge = hasEdge + vertexCount = vertexCount + edgeCount = edgeCount + vertexList = vertexList + vertexSet = vertexSet + vertexIntSet = IntSet.fromAscList . vertexList + edgeList = T.edgeList . skeleton + edgeSet = T.edgeSet . skeleton + adjacencyList = T.adjacencyList . skeleton + preSet = preSet + postSet = postSet + toAdjacencyMap = skeleton + toAdjacencyIntMap = T.toAdjacencyIntMap . skeleton + toAdjacencyMapTranspose = T.toAdjacencyMapTranspose . skeleton + toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose . skeleton + -- | Construct the /empty graph/. -- -- @ @@ -632,7 +659,7 @@ -- closure == 'reflexiveClosure' . 'transitiveClosure' -- closure == 'transitiveClosure' . 'reflexiveClosure' -- closure . closure == closure --- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ closure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a closure = goWarshallFloydKleene . reflexiveClosure 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled.Example.Automaton --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -16,6 +16,7 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Labelled.Example.Automaton where +import Control.Arrow ((&&&)) import Data.Map (Map) import Data.Monoid (Any (..)) @@ -42,10 +43,10 @@ -- | An example automaton for ordering coffee or tea. -- -- @ --- order = 'overlays' [ 'Choice' '-<'['Coffee', 'Tea']'>-' 'Payment' --- , 'Choice' '-<'['Cancel' ]'>-' 'Complete' --- , 'Payment' '-<'['Cancel' ]'>-' 'Choice' --- , 'Payment' '-<'['Pay' ]'>-' 'Complete' ] +-- coffeeTeaAutomaton = 'overlays' [ 'Choice' '-<'['Coffee', 'Tea']'>-' 'Payment' +-- , 'Payment' '-<'['Pay' ]'>-' 'Complete' +-- , 'Choice' '-<'['Cancel' ]'>-' 'Complete' +-- , 'Payment' '-<'['Cancel' ]'>-' 'Choice' ] -- @ coffeeTeaAutomaton :: Automaton Alphabet State coffeeTeaAutomaton = overlays [ Choice -<[Coffee, Tea]>- Payment @@ -56,7 +57,9 @@ -- | The map of 'State' reachability. -- -- @ --- reachability = Map.'Map.fromList' $ map (\s -> (s, 'reachable' s 'order')) ['Choice' ..] +-- reachability = Map.'Map.fromList' $ map ('id' '&&&' 'reachable' skeleton) ['Choice' ..] +-- where +-- skeleton = emap (Any . not . 'isZero') coffeeTeaAutomaton -- @ -- -- Or, when evaluated: @@ -67,7 +70,7 @@ -- , ('Complete', ['Complete' ]) ] -- @ reachability :: Map State [State] -reachability = Map.fromList $ map (\s -> (s, reachable s skeleton)) [Choice ..] +reachability = Map.fromList $ map (id &&& reachable skeleton) [Choice ..] where skeleton :: Graph Any State skeleton = emap (Any . not . isZero) coffeeTeaAutomaton diff --git a/src/Algebra/Graph/Labelled/Example/Network.hs b/src/Algebra/Graph/Labelled/Example/Network.hs --- a/src/Algebra/Graph/Labelled/Example/Network.hs +++ b/src/Algebra/Graph/Labelled/Example/Network.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled.Example.Network --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -53,7 +53,6 @@ ) where import Control.DeepSeq -import Control.Monad import Control.Monad.Trans.State import Data.List.NonEmpty (NonEmpty (..)) import Data.String @@ -913,15 +912,15 @@ -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the -- original vertices (wrapping the latter in 'Right') such that the resulting --- graph is /sparse/, i.e. contains only O(s) edges, but preserves the +-- graph is /sparse/, i.e. contains only /O(s)/ edges, but preserves the -- reachability relation between the original vertices. Sparsification is useful -- when working with dense graphs, as it can reduce the number of edges from --- O(n^2) down to O(n) by replacing cliques, bicliques and similar densely +-- /O(n^2)/ down to /O(n)/ by replacing cliques, bicliques and similar densely -- connected structures by sparse subgraphs built out of intermediate vertices. --- Complexity: O(s) time, memory and size. +-- Complexity: /O(s)/ time, memory and size. -- -- @ --- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' ('Data.Either.Right' x) . sparsify +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' (sparsify x) . 'Data.Either.Right' -- 'vertexCount' (sparsify x) <= 'vertexCount' x + 'size' x + 1 -- 'edgeCount' (sparsify x) <= 3 * 'size' x -- 'size' (sparsify x) <= 3 * 'size' x @@ -950,7 +949,7 @@ -- contain a quadratic /O(s^2)/ number of edges. -- -- @ --- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' k == 'Data.List.sort' . 'filter' (<= n) . 'flip' 'Data.Graph.reachable' k . sparsifyKL n +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'filter' (<= n) . 'Data.Graph.reachable' (sparsifyKL n x) -- 'length' ('Data.Graph.vertices' $ sparsifyKL n x) <= 'vertexCount' x + 'size' x + 1 -- 'length' ('Data.Graph.edges' $ sparsifyKL n x) <= 3 * 'size' x -- @ 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,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -656,7 +656,7 @@ -- closure == 'reflexiveClosure' . 'transitiveClosure' -- closure == 'transitiveClosure' . 'reflexiveClosure' -- closure . closure == closure --- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ closure :: Ord a => AdjacencyMap a -> AdjacencyMap a closure = coerce AM.closure 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -46,14 +46,18 @@ import Data.Bifunctor import Data.Set (Set, union) import Data.String -import Data.Tree +import Data.Tree (Tree (..)) import Data.Tuple -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import qualified Data.Tree as Tree +import qualified Data.IntSet as IntSet +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Tree as Tree -import Algebra.Graph.Internal +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.ToGraph as T {-| The 'Relation' data type represents a graph as a /binary relation/. We define a 'Num' instance as a convenient notation for working with graphs: @@ -205,6 +209,26 @@ instance Ord a => Monoid (Relation a) where mempty = empty +instance Ord a => T.ToGraph (Relation a) where + type ToVertex (Relation a) = a + toGraph r = G.vertices (Set.toList $ domain r) `G.overlay` + G.edges (Set.toList $ relation r) + isEmpty = isEmpty + hasVertex = hasVertex + hasEdge = hasEdge + vertexCount = vertexCount + edgeCount = edgeCount + vertexList = vertexList + vertexSet = vertexSet + vertexIntSet = IntSet.fromAscList . vertexList + edgeList = edgeList + edgeSet = edgeSet + adjacencyList = adjacencyList + toAdjacencyMap = AM.stars . adjacencyList + toAdjacencyIntMap = AIM.stars . adjacencyList + toAdjacencyMapTranspose = AM.transpose . T.toAdjacencyMap + toAdjacencyIntMapTranspose = AIM.transpose . T.toAdjacencyIntMap + -- | Construct the /empty graph/. -- -- @ @@ -778,7 +802,7 @@ -- closure == 'reflexiveClosure' . 'transitiveClosure' -- closure == 'transitiveClosure' . 'reflexiveClosure' -- closure . closure == closure --- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ closure :: Ord a => Relation a -> Relation a closure = reflexiveClosure . transitiveClosure 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Symmetric --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -13,8 +13,8 @@ -- import qualified Algebra.Graph.Relation.Symmetric as Symmetric -- @ -- --- 'Relation' is an instance of the 'Algebra.Graph.Class.Graph' type --- class, which can be used for polymorphic graph construction and manipulation. +-- 'Relation' is an instance of the 'Algebra.Graph.Class.Graph' type class, +-- which can be used for polymorphic graph construction and manipulation. ----------------------------------------------------------------------------- module Algebra.Graph.Relation.Symmetric ( -- * Data structure @@ -45,10 +45,12 @@ import Data.Coerce import Data.Set (Set) import Data.String -import Data.Tree +import Data.Tree (Forest, Tree) -import qualified Data.Set as Set +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import qualified Algebra.Graph.ToGraph as T import qualified Algebra.Graph.Relation as R {-| This data type represents a /symmetric binary relation/ over a set of @@ -138,8 +140,28 @@ instance Ord a => Monoid (Relation a) where mempty = empty +-- | Defined via 'fromSymmetric' and the 'T.ToGraph' instance of 'R.Relation'. +instance Ord a => T.ToGraph (Relation a) where + type ToVertex (Relation a) = a + toGraph = T.toGraph . fromSymmetric + isEmpty = isEmpty + hasVertex = hasVertex + hasEdge = hasEdge + vertexCount = vertexCount + edgeCount = R.edgeCount . fromSymmetric + vertexList = vertexList + vertexSet = vertexSet + vertexIntSet = IntSet.fromAscList . vertexList + edgeList = R.edgeList . fromSymmetric + edgeSet = R.relation . fromSymmetric + adjacencyList = adjacencyList + toAdjacencyMap = T.toAdjacencyMap . fromSymmetric + toAdjacencyIntMap = T.toAdjacencyIntMap . fromSymmetric + toAdjacencyMapTranspose = T.toAdjacencyMap -- No need to transpose! + toAdjacencyIntMapTranspose = T.toAdjacencyIntMap -- No need to transpose! + -- | Construct a symmetric relation from a given "Algebra.Graph.Relation". --- Complexity: /O(m*log(m))/ time. +-- Complexity: /O(m * log(m))/ time. -- -- @ -- toSymmetric ('Algebra.Graph.Relation.edge' 1 2) == 'edge' 1 2 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -55,21 +55,22 @@ import Data.Set (Set) import Data.Tree -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyMap.Algorithm 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.AdjacencyIntMap as AIM -import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIM -import qualified Algebra.Graph.Relation as R -import qualified Algebra.Graph.Relation.Symmetric as SR -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set +-- Ideally, we would define all instances in the modules where the corresponding +-- data types are declared. However, that causes import cycles, so we define a +-- few instances here. + +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.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIM + -- | The 'ToGraph' type class captures data types that can be converted to -- algebraic graphs. Instances of this type class should satisfy the laws -- specified by the default method definitions. @@ -236,29 +237,29 @@ -- necessarily span the whole graph, as some vertices may be unreachable. -- -- @ - -- dfsForestFrom vs == Algebra.Graph.AdjacencyMap.'AM.dfsForestFrom' vs . toAdjacencyMap + -- dfsForestFrom == Algebra.Graph.AdjacencyMap.'AM.dfsForestFrom' . toAdjacencyMap -- @ - dfsForestFrom :: Ord (ToVertex t) => [ToVertex t] -> t -> Forest (ToVertex t) - dfsForestFrom vs = AM.dfsForestFrom vs . toAdjacencyMap + dfsForestFrom :: Ord (ToVertex t) => t -> [ToVertex t] -> Forest (ToVertex t) + dfsForestFrom = AM.dfsForestFrom . toAdjacencyMap -- | Compute the list of vertices visited by the /depth-first search/ in a -- graph, when searching from each of the given vertices in order. -- -- @ - -- dfs vs == Algebra.Graph.AdjacencyMap.'AM.dfs' vs . toAdjacencyMap + -- dfs == Algebra.Graph.AdjacencyMap.'AM.dfs' . toAdjacencyMap -- @ - dfs :: Ord (ToVertex t) => [ToVertex t] -> t -> [ToVertex t] - dfs vs = AM.dfs vs . toAdjacencyMap + dfs :: Ord (ToVertex t) => t -> [ToVertex t] -> [ToVertex t] + dfs = AM.dfs . toAdjacencyMap -- | Compute the list of vertices that are /reachable/ from a given source -- vertex in a graph. The vertices in the resulting list appear in the -- /depth-first order/. -- -- @ - -- reachable x == Algebra.Graph.AdjacencyMap.'AM.reachable' x . toAdjacencyMap + -- reachable == Algebra.Graph.AdjacencyMap.'AM.reachable' . toAdjacencyMap -- @ - reachable :: Ord (ToVertex t) => ToVertex t -> t -> [ToVertex t] - reachable x = AM.reachable x . toAdjacencyMap + reachable :: Ord (ToVertex t) => t -> ToVertex t -> [ToVertex t] + reachable = AM.reachable . toAdjacencyMap -- | Compute the /topological sort/ of a graph or a @AM.Cycle@ if the -- graph is cyclic. @@ -329,6 +330,7 @@ isTopSortOf :: Ord (ToVertex t) => [ToVertex t] -> t -> Bool isTopSortOf vs = AM.isTopSortOf vs . toAdjacencyMap +-- | See "Algebra.Graph". instance Ord a => ToGraph (G.Graph a) where type ToVertex (G.Graph a) = a toGraph = id @@ -368,6 +370,7 @@ isDfsForestOf = AM.isDfsForestOf isTopSortOf = AM.isTopSortOf +-- | See "Algebra.Graph.AdjacencyIntMap". instance ToGraph AIM.AdjacencyIntMap where type ToVertex AIM.AdjacencyIntMap = Int toGraph = G.stars @@ -400,42 +403,6 @@ isDfsForestOf = AIM.isDfsForestOf isTopSortOf = AIM.isTopSortOf --- | See "Algebra.Graph.Labelled". -instance (Eq e, Monoid e, Ord a) => ToGraph (LG.Graph e a) where - type ToVertex (LG.Graph e a) = a - foldg e v o c = LG.foldg e v (\e -> if e == mempty then o else c) - vertexList = LG.vertexList - vertexSet = LG.vertexSet - toAdjacencyMap = LAM.skeleton - . LG.foldg LAM.empty LAM.vertex LAM.connect - toAdjacencyMapTranspose = LAM.skeleton - . LG.foldg LAM.empty LAM.vertex (fmap flip LAM.connect) - toAdjacencyIntMap = toAdjacencyIntMap . toAdjacencyMap - toAdjacencyIntMapTranspose = toAdjacencyIntMapTranspose . toAdjacencyMapTranspose - --- | See "Algebra.Graph.Labelled.AdjacencyMap". -instance (Eq e, Monoid e, Ord a) => ToGraph (LAM.AdjacencyMap e a) where - type ToVertex (LAM.AdjacencyMap e a) = a - toGraph = toGraph . LAM.skeleton - foldg e v o c = foldg e v o c . LAM.skeleton - isEmpty = LAM.isEmpty - hasVertex = LAM.hasVertex - hasEdge = LAM.hasEdge - vertexCount = LAM.vertexCount - edgeCount = LAM.edgeCount - vertexList = LAM.vertexList - vertexSet = LAM.vertexSet - vertexIntSet = IntSet.fromAscList . LAM.vertexList - edgeList = edgeList . LAM.skeleton - edgeSet = edgeSet . LAM.skeleton - adjacencyList = adjacencyList . LAM.skeleton - preSet = LAM.preSet - postSet = LAM.postSet - toAdjacencyMap = LAM.skeleton - toAdjacencyIntMap = toAdjacencyIntMap . LAM.skeleton - toAdjacencyMapTranspose = toAdjacencyMapTranspose . LAM.skeleton - toAdjacencyIntMapTranspose = toAdjacencyIntMapTranspose . LAM.skeleton - -- | See "Algebra.Graph.NonEmpty.AdjacencyMap". instance Ord a => ToGraph (NAM.AdjacencyMap a) where type ToVertex (NAM.AdjacencyMap a) = a @@ -454,9 +421,9 @@ preSet = NAM.preSet postSet = NAM.postSet dfsForest = dfsForest . toAdjacencyMap - dfsForestFrom xs = dfsForestFrom xs . toAdjacencyMap - dfs xs = dfs xs . toAdjacencyMap - reachable x = reachable x . toAdjacencyMap + dfsForestFrom = dfsForestFrom . toAdjacencyMap + dfs = dfs . toAdjacencyMap + reachable = reachable . toAdjacencyMap topSort = topSort . toAdjacencyMap isAcyclic = isAcyclic . toAdjacencyMap toAdjacencyMap = NAM.fromNonEmpty @@ -465,51 +432,6 @@ toAdjacencyIntMapTranspose = toAdjacencyIntMap . NAM.transpose 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". -instance Ord a => ToGraph (R.Relation a) where - type ToVertex (R.Relation a) = a - toGraph r = G.vertices (Set.toList $ R.domain r) `G.overlay` - G.edges (Set.toList $ R.relation r) - isEmpty = R.isEmpty - hasVertex = R.hasVertex - hasEdge = R.hasEdge - vertexCount = R.vertexCount - edgeCount = R.edgeCount - vertexList = R.vertexList - vertexSet = R.vertexSet - vertexIntSet = IntSet.fromAscList . R.vertexList - edgeList = R.edgeList - edgeSet = R.edgeSet - adjacencyList = R.adjacencyList - toAdjacencyMap = AM.stars . R.adjacencyList - toAdjacencyIntMap = AIM.stars . R.adjacencyList - toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap - toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap - --- TODO: This instance is probably wrong because of the way it treats edges. --- Find out a better way to integrate undirected graphs into 'ToGraph'. --- | See "Algebra.Graph.Symmetric.Relation". Warning: this instance is likely to --- be modified or removed in future. -instance Ord a => ToGraph (SR.Relation a) where - type ToVertex (SR.Relation a) = a - toGraph = toGraph . SR.fromSymmetric - isEmpty = SR.isEmpty - hasVertex = SR.hasVertex - hasEdge = SR.hasEdge - vertexCount = SR.vertexCount - edgeCount = SR.edgeCount - vertexList = SR.vertexList - vertexSet = SR.vertexSet - vertexIntSet = IntSet.fromAscList . SR.vertexList - edgeList = SR.edgeList - edgeSet = SR.edgeSet - adjacencyList = SR.adjacencyList - 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/. diff --git a/src/Algebra/Graph/Undirected.hs b/src/Algebra/Graph/Undirected.hs --- a/src/Algebra/Graph/Undirected.hs +++ b/src/Algebra/Graph/Undirected.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Undirected --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -60,7 +60,7 @@ import Data.String import qualified Algebra.Graph as G -import qualified Algebra.Graph.Relation.Symmetric as R +import qualified Algebra.Graph.Relation.Symmetric as SR import qualified Data.Set as Set -- TODO: Specialise the API for graphs with vertices of type 'Int'. @@ -88,7 +88,7 @@ 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 +The 'Eq' instance is currently implemented using the 'SR.Relation' as the /canonical graph representation/ and satisfies all axioms of algebraic graphs: * 'overlay' is commutative and associative: @@ -144,7 +144,7 @@ 'vertexCount' ('empty' + 'empty') == 0 'size' ('empty' + 'empty') == 2@ -Converting an undirected 'Graph' to the corresponding 'R.Relation' takes +Converting an undirected 'Graph' to the corresponding 'SR.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. @@ -238,7 +238,7 @@ -- 'Algebra.Graph.edgeCount' . fromUndirected <= (*2) . 'edgeCount' -- @ fromUndirected :: Ord a => Graph a -> G.Graph a -fromUndirected = toGraph . toRelation +fromUndirected = toGraph . SR.fromSymmetric . toRelation -- | Construct the /empty graph/. -- @@ -421,15 +421,15 @@ -- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool -isSubgraphOf x y = R.isSubgraphOf (toRelation x) (toRelation y) +isSubgraphOf x y = SR.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 +-- | Convert an undirected graph to a symmetric 'SR.Relation'. +toRelation :: Ord a => Graph a -> SR.Relation a +toRelation = foldg SR.empty SR.vertex SR.overlay SR.connect {-# INLINE toRelation #-} -- | Check if a graph is empty. @@ -516,7 +516,7 @@ -- edgeCount == 'length' . 'edgeList' -- @ edgeCount :: Ord a => Graph a -> Int -edgeCount = R.edgeCount . toRelation +edgeCount = SR.edgeCount . toRelation {-# INLINE [1] edgeCount #-} -- | The sorted list of vertices of a given graph. @@ -542,7 +542,7 @@ -- edgeList ('star' 2 [3,1]) == [(1,2), (2,3)] -- @ edgeList :: Ord a => Graph a -> [(a, a)] -edgeList = R.edgeList . toRelation +edgeList = SR.edgeList . toRelation {-# INLINE [1] edgeList #-} -- | The set of vertices of a given graph. @@ -566,7 +566,7 @@ -- 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 +edgeSet = SR.edgeSet . toRelation {-# INLINE [1] edgeSet #-} -- | The sorted /adjacency list/ of a graph. @@ -580,7 +580,7 @@ -- 'stars' . adjacencyList == id -- @ adjacencyList :: Ord a => Graph a -> [(a, [a])] -adjacencyList = R.adjacencyList . toRelation +adjacencyList = SR.adjacencyList . toRelation {-# INLINE adjacencyList #-} {-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} @@ -593,7 +593,7 @@ -- neighbours y ('edge' x y) == Set.'Set.fromList' [x] -- @ neighbours :: Ord a => a -> Graph a -> Set a -neighbours x = R.neighbours x . toRelation +neighbours x = SR.neighbours x . toRelation {-# INLINE neighbours #-} -- | The /path/ on a list of vertices. 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Graph.Typed --- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2022 +-- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com -- Stability : unstable @@ -86,8 +86,8 @@ -- In the following examples we will use the helper function: -- -- @ --- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a --- a % g = a $ 'fromAdjacencyMap' g +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) -- @ -- -- for greater clarity. @@ -95,11 +95,10 @@ -- @ -- '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.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) --- 'AM.dfsForestFrom' ('AM.vertexList' x) % x == dfsForest % x -- dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] }]} @@ -117,30 +116,30 @@ -- In the following examples we will use the helper function: -- -- @ --- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a --- a % g = a $ 'fromAdjacencyMap' g +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) -- @ -- -- 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 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 1) [1] == 'AM.vertex' 1 +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [0] == 'AM.empty' +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [1] == 'AM.edge' 1 2 +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [2] == 'AM.vertex' 2 +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [2,1] == 'AM.vertices' [1,2] +-- 'AM.isSubgraphOf' ('AM.forest' $ dfsForestFrom % x $ vs) x == True +-- dfsForestFrom % x $ 'AM.vertexList' x == 'dfsForest' % x +-- dfsForestFrom % 'AM.vertices' vs $ vs == 'map' (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom % x $ [] == [] +-- dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] -- @ -dfsForestFrom :: [a] -> GraphKL a -> Forest a -dfsForestFrom vs (GraphKL g r t) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) +dfsForestFrom :: GraphKL a -> [a] -> Forest a +dfsForestFrom (GraphKL g r t) = fmap (fmap r) . KL.dfs g . mapMaybe t -- | Compute the list of vertices visited by the /depth-first search/ in a -- graph, when searching from each of the given vertices in order. @@ -148,25 +147,26 @@ -- In the following examples we will use the helper function: -- -- @ --- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a --- a % g = a $ 'fromAdjacencyMap' g +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) -- @ -- -- 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] --- 'AM.isSubgraphOf' ('AM.vertices' $ dfs vs x) x == True +-- dfs % 'AM.edge' 1 1 $ [1] == [1] +-- dfs % 'AM.edge' 1 2 $ [0] == [] +-- dfs % 'AM.edge' 1 2 $ [1] == [1,2] +-- dfs % 'AM.edge' 1 2 $ [2] == [2] +-- dfs % 'AM.edge' 1 2 $ [1,2] == [1,2] +-- dfs % 'AM.edge' 1 2 $ [2,1] == [2,1] +-- dfs % x $ [] == [] +-- +-- dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [1,5,4] +-- 'Data.List.and' [ 'AM.hasVertex' v x | v <- dfs % x $ vs ] == True -- @ -dfs :: [a] -> GraphKL a -> [a] -dfs vs = concatMap flatten . dfsForestFrom vs +dfs :: GraphKL a -> [a] -> [a] +dfs x = concatMap flatten . dfsForestFrom x -- | Compute the /topological sort/ of a graph. Note that this function returns -- a result even if the graph is cyclic. @@ -174,8 +174,8 @@ -- In the following examples we will use the helper function: -- -- @ --- (%) :: (GraphKL Int -> a) -> 'AM.AdjacencyMap' Int -> a --- a % g = a $ 'fromAdjacencyMap' g +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) -- @ -- -- for greater clarity. @@ -187,6 +187,7 @@ topSort :: GraphKL a -> [a] topSort (GraphKL g r _) = map r (KL.topSort g) +-- TODO: Add docs and tests. scc :: Ord a => AM.AdjacencyMap a -> AM.AdjacencyMap (NonEmpty.AdjacencyMap a) scc m = AM.gmap (component Map.!) $ removeSelfLoops $ AM.gmap (leader Map.!) m where 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,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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 @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.API --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -97,12 +97,12 @@ , 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]] + , bfsForest :: forall a. c a => g a -> [a] -> Forest a + , bfs :: forall a. c a => g a -> [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] + , dfsForestFrom :: forall a. c a => g a -> [a] -> Forest a + , dfs :: forall a. c a => g a -> [a] -> [a] + , reachable :: forall a. c a => g a -> 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 diff --git a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Acyclic.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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 @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Arbitrary --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,10 +14,8 @@ arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, ) where -import Control.Monad import Data.List.NonEmpty (NonEmpty (..), toList) import Data.Maybe (catMaybes) -import Data.Tree import Test.QuickCheck import Algebra.Graph diff --git a/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs b/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Bipartite.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -20,7 +20,7 @@ import Algebra.Graph.Test import Data.Either import Data.Either.Extra -import Data.List (nub, sort) +import Data.List (nub) import Data.Map.Strict (Map) import Data.Set (Set) @@ -30,7 +30,6 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Tuple -import qualified Algebra.Graph.Bipartite.AdjacencyMap as B type AI = AM.AdjacencyMap Int type AII = AM.AdjacencyMap (Either Int Int) 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Export --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Generic --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -13,7 +13,7 @@ import Control.Monad (when) import Data.Either -import Data.List (nub, sort) +import Data.List (nub) import Data.List.NonEmpty (NonEmpty (..)) import Data.Tree import Data.Tuple @@ -688,14 +688,14 @@ 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 "dfsForestFrom == Algebra.Graph.AdjacencyMap.dfsForestFrom . toAdjacencyMap" $ \x vs -> + dfsForestFrom x vs == (AM.dfsForestFrom . toAdjacencyMap) x vs - test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> - dfs vs x == (AM.dfs vs . toAdjacencyMap) x + test "dfs == Algebra.Graph.AdjacencyMap.dfs . toAdjacencyMap" $ \x vs -> + dfs x vs == (AM.dfs . toAdjacencyMap) x vs - test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> - reachable x y == (AM.reachable x . toAdjacencyMap) y + test "reachable == Algebra.Graph.AdjacencyMap.reachable . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable . toAdjacencyMap) x y test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> topSort x == (AM.topSort . toAdjacencyMap) x @@ -782,14 +782,14 @@ 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 "dfsForestFrom == Algebra.Graph.AdjacencyMap.dfsForestFrom . toAdjacencyMap" $ \x vs -> + dfsForestFrom x vs == (AM.dfsForestFrom . toAdjacencyMap) x vs - test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> - dfs vs x == (AM.dfs vs . toAdjacencyMap) x + test "dfs == Algebra.Graph.AdjacencyMap.dfs . toAdjacencyMap" $ \x vs -> + dfs x vs == (AM.dfs . toAdjacencyMap) x vs - test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> - reachable x y == (AM.reachable x . toAdjacencyMap) y + test "reachable == Algebra.Graph.AdjacencyMap.reachable . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable . toAdjacencyMap) x y test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> topSort x == (AM.topSort . toAdjacencyMap) x @@ -1594,8 +1594,8 @@ 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) + test "postSet x (closure y) == Set.fromList (reachable y x)" $ size10 $ \x y -> + postSet x (closure y) == Set.fromList (reachable y x) testReflexiveClosure :: TestsuiteInt g -> IO () testReflexiveClosure (prefix, API{..}) = do @@ -1702,114 +1702,106 @@ testBfsForest :: TestsuiteInt g -> IO () testBfsForest (prefix, API{..}) = do putStrLn $ "\n============ " ++ prefix ++ "bfsForest ============" - test "bfsForest vs empty == []" $ \vs -> - bfsForest vs empty == [] + test "forest $ bfsForest (edge 1 2) [0] == empty" $ + (forest $ bfsForest (edge 1 2) [0]) == empty - test "forest (bfsForest [1] $ edge 1 1) == vertex 1" $ - forest (bfsForest [1] $ edge 1 1) == vertex 1 + test "forest $ bfsForest (edge 1 2) [1] == edge 1 2" $ + (forest $ bfsForest (edge 1 2) [1]) == edge 1 2 - test "forest (bfsForest [1] $ edge 1 2) == edge 1 2" $ - forest (bfsForest [1] $ edge 1 2) == edge 1 2 + test "forest $ bfsForest (edge 1 2) [2] == vertex 2" $ + (forest $ bfsForest (edge 1 2) [2]) == vertex 2 - test "forest (bfsForest [2] $ edge 1 2) == vertex 2" $ - forest (bfsForest [2] $ edge 1 2) == vertex 2 + test "forest $ bfsForest (edge 1 2) [0,1,2] == vertices [1,2]" $ + (forest $ bfsForest (edge 1 2) [0,1,2]) == vertices [1,2] - test "forest (bfsForest [3] $ edge 1 2) == empty" $ - forest (bfsForest [3] $ edge 1 2) == empty + test "forest $ bfsForest (edge 1 2) [2,1,0] == vertices [1,2]" $ + (forest $ bfsForest (edge 1 2) [2,1,0]) == vertices [1,2] - test "forest (bfsForest [2,1] $ edge 1 2) == vertices [1,2]" $ - forest (bfsForest [2,1] $ edge 1 2) == vertices [1,2] + test "forest $ bfsForest (edge 1 1) [1] == vertex 1" $ + (forest $ bfsForest (edge 1 1) [1]) == vertex 1 - test "isSubgraphOf (forest $ bfsForest vs x) x == True" $ \vs x -> - isSubgraphOf (forest $ bfsForest vs x) x == True + test "isSubgraphOf (forest $ bfsForest x vs) x == True" $ \x vs -> + isSubgraphOf (forest $ bfsForest x vs) x == True - test "bfsForest (vertexList g) g == " $ \g -> - bfsForest (vertexList g) g == - map (\v -> Node v []) (nub $ vertexList g) + test "bfsForest x (vertexList x) == map (\v -> Node v []) (nub $ vertexList x)" $ \x -> + bfsForest x (vertexList x) == map (\v -> Node v []) (nub $ vertexList x) - test "bfsForest [] x == []" $ \x -> - bfsForest [] x == [] + 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 empty vs == []" $ \vs -> + bfsForest empty vs == [] - 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 = []}]}]}] + test "bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == " $ + bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + test "forest $ bfsForest (circuit [1..5] + circuit [5,4..1]) [3] == path [3,2,1] + path [3,4,5]" $ + (forest $ bfsForest (circuit [1..5] + circuit [5,4..1]) [3])== path [3,2,1] + path [3,4,5] + 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 (edge 1 2) [0] == []" $ + bfs (edge 1 2) [0] == [] - test "bfs [1] (edge 1 1) == [[1]]" $ - bfs [1] (edge 1 1) == [[1]] + test "bfs (edge 1 2) [1] == [[1], [2]]" $ + bfs (edge 1 2) [1] == [[1], [2]] - test "bfs [1] (edge 1 2) == [[1],[2]]" $ - bfs [1] (edge 1 2) == [[1],[2]] + test "bfs (edge 1 2) [2] == [[2]]" $ + bfs (edge 1 2) [2] == [[2]] - test "bfs [2] (edge 1 2) == [[2]]" $ - bfs [2] (edge 1 2) == [[2]] + test "bfs (edge 1 2) [1,2] == [[1,2]]" $ + bfs (edge 1 2) [1,2] == [[1,2]] - test "bfs [1,2] (edge 1 2) == [[1,2]]" $ - bfs [1,2] (edge 1 2) == [[1,2]] + test "bfs (edge 1 2) [2,1] == [[2,1]]" $ + bfs (edge 1 2) [2,1] == [[2,1]] - test "bfs [2,1] (edge 1 2) == [[2,1]]" $ - bfs [2,1] (edge 1 2) == [[2,1]] + test "bfs (edge 1 1) [1] == [[1]]" $ + bfs (edge 1 1) [1] == [[1]] - test "bfs [3] (edge 1 2) == []" $ - bfs [3] (edge 1 2) == [] + test "bfs empty vs == []" $ \vs -> + bfs empty vs == [] - 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 x [] == []" $ \x -> + bfs x [] == [] - 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 (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]]" $ + bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]] - 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 (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]]" $ + bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]] - 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 "bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]]" $ + bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]] - 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 "bfs (circuit [1..5] + circuit [5,4..1]) [2] == [[2], [1,3], [5,4]]" $ + bfs (circuit [1..5] + circuit [5,4..1]) [2] == [[2], [1,3], [5,4]] - test "isSubgraphOf (vertices $ concat $ bfs vs x) x == True" $ \vs x -> - isSubgraphOf (vertices $ concat $ bfs vs x) x == True + test "concat $ bfs (circuit [1..5] + circuit [5,4..1]) [3] == [3,2,4,1,5]" $ + (concat $ bfs (circuit [1..5] + circuit [5,4..1]) [3])== [3,2,4,1,5] - 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 + test "map concat . transpose . map levels . bfsForest x == bfs x" $ \x vs -> + (map concat . List.transpose . map levels . bfsForest x) vs == bfs x vs testDfsForest :: TestsuiteInt g -> IO () testDfsForest (prefix, API{..}) = do putStrLn $ "\n============ " ++ prefix ++ "dfsForest ============" - test "dfsForest empty == []" $ - dfsForest empty == [] + test "forest $ dfsForest empty == empty" $ + (forest $ dfsForest empty) == empty - test "forest (dfsForest $ edge 1 1) == vertex 1" $ - forest (dfsForest $ edge 1 1) == vertex 1 + 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 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 "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 @@ -1824,127 +1816,133 @@ 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 + (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 empty vs == empty" $ \vs -> + (forest $ dfsForestFrom empty vs) == empty - test "forest (dfsForestFrom [1] $ edge 1 1) == vertex 1" $ - forest (dfsForestFrom [1] $ edge 1 1) == vertex 1 + test "forest $ dfsForestFrom (edge 1 1) [1] == vertex 1" $ + (forest $ dfsForestFrom (edge 1 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 (edge 1 2) [0] == empty" $ + (forest $ dfsForestFrom (edge 1 2) [0]) == empty - test "forest (dfsForestFrom [2] $ edge 1 2) == vertex 2" $ - forest (dfsForestFrom [2] $ edge 1 2) == vertex 2 + test "forest $ dfsForestFrom (edge 1 2) [1] == edge 1 2" $ + (forest $ dfsForestFrom (edge 1 2) [1]) == edge 1 2 - test "forest (dfsForestFrom [3] $ edge 1 2) == empty" $ - forest (dfsForestFrom [3] $ edge 1 2) == empty + test "forest $ dfsForestFrom (edge 1 2) [2] == vertex 2" $ + (forest $ dfsForestFrom (edge 1 2) [2]) == vertex 2 - test "forest (dfsForestFrom [2,1] $ edge 1 2) == vertices [1,2]" $ - forest (dfsForestFrom [2,1] $ edge 1 2) == vertices [1,2] + test "forest $ dfsForestFrom (edge 1 2) [1,2] == edge 1 2" $ + (forest $ dfsForestFrom (edge 1 2) [1,2]) == edge 1 2 - test "isSubgraphOf (forest $ dfsForestFrom vs x) x == True" $ \vs x -> - isSubgraphOf (forest $ dfsForestFrom vs x) x == True + test "forest $ dfsForestFrom (edge 1 2) [2,1] == vertices [1,2]" $ + (forest $ dfsForestFrom (edge 1 2) [2,1]) == vertices [1,2] - test "isDfsForestOf (dfsForestFrom (vertexList x) x) x == True" $ \x -> - isDfsForestOf (dfsForestFrom (vertexList x) x) x == True + test "isSubgraphOf (forest $ dfsForestFrom x vs) x == True" $ \x vs -> + isSubgraphOf (forest $ dfsForestFrom x vs) x == True - test "dfsForestFrom (vertexList x) x == dfsForest x" $ \x -> - dfsForestFrom (vertexList x) x == dfsForest x + test "isDfsForestOf (dfsForestFrom x (vertexList x)) x == True" $ \x -> + isDfsForestOf (dfsForestFrom x (vertexList x)) x == True - test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> - dfsForestFrom vs (vertices vs) == map (\v -> Node v []) (nub vs) + test "dfsForestFrom x (vertexList x) == dfsForest x" $ \x -> + dfsForestFrom x (vertexList x) == dfsForest x - test "dfsForestFrom [] x == []" $ \x -> - dfsForestFrom [] x == [] + 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 + test "dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == " $ + dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == [ 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] + test "forest $ dfsForestFrom (circuit [1..5] + circuit [5,4..1]) [3] == path [3,2,1,5,4]" $ + (forest $ dfsForestFrom (circuit [1..5] + circuit [5,4..1]) [3])== 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 empty vs == []" $ \vs -> + dfs empty vs == [] - test "dfs [1] $ edge 1 1 == [1]" $ - dfs [1] (edge 1 1) == [1] + test "dfs (edge 1 1) [1] == [1]" $ + dfs (edge 1 1) [1] == [1] - test "dfs [1] $ edge 1 2 == [1,2]" $ - dfs [1] (edge 1 2) == [1,2] + test "dfs (edge 1 2) [0] == []" $ + dfs (edge 1 2) [0] == [] - test "dfs [2] $ edge 1 2 == [2]" $ - dfs [2] (edge 1 2) == [2] + test "dfs (edge 1 2) [1] == [1,2]" $ + dfs (edge 1 2) [1] == [1,2] - test "dfs [3] $ edge 1 2 == []" $ - dfs [3] (edge 1 2) == [] + test "dfs (edge 1 2) [2] == [2]" $ + dfs (edge 1 2) [2] == [2] - test "dfs [1,2] $ edge 1 2 == [1,2]" $ - dfs [1,2] (edge 1 2) == [1,2] + test "dfs (edge 1 2) [1,2] == [1,2]" $ + dfs (edge 1 2) [1,2] == [1,2] - test "dfs [2,1] $ edge 1 2 == [2,1]" $ - dfs [2,1] (edge 1 2) == [2,1] + test "dfs (edge 1 2) [2,1] == [2,1]" $ + dfs (edge 1 2) [2,1] == [2,1] - test "dfs [] $ x == []" $ \x -> - dfs [] x == [] + 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] + putStrLn "" + test "and [ hasVertex v x | v <- dfs x vs ] == True" $ \x vs -> + and [ hasVertex v x | v <- dfs x vs ] == True - test "isSubgraphOf (vertices $ dfs vs x) x == True" $ \vs x -> - isSubgraphOf (vertices $ dfs vs x) x == True + test "dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4]" $ + dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4] - 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] + test "dfs (circuit [1..5] + circuit [5,4..1]) [3] == [3,2,1,5,4]" $ + dfs (circuit [1..5] + circuit [5,4..1]) [3] == [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 empty x == []" $ \x -> + reachable empty x == [] - test "reachable 1 $ vertex 1 == [1]" $ - reachable 1 (vertex 1) == [1] + test "reachable (vertex 1) 1 == [1]" $ + reachable (vertex 1) 1 == [1] - test "reachable 1 $ vertex 2 == []" $ - reachable 1 (vertex 2) == [] + test "reachable (edge 1 1) 1 == [1]" $ + reachable (edge 1 1) 1 == [1] - test "reachable 1 $ edge 1 1 == [1]" $ - reachable 1 (edge 1 1) == [1] + test "reachable (edge 1 2) 0 == []" $ + reachable (edge 1 2) 0 == [] - test "reachable 1 $ edge 1 2 == [1,2]" $ - reachable 1 (edge 1 2) == [1,2] + test "reachable (edge 1 2) 1 == [1,2]" $ + reachable (edge 1 2) 1 == [1,2] - test "reachable 4 $ path [1..8] == [4..8]" $ - reachable 4 (path [1..8]) == [4..8] + test "reachable (edge 1 2) 2 == [2]" $ + reachable (edge 1 2) 2 == [2] - test "reachable 4 $ circuit [1..8] == [4..8] ++ [1..3]" $ - reachable 4 (circuit [1..8]) == [4..8] ++ [1..3] + test "reachable (path [1..8] ) 4 == [4..8]" $ + reachable (path [1..8] ) 4 == [4..8] - test "reachable 8 $ clique [8,7..1] == [8] ++ [1..7]" $ - reachable 8 (clique [8,7..1]) == [8] ++ [1..7] + test "reachable (circuit [1..8] ) 4 == [4..8] ++ [1..3]" $ + reachable (circuit [1..8] ) 4 == [4..8] ++ [1..3] - test "isSubgraphOf (vertices $ reachable x y) y == True" $ \x y -> - isSubgraphOf (vertices $ reachable x y) y == True + test "reachable (clique [8,7..1]) 8 == [8] ++ [1..7]" $ + reachable (clique [8,7..1]) 8 == [8] ++ [1..7] + putStrLn "" + test "and [ hasVertex v x | v <- reachable x y ] == True" $ \x y -> + and [ hasVertex v x | v <- reachable x y ] == True + testTopSort :: TestsuiteInt g -> IO () testTopSort (prefix, API{..}) = do putStrLn $ "\n============ " ++ prefix ++ "topSort ============" @@ -1969,8 +1967,8 @@ 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 "topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 :| [2])" $ + topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 :| [2]) test "fmap (flip isTopSortOf x) (topSort x) /= Right False" $ \x -> fmap (flip isTopSortOf x) (topSort x) /= Right 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -79,8 +79,8 @@ testBox tPoly putStrLn "\n============ Graph.sparsify ============" - test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> - (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y + test "sort . reachable x == sort . rights . reachable (sparsify x) . Right" $ \(x :: G) y -> + (sort . reachable x) y ==(sort . rights . reachable (sparsify x) . Right) y test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> vertexCount (sparsify x) <= vertexCount x + size x + 1 @@ -92,12 +92,12 @@ size (sparsify x) <= 3 * size x putStrLn "\n============ Graph.sparsifyKL ============" - test "sort . reachable k == sort . filter (<= n) . flip reachable k . sparsifyKL n" $ \(Positive n) -> do + test "sort . reachable x == sort . filter (<= n) . reachable (sparsifyKL n x)" $ \(Positive n) -> do let pairs = (,) <$> choose (1, n) <*> choose (1, n) - k <- choose (1, n) es <- listOf pairs let x = vertices [1..n] `overlay` edges es - return $ (sort . reachable k) x == (sort . filter (<= n) . flip KL.reachable k . sparsifyKL n) x + y <- choose (1, n) + return $ (sort . reachable x) y == (sort . filter (<= n) . KL.reachable (sparsifyKL n x)) y test "length (vertices $ sparsifyKL n x) <= vertexCount x + size x + 1" $ \(Positive n) -> do let pairs = (,) <$> choose (1, n) <*> choose (1, n) 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Internal --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/test/Algebra/Graph/Test/Label.hs b/test/Algebra/Graph/Test/Label.hs --- a/test/Algebra/Graph/Test/Label.hs +++ b/test/Algebra/Graph/Test/Label.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Label --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -430,8 +430,8 @@ test "closure . closure == closure" $ size10 $ \x -> (closure . closure) x == closure (x :: LAD) - test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> - postSet x (closure y) == Set.fromList (reachable x y) + test "postSet x (closure y) == Set.fromList (reachable y x)" $ size10 $ \(x :: Int) (y :: LAD) -> + postSet x (closure y) == Set.fromList (reachable y x) putStrLn "\n============ Labelled.AdjacencyMap.reflexiveClosure ============" test "reflexiveClosure 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Labelled.Graph --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -422,8 +422,8 @@ test "closure . closure == closure" $ size10 $ \x -> (closure . closure) x == closure (x :: LAD) - test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> - T.postSet x (closure y) == Set.fromList (T.reachable x y) + test "postSet x (closure y) == Set.fromList (reachable y x)" $ size10 $ \(x :: Int) (y :: LAD) -> + T.postSet x (closure y) == Set.fromList (T.reachable y x) putStrLn "\n============ Labelled.Graph.reflexiveClosure ============" test "reflexiveClosure 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.NonEmpty.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -580,8 +580,8 @@ test "closure . closure == closure" $ sizeLimit $ \(x :: G) -> (closure . closure) x == closure x - test "postSet x (closure y) == Set.fromList (reachable x y)" $ sizeLimit $ \x (y :: G) -> - postSet x (closure y) == Set.fromList (reachable x y) + test "postSet x (closure y) == Set.fromList (reachable y x)" $ sizeLimit $ \x (y :: G) -> + postSet x (closure y) == Set.fromList (reachable y x) putStrLn $ "\n============ NonEmpty.AdjacencyMap.reflexiveClosure ============" test "reflexiveClosure (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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.NonEmpty.Graph --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -654,8 +654,8 @@ simplify (1 * 1 * 1) === (1 * 1 :: G) putStrLn "\n============ NonEmpty.Graph.sparsify ============" - test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> - (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y + test "sort . reachable x == sort . rights . reachable (sparsify x) . Right" $ \(x :: G) y -> + (sort . reachable x) y ==(sort . rights . reachable (sparsify x) . Right) y test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> vertexCount (sparsify x) <= vertexCount x + size x + 1 @@ -666,13 +666,13 @@ test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> size (sparsify x) <= 3 * size x - putStrLn "\n============ NonEmpty.Graph.sparsify ============" - test "sort . reachable k == sort . filter (<= n) . flip reachable k . sparsifyKL n" $ \(Positive n) -> do + putStrLn "\n============ NonEmpty.Graph.sparsifyKL ============" + test "sort . reachable x == sort . filter (<= n) . reachable (sparsifyKL n x)" $ \(Positive n) -> do let pairs = (,) <$> choose (1, n) <*> choose (1, n) - k <- choose (1, n) es <- listOf pairs let x = G.edges es `overlay1` vertices1 [1..n] - return $ (sort . reachable k) x == (sort . filter (<= n) . flip KL.reachable k . sparsifyKL n) x + y <- choose (1, n) + return $ (sort . reachable x) y == (sort . filter (<= n) . KL.reachable (sparsifyKL n x)) y test "length (vertices $ sparsifyKL n x) <= vertexCount x + size x + 1" $ \(Positive n) -> do let pairs = (,) <$> choose (1, n) <*> choose (1, n) 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-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/test/Algebra/Graph/Test/Relation/Symmetric.hs b/test/Algebra/Graph/Test/Relation/Symmetric.hs --- a/test/Algebra/Graph/Test/Relation/Symmetric.hs +++ b/test/Algebra/Graph/Test/Relation/Symmetric.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Relation.Symmetric --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.RewriteRules --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/test/Algebra/Graph/Test/Undirected.hs b/test/Algebra/Graph/Test/Undirected.hs --- a/test/Algebra/Graph/Test/Undirected.hs +++ b/test/Algebra/Graph/Test/Undirected.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Undirected --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Graph.Test.Typed --- Copyright : (c) Andrey Mokhov 2016-2022 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com -- Stability : experimental @@ -13,22 +13,26 @@ testTyped ) where -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyIntMap as AIM import Algebra.Graph.Test +import Algebra.Graph.AdjacencyMap ( forest, empty, vertex, edge, vertices + , isSubgraphOf, vertexList, hasVertex ) + import Data.Array (array) import Data.Graph.Typed import Data.Tree -import Data.List (nub, sort) +import Data.List (nub) import qualified Data.Graph as KL import qualified Data.IntSet as IntSet +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM + 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 +f % x = f (fromAdjacencyMap x) testTyped :: IO () testTyped = do @@ -68,93 +72,94 @@ putStrLn $ "\n============ Typed.dfsForest ============" test "forest (dfsForest % edge 1 1) == vertex 1" $ - AM.forest (dfsForest % AM.edge 1 1) == AM.vertex 1 + forest (dfsForest % edge 1 1) == vertex 1 test "forest (dfsForest % edge 1 2) == edge 1 2" $ - AM.forest (dfsForest % AM.edge 1 2) == AM.edge 1 2 + forest (dfsForest % edge 1 2) == edge 1 2 test "forest (dfsForest % edge 2 1) == vertices [1, 2]" $ - AM.forest (dfsForest % AM.edge 2 1) == AM.vertices [1, 2] + forest (dfsForest % edge 2 1) == vertices [1, 2] test "isSubgraphOf (forest $ dfsForest % x) x == True" $ \x -> - AM.isSubgraphOf (AM.forest $ dfsForest % x) x == True + isSubgraphOf (forest $ dfsForest % x) x == True test "dfsForest % forest (dfsForest % x) == dfsForest % x" $ \x -> - dfsForest % AM.forest (dfsForest % x) == dfsForest % x + dfsForest % forest (dfsForest % x) == dfsForest % x test "dfsForest % vertices vs == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> - dfsForest % AM.vertices vs == map (\v -> Node v []) (nub $ sort vs) + 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 = [] }]}] + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 3 + , subForest = [ Node { rootLabel = 4 + , subForest = [] }]}] putStrLn $ "\n============ Typed.dfsForestFrom ============" - test "forest (dfsForestFrom [1] % edge 1 1) == vertex 1" $ - AM.forest (dfsForestFrom [1] % AM.edge 1 1) == AM.vertex 1 + test "forest $ (dfsForestFrom % edge 1 1) [1] == vertex 1" $ + (forest $ (dfsForestFrom % edge 1 1) [1]) == vertex 1 - test "forest (dfsForestFrom [1] % edge 1 2) == edge 1 2" $ - AM.forest (dfsForestFrom [1] % AM.edge 1 2) == AM.edge 1 2 + test "forest $ (dfsForestFrom % edge 1 2) [0] == empty" $ + (forest $ (dfsForestFrom % edge 1 2) [0]) == empty - test "forest (dfsForestFrom [2] % edge 1 2) == vertex 2" $ - AM.forest (dfsForestFrom [2] % AM.edge 1 2) == AM.vertex 2 + test "forest $ (dfsForestFrom % edge 1 2) [1] == edge 1 2" $ + (forest $ (dfsForestFrom % edge 1 2) [1]) == edge 1 2 - test "forest (dfsForestFrom [3] % edge 1 2) == empty" $ - AM.forest (dfsForestFrom [3] % AM.edge 1 2) == AM.empty + test "forest $ (dfsForestFrom % edge 1 2) [2] == vertex 2" $ + (forest $ (dfsForestFrom % edge 1 2) [2]) == vertex 2 - test "forest (dfsForestFrom [2, 1] % edge 1 2) == vertices [1, 2]" $ - AM.forest (dfsForestFrom [2, 1] % AM.edge 1 2) == AM.vertices [1, 2] + test "forest $ (dfsForestFrom % edge 1 2) [2,1] == vertices [1,2]" $ + (forest $ (dfsForestFrom % edge 1 2) [2,1]) == vertices [1,2] - test "isSubgraphOf (forest $ dfsForestFrom vs % x) x == True" $ \vs x -> - AM.isSubgraphOf (AM.forest (dfsForestFrom vs % x)) x == True + test "isSubgraphOf (forest $ dfsForestFrom % x $ vs) x == True" $ \x vs -> + isSubgraphOf (forest $ dfsForestFrom % x $ vs) x == True - test "dfsForestFrom (vertexList x) % x == dfsForest % x" $ \x -> - dfsForestFrom (AM.vertexList x) % x == dfsForest % x + test "dfsForestFrom % x $ vertexList x == dfsForest % x" $ \x -> + (dfsForestFrom % x $ vertexList x) == dfsForest % x - test "dfsForestFrom vs % (AM.vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> - dfsForestFrom vs % AM.vertices vs == map (\v -> Node v []) (nub vs) + test "dfsForestFrom % vertices vs $ vs == map (\\v -> Node v []) (nub vs)" $ \vs -> + (dfsForestFrom % vertices vs $ vs) == map (\v -> Node v []) (nub vs) - test "dfsForestFrom [] % x == []" $ \x -> - dfsForestFrom [] % x == [] + 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 + test "dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4] == " $ + (dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4])== [ Node { rootLabel = 1 , subForest = [ Node { rootLabel = 5 , subForest = [] }]} , Node { rootLabel = 4 , subForest = [] }] putStrLn $ "\n============ Typed.dfs ============" - test "dfs [1] % edge 1 1 == [1]" $ - dfs [1] % AM.edge 1 1 == [1] + test "dfs % edge 1 1 $ [1] == [1]" $ + (dfs % edge 1 1 $ [1]) == [1] - test "dfs [1] % edge 1 2 == [1,2]" $ - dfs [1] % AM.edge 1 2 == [1,2] + test "dfs % edge 1 2 $ [0] == []" $ + (dfs % edge 1 2 $ [0]) == [] - test "dfs [2] % edge 1 2 == [2]" $ - dfs [2] % AM.edge 1 2 == [2] + test "dfs % edge 1 2 $ [1] == [1,2]" $ + (dfs % edge 1 2 $ [1]) == [1,2] - test "dfs [3] % edge 1 2 == []" $ - dfs [3] % AM.edge 1 2 == [] + test "dfs % edge 1 2 $ [2] == [2]" $ + (dfs % edge 1 2 $ [2]) == [2] - test "dfs [1, 2] % edge 1 2 == [1, 2]" $ - dfs [1, 2] % AM.edge 1 2 == [1, 2] + test "dfs % edge 1 2 $ [1,2] == [1,2]" $ + (dfs % edge 1 2 $ [1,2])== [1,2] - test "dfs [2, 1] % edge 1 2 == [2, 1]" $ - dfs [2, 1] % AM.edge 1 2 == [2, 1] + test "dfs % edge 1 2 $ [2,1] == [2,1]" $ + (dfs % edge 1 2 $ [2,1])== [2,1] - test "dfs [] % x == []" $ \x -> - dfs [] % x == [] + 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] + putStrLn "" + test "dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [1,5,4]" $ + (dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4]) == [1,5,4] - test "isSubgraphOf (vertices $ dfs vs % x) x == True" $ \vs x -> - AM.isSubgraphOf (AM.vertices $ dfs vs % x) x == True + test "and [ hasVertex v x | v <- dfs % x $ vs ] == True" $ \x vs -> + and [ hasVertex v x | v <- dfs % x $ vs ] == True putStrLn "\n============ Typed.topSort ============" test "topSort % (1 * 2 + 3 * 1) == [3,1,2]" $