├── Setup.hs ├── stack.yaml ├── .gitignore ├── .ghci ├── test ├── Algebra │ └── Graph │ │ ├── Test │ │ ├── Internal.hs │ │ ├── AdjacencyIntMap.hs │ │ ├── Relation.hs │ │ ├── Relation │ │ │ └── Symmetric.hs │ │ ├── Example │ │ │ └── Todo.hs │ │ ├── Undirected.hs │ │ ├── AdjacencyMap.hs │ │ ├── Label.hs │ │ ├── Graph.hs │ │ ├── Export.hs │ │ ├── Arbitrary.hs │ │ └── RewriteRules.hs │ │ └── Test.hs ├── Main.hs └── Data │ └── Graph │ └── Test │ └── Typed.hs ├── LICENSE ├── AUTHORS.md ├── .github └── workflows │ └── ci.yml ├── .hlint.yaml ├── src ├── Algebra │ └── Graph │ │ ├── Relation │ │ ├── Reflexive.hs │ │ ├── Transitive.hs │ │ └── Preorder.hs │ │ ├── Labelled │ │ └── Example │ │ │ ├── Network.hs │ │ │ └── Automaton.hs │ │ ├── Example │ │ └── Todo.hs │ │ ├── Internal.hs │ │ ├── Export.hs │ │ ├── Export │ │ └── Dot.hs │ │ ├── Class.hs │ │ ├── Label.hs │ │ ├── AdjacencyIntMap │ │ └── Algorithm.hs │ │ └── HigherKinded │ │ └── Class.hs └── Data │ └── Graph │ └── Typed.hs ├── README.md ├── CHANGES.md └── algebraic-graphs.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2025-03-01 # ghc-9.8.1 2 | 3 | ghc-options: 4 | '$everything': -haddock 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | .ghc.environment.* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | ghcid.txt 22 | .vscode/ 23 | *.swp 24 | *.swo 25 | *.swn 26 | .log 27 | stack.yaml.lock 28 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -Wall -fno-warn-name-shadowing -Wcompat 2 | :set -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 3 | :set -Wunused-binds -Wunused-imports -Worphans 4 | 5 | :set -isrc 6 | :set -itest 7 | 8 | :set -XFlexibleContexts 9 | :set -XFlexibleInstances 10 | :set -XGeneralizedNewtypeDeriving 11 | :set -XScopedTypeVariables 12 | :set -XTupleSections 13 | :set -XTypeFamilies 14 | 15 | :load Main Algebra.Graph.Labelled.Example.Automaton Algebra.Graph.Labelled.Example.Network 16 | 17 | :set prompt "\x03BB> " 18 | :set prompt-cont "\x03BB| " 19 | :!cls 20 | 21 | :{ 22 | :def alga \top -> return $ unlines $ 23 | [ ":set -XOverloadedLists" 24 | , ":set -XOverloadedStrings" 25 | , ":set -fno-warn-type-defaults" 26 | , ":m Algebra.Graph" ++ (if null top then "" else ".") ++ top 27 | , ":show imports" ] 28 | :} 29 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Test.Internal 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- Testsuite for "Algebra.Graph.Internal". 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Test.Internal ( 13 | -- * Testsuite 14 | testInternal 15 | ) where 16 | 17 | import Algebra.Graph.Internal 18 | import Algebra.Graph.Test 19 | 20 | testInternal :: IO () 21 | testInternal = do 22 | putStrLn "\n============ Internal.List ============" 23 | test "pure 1 <> pure 4 == [1, 4]" $ 24 | pure 1 <> pure 4 == ([1, 4] :: List Int) 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016-2025 Andrey Mokhov 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /AUTHORS.md: -------------------------------------------------------------------------------- 1 | The Alga library was originally developed by 2 | 3 | * [Andrey Mokhov](mailto:andrey.mokhov@gmail.com) [@snowleopard](https://github.com/snowleopard) 4 | 5 | but over time many contributors helped make it much better, including (among others): 6 | 7 | * [Vasily Alferov](mailto:vasily.v.alferov@gmail.com) [@vasalf](https://github.com/vasalf) 8 | * [Piotr Gawryś](mailto:pgawrys2@gmail.com) [@Avasil](https://github.com/Avasil) 9 | * [Alexandre Moine](mailto:alexandre@moine.me) [@nobrakal](https://github.com/nobrakal) 10 | * [Joseph Novakovich](mailto:jrn@bluefarm.ca) [@jitwit](https://github.com/jitwit) 11 | * [Adithya Obilisetty](mailto:adi.obilisetty@gmail.com) [@adithyaov](https://github.com/adithyaov) 12 | * [Armando Santos](mailto:armandoifsantos@gmail.com) [@bolt12](https://github.com/bolt12) 13 | 14 | If you are not on this list, it's not because your contributions are not 15 | appreciated, but because I didn't want to add your name and contact details 16 | without your consent. Please fix this by sending a PR, keeping the list 17 | alphabetical (sorted by last and then first name). 18 | 19 | Also see the autogenerated yet still possibly incomplete 20 | [list of contributors](https://github.com/snowleopard/alga/graphs/contributors). 21 | 22 | Thank you all for your help! 23 | Andrey 24 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | pull_request: 4 | schedule: 5 | - cron: '0 3 * * 6' # 3am Saturday 6 | workflow_dispatch: 7 | 8 | jobs: 9 | test: 10 | runs-on: ${{ matrix.os }} 11 | 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: [ubuntu-latest] 16 | ghc: ['9.8.2', '9.6.3', '9.4.7', '9.2.8', '9.0.2', '8.10.7'] 17 | include: 18 | - os: windows-latest 19 | # Testing on MacOS is disabled until GitHub actions support 'allow-failure' 20 | # - os: macOS-latest 21 | 22 | steps: 23 | - run: git config --global core.autocrlf false 24 | - uses: actions/checkout@v4 25 | - uses: haskell-actions/setup@v2 26 | id: setup-haskell 27 | with: 28 | ghc-version: ${{ matrix.ghc }} 29 | - name: Get GHC libdir 30 | id: get-ghc-libdir 31 | run: | 32 | echo "name=libdir::$(ghc --print-libdir)" >> $GITHUB_OUTPUT 33 | shell: bash 34 | - run: cabal v2-freeze --enable-tests 35 | - uses: actions/cache@v4 36 | with: 37 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 38 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ steps.get-ghc-libdir.outputs.libdir }}-${{ hashFiles('cabal.project.freeze') }} 39 | - uses: snowleopard/neil@master 40 | with: 41 | github-user: snowleopard 42 | hlint-arguments: src 43 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/AdjacencyIntMap.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Test.AdjacencyIntMap 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Testsuite for "Algebra.Graph.AdjacencyIntMap". 10 | ----------------------------------------------------------------------------- 11 | module Algebra.Graph.Test.AdjacencyIntMap ( 12 | -- * Testsuite 13 | testAdjacencyIntMap 14 | ) where 15 | 16 | import Algebra.Graph.AdjacencyIntMap 17 | import Algebra.Graph.Test 18 | import Algebra.Graph.Test.API (Mono (..), adjacencyIntMapAPI) 19 | import Algebra.Graph.Test.Generic 20 | 21 | import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap 22 | 23 | t :: TestsuiteInt (Mono AdjacencyIntMap) 24 | t = ("AdjacencyIntMap.", adjacencyIntMapAPI) 25 | 26 | testAdjacencyIntMap :: IO () 27 | testAdjacencyIntMap = do 28 | putStrLn "\n============ AdjacencyIntMap ============" 29 | test "Axioms of graphs" (axioms @AdjacencyIntMap) 30 | 31 | putStrLn $ "\n============ AdjacencyIntMap.fromAdjacencyMap ============" 32 | test "fromAdjacencyMap == stars . AdjacencyMap.adjacencyList" $ \x -> 33 | fromAdjacencyMap x == (stars . AdjacencyMap.adjacencyList) x 34 | 35 | testConsistent t 36 | testShow t 37 | testBasicPrimitives t 38 | testFromAdjacencyIntSets t 39 | testIsSubgraphOf t 40 | testToGraph t 41 | testGraphFamilies t 42 | testTransformations t 43 | testRelational t 44 | testBfsForest t 45 | testBfs t 46 | testDfsForest t 47 | testDfsForestFrom t 48 | testDfs t 49 | testReachable t 50 | testTopSort t 51 | testIsAcyclic t 52 | testIsDfsForestOf t 53 | testIsTopSortOf t 54 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Relation.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Test.Relation 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Testsuite for "Algebra.Graph.Relation". 10 | ----------------------------------------------------------------------------- 11 | module Algebra.Graph.Test.Relation ( 12 | -- * Testsuite 13 | testRelation 14 | ) where 15 | 16 | import Algebra.Graph.Relation 17 | import Algebra.Graph.Relation.Preorder 18 | import Algebra.Graph.Relation.Reflexive 19 | import Algebra.Graph.Relation.Transitive 20 | import Algebra.Graph.Test 21 | import Algebra.Graph.Test.API (toIntAPI, relationAPI) 22 | import Algebra.Graph.Test.Generic 23 | 24 | import qualified Algebra.Graph.Class as C 25 | 26 | tPoly :: Testsuite Relation Ord 27 | tPoly = ("Relation.", relationAPI) 28 | 29 | t :: TestsuiteInt Relation 30 | t = fmap toIntAPI tPoly 31 | 32 | type RI = Relation Int 33 | 34 | testRelation :: IO () 35 | testRelation = do 36 | putStrLn "\n============ Relation ============" 37 | test "Axioms of graphs" $ size10 $ axioms @RI 38 | 39 | testConsistent t 40 | testShow t 41 | testBasicPrimitives t 42 | testIsSubgraphOf t 43 | testToGraph t 44 | testGraphFamilies t 45 | testTransformations t 46 | testRelational t 47 | testInduceJust tPoly 48 | 49 | putStrLn "\n============ ReflexiveRelation ============" 50 | test "Axioms of reflexive graphs" $ size10 $ 51 | reflexiveAxioms @(ReflexiveRelation Int) 52 | 53 | putStrLn "\n============ TransitiveRelation ============" 54 | test "Axioms of transitive graphs" $ size10 $ 55 | transitiveAxioms @(TransitiveRelation Int) 56 | 57 | test "path xs == (clique xs :: TransitiveRelation Int)" $ size10 $ \xs -> 58 | C.path xs == (C.clique xs :: TransitiveRelation Int) 59 | 60 | putStrLn "\n============ PreorderRelation ============" 61 | test "Axioms of preorder graphs" $ size10 $ 62 | preorderAxioms @(PreorderRelation Int) 63 | 64 | test "path xs == (clique xs :: PreorderRelation Int)" $ size10 $ \xs -> 65 | C.path xs == (C.clique xs :: PreorderRelation Int) 66 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | # Specify additional command line arguments 9 | # 10 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 11 | 12 | # Control which extensions/flags/modules/functions can be used 13 | # 14 | # - extensions: 15 | # - default: false # all extension are banned by default 16 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 17 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 18 | # 19 | # - flags: 20 | # - {name: -w, within: []} # -w is allowed nowhere 21 | # 22 | # - modules: 23 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 24 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 25 | # 26 | # - functions: 27 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 28 | 29 | # Add custom hints for this project 30 | # 31 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 32 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 33 | 34 | # The hints are named by the string they display in warning messages. 35 | # For example, if you see a warning starting like 36 | # 37 | # Main.hs:116:51: Warning: Redundant == 38 | # 39 | # You can refer to that hint with `{name: Redundant ==}` (see below). 40 | 41 | # Turn on hints that are off by default 42 | # 43 | # Ban "module X(module X) where", to require a real export list 44 | # - warn: {name: Use explicit module export list} 45 | # 46 | # Replace a $ b $ c with a . b $ c 47 | # - group: {name: dollar, enabled: true} 48 | # 49 | # Generalise map to fmap, ++ to <> 50 | # - group: {name: generalise, enabled: true} 51 | 52 | # Ignore some builtin hints 53 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 54 | 55 | - ignore: 56 | name: Use if 57 | within: Algebra.Graph.Bipartite.AdjacencyMap.Algorithm 58 | 59 | - ignore: 60 | name: Avoid NonEmpty.unzip 61 | within: Algebra.Graph.NonEmpty.AdjacencyMap 62 | 63 | # Define some custom infix operators 64 | # - fixity: infixr 3 ~^#^~ 65 | 66 | # To generate a suitable file for HLint do: 67 | # $ hlint --default > .hlint.yaml 68 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | import Algebra.Graph.Test.Acyclic.AdjacencyMap 2 | import Algebra.Graph.Test.AdjacencyIntMap 3 | import Algebra.Graph.Test.AdjacencyMap 4 | import Algebra.Graph.Test.Bipartite.AdjacencyMap 5 | import Algebra.Graph.Test.Example.Todo 6 | import Algebra.Graph.Test.Export 7 | import Algebra.Graph.Test.Graph 8 | import Algebra.Graph.Test.Internal 9 | import Algebra.Graph.Test.Label 10 | import Algebra.Graph.Test.Labelled.AdjacencyMap 11 | import Algebra.Graph.Test.Labelled.Graph 12 | import Algebra.Graph.Test.NonEmpty.AdjacencyMap 13 | import Algebra.Graph.Test.NonEmpty.Graph 14 | import Algebra.Graph.Test.Relation 15 | import Algebra.Graph.Test.Relation.Symmetric 16 | import Algebra.Graph.Test.Undirected 17 | import Data.Graph.Test.Typed 18 | 19 | import Control.Monad 20 | import System.Environment 21 | 22 | -- | By default, all testsuites will be executed, which takes a few minutes. If 23 | -- you would like to execute only some specific testsuites, you can specify 24 | -- their names in the command line. For example: 25 | -- 26 | -- > stack test --test-arguments "Graph Symmetric.Relation" 27 | -- 28 | -- will test the modules "Algebra.Graph" and "Algebra.Graph.Symmetric.Relation". 29 | main :: IO () 30 | main = do 31 | selected <- getArgs 32 | let go current = when (null selected || current `elem` selected) 33 | go "Acyclic.AdjacencyMap" testAcyclicAdjacencyMap 34 | go "AdjacencyIntMap" testAdjacencyIntMap 35 | go "AdjacencyMap" testAdjacencyMap 36 | go "Bipartite.AdjacencyMap" testBipartiteAdjacencyMap 37 | go "Bipartite.AdjacencyMap.Algorithm" testBipartiteAdjacencyMapAlgorithm 38 | go "Export" testExport 39 | go "Graph" testGraph 40 | go "Internal" testInternal 41 | go "Label" testLabel 42 | go "Labelled.AdjacencyMap" testLabelledAdjacencyMap 43 | go "Labelled.Graph" testLabelledGraph 44 | go "NonEmpty.AdjacencyMap" testNonEmptyAdjacencyMap 45 | go "NonEmpty.Graph" testNonEmptyGraph 46 | go "Relation" testRelation 47 | go "Symmetric.Relation" testSymmetricRelation 48 | go "Todo" testTodo 49 | go "Typed" testTyped 50 | go "Undirected" testUndirected 51 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Relation/Reflexive.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Relation.Reflexive 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- An abstract implementation of reflexive binary relations. Use 10 | -- "Algebra.Graph.Class" for polymorphic construction and manipulation. 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Relation.Reflexive ( 13 | -- * Data structure 14 | ReflexiveRelation, fromRelation, toRelation 15 | ) where 16 | 17 | import Algebra.Graph.Relation 18 | import Control.DeepSeq 19 | import Data.String 20 | 21 | import qualified Algebra.Graph.Class as C 22 | 23 | {-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ 24 | over a set of elements. Reflexive relations satisfy all laws of the 25 | 'Reflexive' type class and, in particular, the /self-loop/ axiom: 26 | 27 | @'vertex' x == 'vertex' x * 'vertex' x@ 28 | 29 | The 'Show' instance produces reflexively closed expressions: 30 | 31 | @show (1 :: ReflexiveRelation Int) == "edge 1 1" 32 | show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ 33 | -} 34 | newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } 35 | deriving (IsString, NFData, Num) 36 | 37 | instance Ord a => Eq (ReflexiveRelation a) where 38 | x == y = toRelation x == toRelation y 39 | 40 | instance Ord a => Ord (ReflexiveRelation a) where 41 | compare x y = compare (toRelation x) (toRelation y) 42 | 43 | instance (Ord a, Show a) => Show (ReflexiveRelation a) where 44 | show = show . toRelation 45 | 46 | instance Ord a => C.Graph (ReflexiveRelation a) where 47 | type Vertex (ReflexiveRelation a) = a 48 | empty = ReflexiveRelation empty 49 | vertex = ReflexiveRelation . vertex 50 | overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y 51 | connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y 52 | 53 | instance Ord a => C.Reflexive (ReflexiveRelation a) 54 | 55 | -- | Construct a reflexive relation from a 'Relation'. 56 | -- Complexity: /O(1)/ time. 57 | fromRelation :: Relation a -> ReflexiveRelation a 58 | fromRelation = ReflexiveRelation 59 | 60 | -- | Extract the underlying relation. 61 | -- Complexity: /O(n*log(m))/ time. 62 | toRelation :: Ord a => ReflexiveRelation a -> Relation a 63 | toRelation = reflexiveClosure . fromReflexive 64 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Labelled/Example/Network.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Labelled.Example.Network 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 11 | -- in Haskell. See for the 12 | -- motivation behind the library, the underlying theory, and implementation details. 13 | -- 14 | -- This module contains a simple example of using edge-labelled graphs defined 15 | -- in the module "Algebra.Graph.Labelled" for working with networks, i.e. graphs 16 | -- whose edges are labelled with distances. 17 | ----------------------------------------------------------------------------- 18 | module Algebra.Graph.Labelled.Example.Network where 19 | 20 | import Algebra.Graph.Labelled 21 | 22 | -- | Our example networks have /cities/ as vertices. 23 | data City = Aberdeen 24 | | Edinburgh 25 | | Glasgow 26 | | London 27 | | Newcastle 28 | deriving (Bounded, Enum, Eq, Ord, Show) 29 | 30 | -- | For simplicity we measure /journey times/ in integer number of minutes. 31 | type JourneyTime = Int 32 | 33 | -- | A part of the EastCoast train network between 'Aberdeen' and 'London'. 34 | -- 35 | -- @ 36 | -- eastCoast = 'overlays' [ 'Aberdeen' '-<'150'>-' 'Edinburgh' 37 | -- , 'Edinburgh' '-<' 90'>-' 'Newcastle' 38 | -- , 'Newcastle' '-<'170'>-' 'London' ] 39 | -- @ 40 | eastCoast :: Network JourneyTime City 41 | eastCoast = overlays [ Aberdeen -<150>- Edinburgh 42 | , Edinburgh -< 90>- Newcastle 43 | , Newcastle -<170>- London ] 44 | 45 | -- | A part of the ScotRail train network between 'Aberdeen' and 'Glasgow'. 46 | -- 47 | -- @ 48 | -- scotRail = 'overlays' [ 'Aberdeen' '-<'140'>-' 'Edinburgh' 49 | -- , 'Edinburgh' '-<' 50'>-' 'Glasgow' 50 | -- , 'Edinburgh' '-<' 70'>-' 'Glasgow' ] 51 | -- @ 52 | scotRail :: Network JourneyTime City 53 | scotRail = overlays [ Aberdeen -<140>- Edinburgh 54 | , Edinburgh -< 50>- Glasgow 55 | , Edinburgh -< 70>- Glasgow ] 56 | 57 | -- TODO: Add an illustration. 58 | -- | An example train network. 59 | -- 60 | -- @ 61 | -- network = 'overlay' 'scotRail' 'eastCoast' 62 | -- @ 63 | network :: Network JourneyTime City 64 | network = overlay scotRail eastCoast 65 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Example/Todo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Algebra.Graph.Example.Todo ( 3 | -- * Creating and manipulating to-do lists 4 | Todo, todo, low, high, (~*~), (>*<), priority, 5 | 6 | -- * Examples 7 | shopping, holiday 8 | ) where 9 | 10 | -- Based on https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ 11 | 12 | import Data.Map (Map) 13 | import Data.String 14 | 15 | import Algebra.Graph.AdjacencyMap as AM 16 | import Algebra.Graph.AdjacencyMap.Algorithm as AM 17 | import Algebra.Graph.Class as C 18 | 19 | import qualified Data.Map as Map 20 | 21 | data Todo a = T (Map a Int) (AdjacencyMap a) deriving Show 22 | 23 | instance Ord a => Eq (Todo a) where 24 | x == y = todo x == todo y 25 | 26 | instance (IsString a, Ord a) => IsString (Todo a) where 27 | fromString = C.vertex . fromString 28 | 29 | -- Lower the priority of items in a given todo list 30 | low :: Todo a -> Todo a 31 | low (T p g) = T (Map.map (subtract 1) p) g 32 | 33 | -- Raise the priority of items in a given todo list 34 | high :: Todo a -> Todo a 35 | high (T p g) = T (Map.map (+1) p) g 36 | 37 | -- Specify exact priority of items in a given todo list (default 0) 38 | priority :: Int -> Todo a -> Todo a 39 | priority x (T p g) = T (Map.map (const x) p) g 40 | 41 | -- Pull the arguments together as close as possible 42 | (~*~) :: Ord a => Todo a -> Todo a -> Todo a 43 | x ~*~ y = low x `C.connect` high y 44 | 45 | -- Repel the arguments as far as possible 46 | (>*<) :: Ord a => Todo a -> Todo a -> Todo a 47 | x >*< y = high x `C.connect` low y 48 | 49 | todo :: forall a. Ord a => Todo a -> Maybe [a] 50 | todo (T p g) = case AM.topSort $ gmap prioritise g of 51 | Left _ -> Nothing 52 | Right xs -> Just $ map snd xs 53 | where 54 | prioritise :: a -> (Int, a) 55 | prioritise x = (negate $ Map.findWithDefault 0 x p, x) 56 | 57 | instance (IsString a, Ord a) => Num (Todo a) where 58 | fromInteger i = fromString $ show (fromInteger i :: Integer) 59 | (+) = C.overlay 60 | (*) = C.connect 61 | signum = const C.empty 62 | abs = id 63 | negate = id 64 | 65 | instance Ord a => Graph (Todo a) where 66 | type Vertex (Todo a) = a 67 | empty = T Map.empty AM.empty 68 | vertex x = T (Map.singleton x 0) (C.vertex x) 69 | overlay (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.overlay g1 g2) 70 | connect (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.connect g1 g2) 71 | 72 | -- λ> todo shopping 73 | -- Just ["coat","presents","phone wife","scarf"] 74 | shopping :: Todo String 75 | shopping = "presents" + "coat" + "phone wife" ~*~ "scarf" 76 | 77 | -- λ> todo holiday 78 | -- Just ["coat","presents","phone wife","scarf","pack","travel"] 79 | holiday :: Todo String 80 | holiday = shopping * "pack" * "travel" 81 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Relation/Symmetric.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Test.Relation.Symmetric 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Testsuite for "Algebra.Graph.Relation.Symmetric". 10 | ----------------------------------------------------------------------------- 11 | module Algebra.Graph.Test.Relation.Symmetric ( 12 | -- * Testsuite 13 | testSymmetricRelation 14 | ) where 15 | 16 | import Algebra.Graph.Relation.Symmetric 17 | import Algebra.Graph.Test 18 | import Algebra.Graph.Test.API (toIntAPI, symmetricRelationAPI) 19 | import Algebra.Graph.Test.Generic 20 | 21 | import qualified Algebra.Graph.Relation as R 22 | 23 | tPoly :: Testsuite Relation Ord 24 | tPoly = ("Symmetric.Relation.", symmetricRelationAPI) 25 | 26 | t :: TestsuiteInt Relation 27 | t = fmap toIntAPI tPoly 28 | 29 | type RI = R.Relation Int 30 | type SRI = Relation Int 31 | 32 | testSymmetricRelation :: IO () 33 | testSymmetricRelation = do 34 | putStrLn "\n============ Symmetric.Relation ============" 35 | test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @SRI 36 | 37 | testConsistent t 38 | testSymmetricShow t 39 | 40 | putStrLn $ "\n============ Symmetric.Relation.toSymmetric ============" 41 | test "toSymmetric (edge 1 2) == edge 1 2" $ 42 | toSymmetric (R.edge 1 2) == edge 1 (2 :: Int) 43 | 44 | test "toSymmetric . fromSymmetric == id" $ \(x :: SRI) -> 45 | (toSymmetric . fromSymmetric) x == id x 46 | 47 | test "fromSymmetric . toSymmetric == symmetricClosure" $ \(x :: RI) -> 48 | (fromSymmetric . toSymmetric) x == R.symmetricClosure x 49 | 50 | test "vertexCount . toSymmetric == vertexCount" $ \(x :: RI) -> 51 | vertexCount (toSymmetric x) == R.vertexCount x 52 | 53 | test "(*2) . edgeCount . toSymmetric >= edgeCount" $ \(x :: RI) -> 54 | ((*2) . edgeCount . toSymmetric) x >= R.edgeCount x 55 | 56 | putStrLn $ "\n============ Symmetric.Relation.fromSymmetric ============" 57 | test "fromSymmetric (edge 1 2) == edges [(1,2), (2,1)]" $ 58 | fromSymmetric (edge 1 2) == R.edges [(1,2), (2,1 :: Int)] 59 | 60 | test "vertexCount . fromSymmetric == vertexCount" $ \(x :: SRI) -> 61 | (R.vertexCount . fromSymmetric) x == vertexCount x 62 | 63 | test "edgeCount . fromSymmetric <= (*2) . edgeCount" $ \(x :: SRI) -> 64 | (R.edgeCount . fromSymmetric) x <= ((*2) . edgeCount) x 65 | 66 | testSymmetricBasicPrimitives t 67 | testSymmetricIsSubgraphOf t 68 | testSymmetricToGraph t 69 | testSymmetricGraphFamilies t 70 | testSymmetricTransformations t 71 | testInduceJust tPoly 72 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Relation/Transitive.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Relation.Transitive 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- An abstract implementation of transitive binary relations. Use 10 | -- "Algebra.Graph.Class" for polymorphic construction and manipulation. 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Relation.Transitive ( 13 | -- * Data structure 14 | TransitiveRelation, fromRelation, toRelation 15 | ) where 16 | 17 | import Algebra.Graph.Relation 18 | import Control.DeepSeq 19 | import Data.String 20 | 21 | import qualified Algebra.Graph.Class as C 22 | 23 | -- TODO: Optimise the implementation by caching the results of transitive closure. 24 | {-| The 'TransitiveRelation' data type represents a /transitive binary relation/ 25 | over a set of elements. Transitive relations satisfy all laws of the 26 | 'Transitive' type class and, in particular, the /closure/ axiom: 27 | 28 | @y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ 29 | 30 | For example, the following holds: 31 | 32 | @'path' xs == ('clique' xs :: TransitiveRelation Int)@ 33 | 34 | The 'Show' instance produces transitively closed expressions: 35 | 36 | @show (1 * 2 :: TransitiveRelation Int) == "edge 1 2" 37 | show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ 38 | -} 39 | newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } 40 | deriving (IsString, NFData, Num) 41 | 42 | instance Ord a => Eq (TransitiveRelation a) where 43 | x == y = toRelation x == toRelation y 44 | 45 | instance Ord a => Ord (TransitiveRelation a) where 46 | compare x y = compare (toRelation x) (toRelation y) 47 | 48 | instance (Ord a, Show a) => Show (TransitiveRelation a) where 49 | show = show . toRelation 50 | 51 | -- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 52 | instance Ord a => C.Graph (TransitiveRelation a) where 53 | type Vertex (TransitiveRelation a) = a 54 | empty = TransitiveRelation empty 55 | vertex = TransitiveRelation . vertex 56 | overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y 57 | connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y 58 | 59 | instance Ord a => C.Transitive (TransitiveRelation a) 60 | 61 | -- | Construct a transitive relation from a 'Relation'. 62 | -- Complexity: /O(1)/ time. 63 | fromRelation :: Relation a -> TransitiveRelation a 64 | fromRelation = TransitiveRelation 65 | 66 | -- | Extract the underlying relation. 67 | -- Complexity: /O(n * m * log(m))/ time. 68 | toRelation :: Ord a => TransitiveRelation a -> Relation a 69 | toRelation = transitiveClosure . fromTransitive 70 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Relation/Preorder.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Relation.Preorder 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- An abstract implementation of preorder relations. Use "Algebra.Graph.Class" 10 | -- for polymorphic construction and manipulation. 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Relation.Preorder ( 13 | -- * Data structure 14 | PreorderRelation, fromRelation, toRelation 15 | ) where 16 | 17 | import Algebra.Graph.Relation 18 | import Control.DeepSeq 19 | import Data.String 20 | 21 | import qualified Algebra.Graph.Class as C 22 | 23 | -- TODO: Optimise the implementation by caching the results of preorder closure. 24 | {-| The 'PreorderRelation' data type represents a 25 | /binary relation that is both reflexive and transitive/. Preorders satisfy all 26 | laws of the 'Preorder' type class and, in particular, the /self-loop/ axiom: 27 | 28 | @'vertex' x == 'vertex' x * 'vertex' x@ 29 | 30 | and the /closure/ axiom: 31 | 32 | @y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ 33 | 34 | For example, the following holds: 35 | 36 | @'path' xs == ('clique' xs :: PreorderRelation Int)@ 37 | 38 | The 'Show' instance produces reflexively and transitively closed expressions: 39 | 40 | @show (1 :: PreorderRelation Int) == "edge 1 1" 41 | show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]" 42 | show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ 43 | -} 44 | newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } 45 | deriving (IsString, NFData, Num) 46 | 47 | instance (Ord a, Show a) => Show (PreorderRelation a) where 48 | show = show . toRelation 49 | 50 | instance Ord a => Eq (PreorderRelation a) where 51 | x == y = toRelation x == toRelation y 52 | 53 | instance Ord a => Ord (PreorderRelation a) where 54 | compare x y = compare (toRelation x) (toRelation y) 55 | 56 | -- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 57 | instance Ord a => C.Graph (PreorderRelation a) where 58 | type Vertex (PreorderRelation a) = a 59 | empty = PreorderRelation empty 60 | vertex = PreorderRelation . vertex 61 | overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y 62 | connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y 63 | 64 | instance Ord a => C.Reflexive (PreorderRelation a) 65 | instance Ord a => C.Transitive (PreorderRelation a) 66 | instance Ord a => C.Preorder (PreorderRelation a) 67 | 68 | -- | Construct a preorder relation from a 'Relation'. 69 | -- Complexity: /O(1)/ time. 70 | fromRelation :: Relation a -> PreorderRelation a 71 | fromRelation = PreorderRelation 72 | 73 | -- | Extract the underlying relation. 74 | -- Complexity: /O(n * m * log(m))/ time. 75 | toRelation :: Ord a => PreorderRelation a -> Relation a 76 | toRelation = closure . fromPreorder 77 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Labelled/Example/Automaton.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists, TypeFamilies #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Labelled.Example.Automaton 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 11 | -- in Haskell. See for the 12 | -- motivation behind the library, the underlying theory, and implementation details. 13 | -- 14 | -- This module contains a simple example of using edge-labelled graphs defined 15 | -- in the module "Algebra.Graph.Labelled" for working with finite automata. 16 | ----------------------------------------------------------------------------- 17 | module Algebra.Graph.Labelled.Example.Automaton where 18 | 19 | import Control.Arrow ((&&&)) 20 | import Data.Map (Map) 21 | import Data.Monoid (Any (..)) 22 | 23 | import Algebra.Graph.Label 24 | import Algebra.Graph.Labelled 25 | import Algebra.Graph.ToGraph 26 | 27 | import qualified Data.Map as Map 28 | 29 | -- | The alphabet of actions for ordering coffee or tea. 30 | data Alphabet = Coffee -- ^ Order coffee 31 | | Tea -- ^ Order tea 32 | | Cancel -- ^ Cancel payment or order 33 | | Pay -- ^ Pay for the order 34 | deriving (Bounded, Enum, Eq, Ord, Show) 35 | 36 | -- | The state of the order. 37 | data State = Choice -- ^ Choosing what to order 38 | | Payment -- ^ Making the payment 39 | | Complete -- ^ The order is complete 40 | deriving (Bounded, Enum, Eq, Ord, Show) 41 | 42 | -- TODO: Add an illustration. 43 | -- | An example automaton for ordering coffee or tea. 44 | -- 45 | -- @ 46 | -- coffeeTeaAutomaton = 'overlays' [ 'Choice' '-<'['Coffee', 'Tea']'>-' 'Payment' 47 | -- , 'Payment' '-<'['Pay' ]'>-' 'Complete' 48 | -- , 'Choice' '-<'['Cancel' ]'>-' 'Complete' 49 | -- , 'Payment' '-<'['Cancel' ]'>-' 'Choice' ] 50 | -- @ 51 | coffeeTeaAutomaton :: Automaton Alphabet State 52 | coffeeTeaAutomaton = overlays [ Choice -<[Coffee, Tea]>- Payment 53 | , Payment -<[Pay ]>- Complete 54 | , Choice -<[Cancel ]>- Complete 55 | , Payment -<[Cancel ]>- Choice ] 56 | 57 | -- | The map of 'State' reachability. 58 | -- 59 | -- @ 60 | -- reachability = Map.'Map.fromList' $ map ('id' '&&&' 'reachable' skeleton) ['Choice' ..] 61 | -- where 62 | -- skeleton = emap (Any . not . 'isZero') coffeeTeaAutomaton 63 | -- @ 64 | -- 65 | -- Or, when evaluated: 66 | -- 67 | -- @ 68 | -- reachability = Map.'Map.fromList' [ ('Choice' , ['Choice' , 'Payment', 'Complete']) 69 | -- , ('Payment' , ['Payment' , 'Choice' , 'Complete']) 70 | -- , ('Complete', ['Complete' ]) ] 71 | -- @ 72 | reachability :: Map State [State] 73 | reachability = Map.fromList $ map (id &&& reachable skeleton) [Choice ..] 74 | where 75 | skeleton :: Graph Any State 76 | skeleton = emap (Any . not . isZero) coffeeTeaAutomaton 77 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Example/Todo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Algebra.Graph.Test.Example.Todo ( 4 | testTodo 5 | ) where 6 | 7 | import Algebra.Graph.Class 8 | import Algebra.Graph.Test 9 | import Algebra.Graph.Example.Todo 10 | 11 | testTodo :: IO () 12 | testTodo = do 13 | putStrLn "\n============ Example.Todo (Holiday) ============" 14 | test "A todo list is semantically Maybe [a]" $ 15 | todo ("presents" :: Todo String) == Just ["presents"] 16 | 17 | test "The overlay operator (+) adds non-dependent items to the todo list" $ 18 | todo ("coat" + "presents" :: Todo String) == Just ["coat", "presents"] 19 | 20 | test "The connect operator (*) adds dependency between items" $ 21 | let 22 | shopping :: Todo String = "presents" + "coat" + "scarf" 23 | holiday :: Todo String = shopping * "pack" * "travel" 24 | in todo (holiday + "scarf" * "coat") 25 | == Just ["presents","scarf","coat", "pack","travel"] 26 | 27 | test "Contradictory constraints make the todo list impossible to schedule" $ 28 | let 29 | shopping :: Todo String = "presents" + "coat" + "scarf" 30 | holiday :: Todo String = shopping * "pack" * "travel" 31 | in todo (holiday + "travel" * "presents") == Nothing 32 | 33 | test "Introduce item priority to schedule the todo list" $ 34 | let 35 | shopping :: Todo String 36 | shopping = "presents" + "coat" + low "phone wife" * "scarf" 37 | holiday :: Todo String 38 | holiday = shopping * "pack" * "travel" + "scarf" * "coat" 39 | in todo holiday 40 | == Just ["presents","phone wife","scarf","coat","pack","travel"] 41 | 42 | test "Custom connect operators pull/repel arguments during scheduling" $ 43 | let 44 | shopping :: Todo String 45 | shopping = "presents" + "coat" + "phone wife" ~*~ "scarf" 46 | holiday :: Todo String 47 | holiday = shopping * "pack" * "travel" + "scarf" * "coat" 48 | in todo holiday 49 | == Just ["presents","phone wife","scarf","coat","pack","travel"] 50 | 51 | putStrLn "\n============ Example.Todo (Commandline) ============" 52 | test "The pull connect operator maintains command line semantics" $ 53 | let 54 | cmdl :: Todo String 55 | cmdl = "gcc" * ("-c" ~*~ "src.c" + "-o" ~*~ "src.o") 56 | in todo cmdl == Just ["gcc","-c","src.c","-o","src.o"] 57 | 58 | test "Swapping flags are allowed by the commutative overlay opeartor" $ 59 | let 60 | cmdl1 :: Todo String 61 | cmdl1 = "gcc" * ("-c" ~*~ "src.c" + "-o" ~*~ "src.o") 62 | cmdl2 :: Todo String 63 | cmdl2 = "gcc" * ("-o" ~*~ "src.o" + "-c" ~*~ "src.c") 64 | in cmdl1 == cmdl2 65 | 66 | test "The usual connect operator breaks semantics" $ 67 | let 68 | cmdl :: Todo String 69 | cmdl = "gcc" * ("-c" * "src.c" + "-o" * "src.o") 70 | in 71 | todo cmdl == Just ["gcc","-c","-o","src.c","src.o"] 72 | 73 | test "Transform command lines by adding optimisation flag" $ 74 | let 75 | cmdl :: Todo String 76 | cmdl = "gcc" * ("-c" ~*~ "src.c" + "-o" ~*~ "src.o") 77 | optimise :: Int -> Todo String -> Todo String 78 | optimise level = (* flag) 79 | where flag = vertex $ "-O" ++ show level 80 | in todo (optimise 2 cmdl) == 81 | Just ["gcc","-c","src.c","-o","src.o","-O2"] 82 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Undirected.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Test.Undirected 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Testsuite for "Algebra.Graph.Undirected". 10 | ----------------------------------------------------------------------------- 11 | module Algebra.Graph.Test.Undirected ( 12 | -- * Testsuite 13 | testUndirected 14 | ) where 15 | 16 | import Algebra.Graph.Undirected 17 | import Algebra.Graph.Test 18 | import Algebra.Graph.Test.API (toIntAPI, undirectedGraphAPI) 19 | import Algebra.Graph.Test.Generic 20 | 21 | import qualified Algebra.Graph as G 22 | import qualified Algebra.Graph.Undirected as U 23 | 24 | tPoly :: Testsuite Graph Ord 25 | tPoly = ("Graph.Undirected.", undirectedGraphAPI) 26 | 27 | t :: TestsuiteInt Graph 28 | t = fmap toIntAPI tPoly 29 | 30 | type G = Graph Int 31 | type UGI = U.Graph Int 32 | type AGI = G.Graph Int 33 | 34 | testUndirected :: IO () 35 | testUndirected = do 36 | putStrLn "\n============ Graph.Undirected ============" 37 | test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @G 38 | 39 | testSymmetricShow t 40 | 41 | putStrLn $ "\n============ Graph.Undirected.toUndirected ============" 42 | test "toUndirected (edge 1 2) == edge 1 2" $ 43 | toUndirected (G.edge 1 2) == edge 1 (2 :: Int) 44 | 45 | test "toUndirected . fromUndirected == id" $ \(x :: G) -> 46 | (toUndirected . fromUndirected) x == id x 47 | 48 | test "vertexCount . toUndirected == vertexCount" $ \(x :: AGI) -> 49 | vertexCount (toUndirected x) == G.vertexCount x 50 | 51 | test "(*2) . edgeCount . toUndirected >= edgeCount" $ \(x :: AGI) -> 52 | ((*2) . edgeCount . toUndirected) x >= G.edgeCount x 53 | 54 | putStrLn $ "\n============ Graph.Undirected.fromUndirected ============" 55 | test "fromUndirected (edge 1 2) == edges [(1,2),(2,1)]" $ 56 | fromUndirected (edge 1 2) == G.edges [(1,2), (2,1 :: Int)] 57 | 58 | test "toUndirected . fromUndirected == id" $ \(x :: G) -> 59 | (toUndirected . fromUndirected) x == id x 60 | 61 | test "vertexCount . fromUndirected == vertexCount" $ \(x :: G) -> 62 | (G.vertexCount . fromUndirected) x == vertexCount x 63 | 64 | test "edgeCount . fromUndirected <= (*2) . edgeCount" $ \(x :: G) -> 65 | (G.edgeCount . fromUndirected) x <= ((*2) . edgeCount) x 66 | 67 | putStrLn $ "\n============ Graph.Undirected.complement ================" 68 | test "complement empty == empty" $ 69 | complement (empty :: UGI) == empty 70 | 71 | test "complement (vertex x) == vertex x" $ \x -> 72 | complement (vertex x :: UGI) == vertex x 73 | 74 | test "complement (edge 1 1) == edge 1 1" $ 75 | complement (edge 1 1) == edge 1 (1 :: Int) 76 | 77 | test "complement (edge 1 2) == vertices [1, 2]" $ 78 | complement (edge 1 2 :: UGI) == vertices [1, 2] 79 | 80 | test "complement (star 1 [2, 3]) == overlay (vertex 1) (edge 2 3)" $ 81 | complement (star 1 [2, 3]) == overlay (vertex 1) (edge 2 3 :: UGI) 82 | 83 | test "complement . complement == id" $ \(x :: UGI) -> 84 | (complement . complement $ x) == x 85 | 86 | testSymmetricBasicPrimitives t 87 | testSymmetricIsSubgraphOf t 88 | testSymmetricGraphFamilies t 89 | testSymmetricTransformations t 90 | testInduceJust tPoly 91 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/AdjacencyMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Test.AdjacencyMap 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- Testsuite for "Algebra.Graph.AdjacencyMap". 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Test.AdjacencyMap ( 13 | -- * Testsuite 14 | testAdjacencyMap 15 | ) where 16 | 17 | import Data.List.NonEmpty 18 | 19 | import Algebra.Graph.AdjacencyMap 20 | import Algebra.Graph.AdjacencyMap.Algorithm 21 | import Algebra.Graph.Test 22 | import Algebra.Graph.Test.API (toIntAPI, adjacencyMapAPI) 23 | import Algebra.Graph.Test.Generic 24 | 25 | import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty 26 | import qualified Data.Graph.Typed as KL 27 | 28 | tPoly :: Testsuite AdjacencyMap Ord 29 | tPoly = ("AdjacencyMap.", adjacencyMapAPI) 30 | 31 | t :: TestsuiteInt AdjacencyMap 32 | t = fmap toIntAPI tPoly 33 | 34 | type AI = AdjacencyMap Int 35 | 36 | testAdjacencyMap :: IO () 37 | testAdjacencyMap = do 38 | putStrLn "\n============ AdjacencyMap ============" 39 | test "Axioms of graphs" (axioms @AI) 40 | 41 | testConsistent t 42 | testShow t 43 | testBasicPrimitives t 44 | testFromAdjacencySets t 45 | testIsSubgraphOf t 46 | testToGraph t 47 | testGraphFamilies t 48 | testTransformations t 49 | testRelational t 50 | testBox tPoly 51 | testBfsForest t 52 | testBfs t 53 | testDfsForest t 54 | testDfsForestFrom t 55 | testDfs t 56 | testReachable t 57 | testTopSort t 58 | testIsAcyclic t 59 | testIsDfsForestOf t 60 | testIsTopSortOf t 61 | testInduceJust tPoly 62 | 63 | putStrLn "\n============ AdjacencyMap.scc ============" 64 | test "scc empty == empty" $ 65 | scc (empty :: AI) == empty 66 | 67 | test "scc (vertex x) == vertex (NonEmpty.vertex x)" $ \(x :: Int) -> 68 | scc (vertex x) == vertex (NonEmpty.vertex x) 69 | 70 | test "scc (vertices xs) == vertices (map NonEmpty.vertex xs)" $ \(xs :: [Int]) -> 71 | scc (vertices xs) == vertices (Prelude.map NonEmpty.vertex xs) 72 | 73 | test "scc (edge 1 1) == vertex (NonEmpty.edge 1 1)" $ 74 | scc (edge 1 1 :: AI) == vertex (NonEmpty.edge 1 1) 75 | 76 | test "scc (edge 1 2) == edge (NonEmpty.vertex 1) (NonEmpty.vertex 2)" $ 77 | scc (edge 1 2 :: AI) == edge (NonEmpty.vertex 1) (NonEmpty.vertex 2) 78 | 79 | test "scc (circuit (1:xs)) == vertex (NonEmpty.circuit1 (1 :| xs))" $ \(xs :: [Int]) -> 80 | scc (circuit (1:xs)) == vertex (NonEmpty.circuit1 (1 :| xs)) 81 | 82 | test "scc (3 * 1 * 4 * 1 * 5) == " $ 83 | scc (3 * 1 * 4 * 1 * 5) == edges [ (NonEmpty.vertex 3 , NonEmpty.vertex 5 ) 84 | , (NonEmpty.vertex 3 , NonEmpty.clique1 [1,4,1]) 85 | , (NonEmpty.clique1 [1,4,1], NonEmpty.vertex (5 :: Int)) ] 86 | 87 | test "isAcyclic . scc == const True" $ \(x :: AI) -> 88 | (isAcyclic . scc) x == (const True) x 89 | 90 | test "isAcyclic x == (scc x == gmap NonEmpty.vertex x)" $ \(x :: AI) -> 91 | isAcyclic x == (scc x == gmap NonEmpty.vertex x) 92 | 93 | test "scc g == KL.scc g" $ \(g :: AI) -> 94 | scc g == KL.scc g 95 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Test 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Basic testsuite infrastructure. 10 | ----------------------------------------------------------------------------- 11 | module Algebra.Graph.Test ( 12 | module Data.List, 13 | module Data.List.Extra, 14 | module Test.QuickCheck, 15 | module Test.QuickCheck.Function, 16 | 17 | GraphTestsuite, (//), axioms, theorems, undirectedAxioms, reflexiveAxioms, 18 | transitiveAxioms, preorderAxioms, size10, test 19 | ) where 20 | 21 | import Data.List (sort) 22 | import Data.List.Extra (nubOrd) 23 | import Prelude hiding ((+), (*)) 24 | import System.Exit (exitFailure) 25 | import Test.QuickCheck hiding ((===)) 26 | import Test.QuickCheck.Function 27 | 28 | import Algebra.Graph.Class 29 | import Algebra.Graph.Test.Arbitrary () 30 | 31 | -- | Test a property only on small (at most size 10) inputs. 32 | size10 :: Testable prop => prop -> Property 33 | size10 = mapSize (min 10) 34 | 35 | test :: Testable a => String -> a -> IO () 36 | test str p = do 37 | result <- quickCheckWithResult (stdArgs { chatty = False }) p 38 | if isSuccess result 39 | then putStrLn $ "OK: " ++ str 40 | else do 41 | putStrLn $ "\nTest failure:\n " ++ str ++ "\n" 42 | putStrLn $ output result 43 | exitFailure 44 | 45 | (+) :: Graph g => g -> g -> g 46 | (+) = overlay 47 | 48 | (*) :: Graph g => g -> g -> g 49 | (*) = connect 50 | 51 | (//) :: Testable prop => prop -> String -> Property 52 | p // s = label s $ counterexample ("Failed when checking '" ++ s ++ "'") p 53 | 54 | infixl 1 // 55 | infixl 6 + 56 | infixl 7 * 57 | 58 | type GraphTestsuite g = (Ord g, Graph g) => g -> g -> g -> Property 59 | 60 | axioms :: GraphTestsuite g 61 | axioms x y z = conjoin 62 | [ x + y == y + x // "Overlay commutativity" 63 | , x + (y + z) == (x + y) + z // "Overlay associativity" 64 | , empty * x == x // "Left connect identity" 65 | , x * empty == x // "Right connect identity" 66 | , x * (y * z) == (x * y) * z // "Connect associativity" 67 | , x * (y + z) == x * y + x * z // "Left distributivity" 68 | , (x + y) * z == x * z + y * z // "Right distributivity" 69 | , x * y * z == x * y + x * z + y * z // "Decomposition" ] 70 | 71 | theorems :: GraphTestsuite g 72 | theorems x y z = conjoin 73 | [ x + empty == x // "Overlay identity" 74 | , x + x == x // "Overlay idempotence" 75 | , x + y + x * y == x * y // "Absorption" 76 | , x * y * z == x * y + x * z + y * z 77 | + x + y + z + empty // "Full decomposition" 78 | , x * x == x * x * x // "Connect saturation" 79 | , empty <= x // "Lower bound" 80 | , x <= x + y // "Overlay order" 81 | , x + y <= x * y // "Overlay-connect order" ] 82 | 83 | undirectedAxioms :: GraphTestsuite g 84 | undirectedAxioms x y z = conjoin 85 | [ axioms x y z 86 | , x * y == y * x // "Connect commutativity" ] 87 | 88 | reflexiveAxioms :: forall g. (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g 89 | reflexiveAxioms x y z = conjoin 90 | [ axioms x y z 91 | , forAll arbitrary (\v -> vertex @g v == vertex v * vertex v) // "Vertex self-loop" ] 92 | 93 | transitiveAxioms :: GraphTestsuite g 94 | transitiveAxioms x y z = conjoin 95 | [ axioms x y z 96 | , y == empty || x * y * z == x * y + y * z // "Closure" ] 97 | 98 | preorderAxioms :: forall g. (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g 99 | preorderAxioms x y z = conjoin 100 | [ axioms x y z 101 | , forAll arbitrary (\v -> vertex @g v == vertex v * vertex v) // "Vertex self-loop" 102 | , y == empty || x * y * z == x * y + y * z // "Closure" ] 103 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Algebraic graphs 2 | 3 | [![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) 4 | 5 | **Alga** is a library for algebraic construction and manipulation of graphs in Haskell. See 6 | [this Haskell Symposium paper](https://github.com/snowleopard/alga-paper) and the 7 | corresponding [talk](https://www.youtube.com/watch?v=EdQGLewU-8k) for the motivation 8 | behind the library, the underlying theory and implementation details. There is also a 9 | [Haskell eXchange talk](https://skillsmatter.com/skillscasts/10635-algebraic-graphs), 10 | and a [tutorial](https://nobrakal.github.io/alga-tutorial) by Alexandre Moine. 11 | 12 | ## Main idea 13 | 14 | Consider the following data type, which is defined in the top-level module 15 | [Algebra.Graph](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph.html) 16 | of the library: 17 | 18 | ```haskell 19 | data Graph a = Empty | Vertex a | Overlay (Graph a) (Graph a) | Connect (Graph a) (Graph a) 20 | ``` 21 | 22 | We can give the following semantics to the constructors in terms of the pair **(V, E)** of graph *vertices* and *edges*: 23 | 24 | * `Empty` constructs the empty graph **(∅, ∅)**. 25 | * `Vertex x` constructs a graph containing a single vertex, i.e. **({x}, ∅)**. 26 | * `Overlay x y` overlays graphs **(Vx, Ex)** and **(Vy, Ey)** constructing **(Vx ∪ Vy, Ex ∪ Ey)**. 27 | * `Connect x y` connects graphs **(Vx, Ex)** and **(Vy, Ey)** constructing **(Vx ∪ Vy, Ex ∪ Ey ∪ Vx × Vy)**. 28 | 29 | Alternatively, we can give an algebraic semantics to the above graph construction primitives by defining the following 30 | type class and specifying a set of laws for its instances (see module [Algebra.Graph.Class](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Class.html)): 31 | 32 | ```haskell 33 | class Graph g where 34 | type Vertex g 35 | empty :: g 36 | vertex :: Vertex g -> g 37 | overlay :: g -> g -> g 38 | connect :: g -> g -> g 39 | ``` 40 | 41 | The laws of the type class are remarkably similar to those of a [semiring](https://en.wikipedia.org/wiki/Semiring), 42 | so we use `+` and `*` as convenient shortcuts for `overlay` and `connect`, respectively: 43 | 44 | * (`+`, `empty`) is an idempotent commutative monoid. 45 | * (`*`, `empty`) is a monoid. 46 | * `*` distributes over `+`, that is: `x * (y + z) == x * y + x * z` and `(x + y) * z == x * z + y * z`. 47 | * `*` can be decomposed: `x * y * z == x * y + x * z + y * z`. 48 | 49 | This algebraic structure corresponds to *unlabelled directed graphs*: every expression represents a graph, and every 50 | graph can be represented by an expression. Other types of graphs (e.g. undirected) can be obtained by modifying the 51 | above set of laws. Algebraic graphs provide a convenient, safe and powerful interface for working with graphs in Haskell, 52 | and allow the application of equational reasoning for proving the correctness of graph algorithms. 53 | 54 | To represent *non-empty graphs*, we can drop the `Empty` constructor -- see module 55 | [Algebra.Graph.NonEmpty](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty.html). 56 | 57 | To represent *edge-labelled graphs*, we can switch to the following data type, as 58 | explained in my [Haskell eXchange 2018 talk](https://skillsmatter.com/skillscasts/12361-labelled-algebraic-graphs): 59 | 60 | ```haskell 61 | data Graph e a = Empty 62 | | Vertex a 63 | | Connect e (Graph e a) (Graph e a) 64 | ``` 65 | 66 | Here `e` is the type of edge labels. If `e` is a monoid `(<+>, zero)` then graph overlay can be recovered 67 | as `Connect zero`, and `<+>` corresponds to *parallel composition* of edge labels. 68 | 69 | ## How fast is the library? 70 | 71 | Alga can handle graphs comprising millions of vertices and billions of edges in a matter of seconds, which is fast 72 | enough for many applications. We believe there is a lot of potential for improving the performance of the library, and 73 | this is one of our top priorities. If you come across a performance issue when using the library, please let us know. 74 | 75 | Some preliminary benchmarks can be found [here](https://github.com/haskell-perf/graphs). 76 | 77 | ## Blog posts 78 | 79 | The development of the library has been documented in the series of blog posts: 80 | * Introduction: https://blogs.ncl.ac.uk/andreymokhov/an-algebra-of-graphs/ 81 | * A few different flavours of the algebra: https://blogs.ncl.ac.uk/andreymokhov/graphs-a-la-carte/ 82 | * Graphs in disguise or How to plan you holiday using Haskell: https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ 83 | * Old graphs from new types: https://blogs.ncl.ac.uk/andreymokhov/old-graphs-from-new-types/ 84 | 85 | ## Algebraic graphs in other languages 86 | 87 | Algebraic graphs were implemented in a few other languages, including 88 | [Agda](http://github.com/algebraic-graphs/agda), 89 | [F#](https://github.com/algebraic-graphs/fsharp), 90 | [Scala](http://github.com/algebraic-graphs/scala) and 91 | [TypeScript](https://github.com/algebraic-graphs/typescript). 92 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Change log 2 | 3 | ## 0.8 4 | 5 | * #305, #312: Support GHC 9.4, GHC 9.6 and GHC 9.8. 6 | * #303, #314: Stop supporting GHC 8.4, GHC 8.6 and GHC 8.8. 7 | 8 | ## 0.7 9 | 10 | * #294: Change the argument order of `bfs*`, `dfs*` and `reachable` algorithms. 11 | * #293: Fix the `ToGraph` instance of symmetric relations. 12 | 13 | ## 0.6.1 14 | 15 | * Drop dependency on `mtl`. 16 | 17 | ## 0.6 18 | 19 | * #276: Add `Monoid` and `Semigroup` instances. 20 | * #278: Stop supporting GHC 8.0 and GHC 8.2. 21 | * #274, #277: Expand the API and add algorithms for bipartite graphs, drop the 22 | `Undirected` component in `Bipartite.Undirected.AdjacencyMap`. 23 | * #273: Add attribute quoting style to `Export.Dot`. 24 | * #259: Allow newer QuickCheck. 25 | * #257: Add `IsString` instances. 26 | * #226: Expand the API of `Bipartite.Undirected.AdjacencyMap`. 27 | 28 | ## 0.5 29 | 30 | * #217, #224, #227, #234, #235: Add new BFS, DFS, topological sort, and SCC 31 | algorithms for adjacency maps. 32 | * #228, #247, #254: Improve algebraic graph fusion. 33 | * #207, #218, #255: Add `Bipartite.Undirected.AdjacencyMap`. 34 | * #220, #237, #255: Add `Algebra.Graph.Undirected`. 35 | * #203, #215, #223: Add `Acyclic.AdjacencyMap`. 36 | * #202, #209, #211: Add `induceJust` and `induceJust1`. 37 | * #172, #245: Stop supporting GHC 7.8 and GHC 7.10. 38 | * #208: Add `fromNonEmpty` to `NonEmpty.AdjacencyMap`. 39 | * #208: Add `fromAdjacencyMap` to `AdjacencyIntMap`. 40 | * #208: Drop `Internal` modules for `AdjacencyIntMap`, `AdjacencyMap`, 41 | `Labelled.AdjacencyMap`, `NonEmpty.AdjacencyMap`, `Relation` and 42 | `Relation.Symmetric`. 43 | * #206: Add `Algebra.Graph.AdjacencyMap.box`. 44 | * #205: Drop dependencies on `base-compat` and `base-orphans`. 45 | * #205: Remove `Algebra.Graph.Fold`. 46 | * #151: Remove `ToGraph.size`. Demote `ToGraph.adjacencyMap`, 47 | `ToGraph.adjacencyIntMap`, `ToGraph.adjacencyMapTranspose` and 48 | `ToGraph.adjacencyIntMapTranspose` to functions. 49 | * #204: Derive `Generic` and `NFData` for `Algebra.Graph` and `Algebra.Graph.Labelled`. 50 | 51 | ## 0.4 52 | 53 | * #174: Add `Symmetric.Relation`. 54 | * #143: Allow newer QuickCheck. 55 | * #171: Implement sparsification for King-Launchbury graph representation. 56 | * #178: Derive `Generic` for adjacency maps. 57 | 58 | ## 0.3 59 | 60 | * #129: Add a testsuite for rewrite rules based on the `inspection-testing` library. 61 | * #63, #148: Add relational composition of algebraic graphs. 62 | * #139, #146: Add relational operations to adjacency maps. 63 | * #146: Rename `preorderClosure` to `closure`. 64 | * #146: Switch to left-to-right composition in `Relation.compose`. 65 | * #143: Allow newer QuickCheck. 66 | * #140, #142: Fix `Show` instances. 67 | * #128, #130: Modify the SCC algorithm to return non-empty graph components. 68 | * #130: Move adjacency map algorithms to separate modules. 69 | * #130: Export `fromAdjacencySets` and `fromAdjacencyIntSets`. 70 | * #138: Do not require `Eq` instance on the string type when exporting graphs. 71 | * #136: Rename `Algebra.Graph.NonEmpty.NonEmptyGraph` to `Algebra.Graph.NonEmpty.Graph`. 72 | * #136: Add `Algebra.Graph.NonEmpty.AdjacencyMap`. 73 | * #136: Remove `vertexIntSet` from the API of basic graph data types. Also 74 | remove `Algebra.Graph.adjacencyMap` and `Algebra.Graph.adjacencyIntMap`. 75 | This functionality is still available from the type class `ToGraph`. 76 | * #126, #131: Implement custom `Ord` instance. 77 | * #17, #122, #125, #149: Add labelled algebraic graphs. 78 | * #121: Drop `Foldable` and `Traversable` instances. 79 | * #113: Add `Labelled.AdjacencyMap`. 80 | 81 | ## 0.2 82 | 83 | * #117: Add `sparsify`. 84 | * #115: Add `isDfsForestOf`. 85 | * #114: Add a basic implementation of edge-labelled graphs. 86 | * #107: Drop `starTranspose`. 87 | * #106: Extend `ToGraph` with algorithms based on adjacency maps. 88 | * #106: Add `isAcyclic` and `reachable`. 89 | * #106: Rename `isTopSort` to `isTopSortOf`. 90 | * #102: Switch the master branch to GHC 8.4.3. Add a CI instance for GHC 8.6.1. 91 | * #101: Drop `-O2` from the `ghc-options` section of the Cabal file. 92 | * #100: Rename `fromAdjacencyList` to `stars`. 93 | * #79: Improve the API consistency: rename `IntAdjacencyMap` to `AdjacencyIntMap`, 94 | and then rename the function that extracts its adjacency map to 95 | `adjacencyIntMap` to avoid the clash with `AdjacencyMap.adjacencyMap`, 96 | which has incompatible type. 97 | * #82, #92: Add performance regression suite. 98 | * #76: Remove benchmarks. 99 | * #74: Drop dependency of `Algebra.Graph` on graph type classes. 100 | * #62: Move King-Launchbury graphs into `Data.Graph.Typed`. 101 | * #67, #68, #69, #77, #81, #93, #94, #97, #103, #110: Various performance improvements. 102 | * #66, #72, #96, #98: Add missing `NFData` instances. 103 | 104 | ## 0.1.1.1 105 | 106 | * #59: Allow `base-compat-0.10`. 107 | 108 | ## 0.1.1 109 | 110 | * #58: Update documentation. 111 | * #57: Allow newer QuickCheck. 112 | 113 | ## 0.1.0 114 | 115 | * Start complying with PVP. 116 | * #48: Add `starTranspose`. 117 | * #48: Add `foldg` to `ToGraph`. 118 | * #15: Optimise `removeEdge`. 119 | * #39: Factor out difference lists into `Algebra.Graph.Internal`. 120 | * #31: Add `Algebra.Graph.NonEmpty`. 121 | * #32: Remove smart constructor `graph`. 122 | * #27, #55: Support GHC versions 7.8.4, 7.10.3, 8.0.2, 8.2.2, 8.4.1. 123 | * #25: Add `NFData Graph` instance. 124 | * General improvements to code, documentation and tests. 125 | 126 | ## 0.0.5 127 | 128 | * Add `dfs`. 129 | * #19: Move `GraphKL` to an internal module. 130 | * #18: Add `dfsForestFrom`. 131 | * #16: Add support for graph export, in particular in DOT format. 132 | * Make API more consistent, e.g. rename `postset` to `postSet`. 133 | * Improve documentation and tests. 134 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Label.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Test.Label 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- Testsuite for "Algebra.Graph.Label". 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Test.Label ( 13 | -- * Testsuite 14 | testLabel 15 | ) where 16 | 17 | import Algebra.Graph.Test 18 | import Algebra.Graph.Label 19 | import Data.Monoid 20 | 21 | type Unary a = a -> a 22 | type Binary a = a -> a -> a 23 | type Additive a = Binary a 24 | type Multiplicative a = Binary a 25 | type Star a = Unary a 26 | type Identity a = a 27 | type Zero a = a 28 | type One a = a 29 | 30 | associative :: Eq a => Binary a -> a -> a -> a -> Property 31 | associative (<>) a b c = (a <> b) <> c == a <> (b <> c) // "Associative" 32 | 33 | commutative :: Eq a => Binary a -> a -> a -> Property 34 | commutative (<>) a b = a <> b == b <> a // "Commutative" 35 | 36 | idempotent :: Eq a => Binary a -> a -> Property 37 | idempotent (<>) a = a <> a == a // "Idempotent" 38 | 39 | annihilatingZero :: Eq a => Binary a -> Zero a -> a -> Property 40 | annihilatingZero (<>) z a = conjoin 41 | [ a <> z == z // "Left" 42 | , z <> a == z // "Right" ] // "Annihilating zero" 43 | 44 | closure :: Eq a => Additive a -> Multiplicative a -> One a -> Star a -> a -> Property 45 | closure (+) (*) o s a = conjoin 46 | [ s a == o + (a * s a) // "Left" 47 | , s a == o + (s a * a) // "Right" ] // "Closure" 48 | 49 | leftDistributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property 50 | leftDistributive (+) (*) a b c = 51 | a * (b + c) == (a * b) + (a * c) // "Left distributive" 52 | 53 | rightDistributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property 54 | rightDistributive (+) (*) a b c = 55 | (a + b) * c == (a * c) + (b * c) // "Right distributive" 56 | 57 | distributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property 58 | distributive p m a b c = conjoin 59 | [ leftDistributive p m a b c 60 | , rightDistributive p m a b c ] // "Distributive" 61 | 62 | identity :: Eq a => Binary a -> Identity a -> a -> Property 63 | identity (<>) e a = conjoin 64 | [ a <> e == a // "Left" 65 | , e <> a == a // "Right" ] // "Identity" 66 | 67 | semigroup :: Eq a => Binary a -> a -> a -> a -> Property 68 | semigroup f a b c = associative f a b c // "Semigroup" 69 | 70 | monoid :: Eq a => Binary a -> Identity a -> a -> a -> a -> Property 71 | monoid f e a b c = conjoin 72 | [ semigroup f a b c 73 | , identity f e a ] // "Monoid" 74 | 75 | commutativeMonoid :: Eq a => Binary a -> Identity a -> a -> a -> a -> Property 76 | commutativeMonoid f e a b c = conjoin 77 | [ monoid f e a b c 78 | , commutative f a b ] // "Commutative monoid" 79 | 80 | leftNearRing :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property 81 | leftNearRing (+) z (*) o a b c = conjoin 82 | [ commutativeMonoid (+) z a b c 83 | , monoid (*) o a b c 84 | , leftDistributive (+) (*) a b c 85 | , annihilatingZero (*) z a ] // "Left near ring" 86 | 87 | semiring :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property 88 | semiring (+) z (*) o a b c = conjoin 89 | [ commutativeMonoid (+) z a b c 90 | , monoid (*) o a b c 91 | , distributive (+) (*) a b c 92 | , annihilatingZero (*) z a ] // "Semiring" 93 | 94 | dioid :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property 95 | dioid (+) z (*) o a b c = conjoin 96 | [ semiring (+) z (*) o a b c 97 | , idempotent (+) a ] // "Dioid" 98 | 99 | starSemiring :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> Star a -> a -> a -> a -> Property 100 | starSemiring (+) z (*) o s a b c = conjoin 101 | [ semiring (+) z (*) o a b c 102 | , closure (+) (*) o s a ] // "Star semiring" 103 | 104 | testLeftNearRing :: (Eq a, Semiring a) => a -> a -> a -> Property 105 | testLeftNearRing = leftNearRing (<+>) zero (<.>) one 106 | 107 | testSemiring :: (Eq a, Semiring a) => a -> a -> a -> Property 108 | testSemiring = semiring (<+>) zero (<.>) one 109 | 110 | testDioid :: (Eq a, Dioid a) => a -> a -> a -> Property 111 | testDioid = dioid (<+>) zero (<.>) one 112 | 113 | testStarSemiring :: (Eq a, StarSemiring a) => a -> a -> a -> Property 114 | testStarSemiring = starSemiring (<+>) zero (<.>) one star 115 | 116 | testLabel :: IO () 117 | testLabel = do 118 | putStrLn "\n============ Graph.Label ============" 119 | putStrLn "\n============ Any: instances ============" 120 | test "Semiring" $ testSemiring @Any 121 | test "StarSemiring" $ testStarSemiring @Any 122 | test "Dioid" $ testDioid @Any 123 | 124 | putStrLn "\n============ Distance Int: instances ============" 125 | test "Semiring" $ testSemiring @(Distance Int) 126 | test "StarSemiring" $ testStarSemiring @(Distance Int) 127 | test "Dioid" $ testDioid @(Distance Int) 128 | 129 | putStrLn "\n============ Capacity Int: instances ============" 130 | test "Semiring" $ testSemiring @(Capacity Int) 131 | test "StarSemiring" $ testStarSemiring @(Capacity Int) 132 | test "Dioid" $ testDioid @(Capacity Int) 133 | 134 | putStrLn "\n============ Minimum (Path Int): instances ============" 135 | test "LeftNearRing" $ testLeftNearRing @(Minimum (Path Int)) 136 | 137 | putStrLn "\n============ PowerSet (Path Int): instances ============" 138 | test "Semiring" $ size10 $ testSemiring @(PowerSet (Path Int)) 139 | test "Dioid" $ size10 $ testDioid @(PowerSet (Path Int)) 140 | 141 | putStrLn "\n============ Count Int: instances ============" 142 | test "Semiring" $ testSemiring @(Count Int) 143 | test "StarSemiring" $ testStarSemiring @(Count Int) 144 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Internal.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Internal 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 10 | -- in Haskell. See for the 11 | -- motivation behind the library, the underlying theory, and implementation details. 12 | -- 13 | -- This module defines various internal utilities and data structures used 14 | -- throughout the library, such as lists with fast concatenation. The API 15 | -- is unstable and unsafe, and is exposed only for documentation. 16 | ----------------------------------------------------------------------------- 17 | module Algebra.Graph.Internal ( 18 | -- * Data structures 19 | List, 20 | 21 | -- * Graph traversal 22 | Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, foldr1Safe, 23 | maybeF, 24 | 25 | -- * Utilities 26 | cartesianProductWith, coerce00, coerce10, coerce20, coerce01, coerce11, 27 | coerce21 28 | ) where 29 | 30 | import Data.Coerce 31 | import Data.Foldable 32 | import Data.Semigroup (Endo (..)) 33 | import Data.Set (Set) 34 | 35 | import qualified Data.Set as Set 36 | import qualified GHC.Exts as Exts 37 | 38 | -- | An abstract list data type with /O(1)/ time concatenation (the current 39 | -- implementation uses difference lists). Here @a@ is the type of list elements. 40 | -- 'List' @a@ is a 'Monoid': 'mempty' corresponds to the empty list and two lists 41 | -- can be concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Singleton 42 | -- lists can be constructed using the function 'pure' from the 'Applicative' 43 | -- instance. 'List' @a@ is also an instance of 'IsList', therefore you can use 44 | -- list literals, e.g. @[1,4]@ @::@ 'List' @Int@ is the same as 'pure' @1@ 45 | -- 'Data.Semigroup.<>' 'pure' @4@; note that this requires the @OverloadedLists@ 46 | -- GHC extension. To extract plain Haskell lists you can use the 'toList' 47 | -- function from the 'Foldable' instance. 48 | newtype List a = List (Endo [a]) deriving (Monoid, Semigroup) 49 | 50 | instance Show a => Show (List a) where 51 | show = show . toList 52 | 53 | instance Eq a => Eq (List a) where 54 | x == y = toList x == toList y 55 | 56 | instance Ord a => Ord (List a) where 57 | compare x y = compare (toList x) (toList y) 58 | 59 | -- TODO: Add rewrite rules? fromList . toList == toList . fromList == id 60 | instance Exts.IsList (List a) where 61 | type Item (List a) = a 62 | fromList = List . Endo . (<>) 63 | toList (List x) = appEndo x [] 64 | 65 | instance Foldable List where 66 | foldMap f = foldMap f . Exts.toList 67 | toList = Exts.toList 68 | 69 | instance Functor List where 70 | fmap f = Exts.fromList . map f . toList 71 | 72 | instance Applicative List where 73 | pure = List . Endo . (:) 74 | f <*> x = Exts.fromList (toList f <*> toList x) 75 | 76 | instance Monad List where 77 | return = pure 78 | x >>= f = Exts.fromList (toList x >>= toList . f) 79 | 80 | -- | The /focus/ of a graph expression is a flattened representation of the 81 | -- subgraph under focus, its context, as well as the list of all encountered 82 | -- vertices. See 'Algebra.Graph.removeEdge' for a use-case example. 83 | data Focus a = Focus 84 | { ok :: Bool -- ^ True if focus on the specified subgraph is obtained. 85 | , is :: List a -- ^ Inputs into the focused subgraph. 86 | , os :: List a -- ^ Outputs out of the focused subgraph. 87 | , vs :: List a } -- ^ All vertices (leaves) of the graph expression. 88 | 89 | -- | Focus on the empty graph. 90 | emptyFocus :: Focus a 91 | emptyFocus = Focus False mempty mempty mempty 92 | 93 | -- | Focus on the graph with a single vertex, given a predicate indicating 94 | -- whether the vertex is of interest. 95 | vertexFocus :: (a -> Bool) -> a -> Focus a 96 | vertexFocus f x = Focus (f x) mempty mempty (pure x) 97 | 98 | -- | Overlay two foci. 99 | overlayFoci :: Focus a -> Focus a -> Focus a 100 | overlayFoci x y = Focus (ok x || ok y) (is x <> is y) (os x <> os y) (vs x <> vs y) 101 | 102 | -- | Connect two foci. 103 | connectFoci :: Focus a -> Focus a -> Focus a 104 | connectFoci x y = Focus (ok x || ok y) (xs <> is y) (os x <> ys) (vs x <> vs y) 105 | where 106 | xs = if ok y then vs x else is x 107 | ys = if ok x then vs y else os y 108 | 109 | -- | A safe version of 'foldr1'. 110 | foldr1Safe :: (a -> a -> a) -> [a] -> Maybe a 111 | foldr1Safe f = foldr (maybeF f) Nothing 112 | {-# INLINE foldr1Safe #-} 113 | 114 | -- | An auxiliary function that tries to apply a function to a base case and a 115 | -- 'Maybe' value and returns 'Just' the result or 'Just' the base case. 116 | maybeF :: (a -> b -> a) -> a -> Maybe b -> Maybe a 117 | maybeF f x = Just . maybe x (f x) 118 | {-# INLINE maybeF #-} 119 | 120 | -- TODO: Can we implement this faster via 'Set.cartesianProduct'? 121 | -- | Compute the Cartesian product of two sets, applying a function to each 122 | -- resulting pair. 123 | cartesianProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c 124 | cartesianProductWith f x y = 125 | Set.fromList [ f a b | a <- Set.toAscList x, b <- Set.toAscList y ] 126 | 127 | -- TODO: Get rid of this boilerplate. 128 | 129 | -- | Help GHC with type inference when direct use of 'coerce' does not compile. 130 | coerce00 :: Coercible f g => f x -> g x 131 | coerce00 = coerce 132 | 133 | -- | Help GHC with type inference when direct use of 'coerce' does not compile. 134 | coerce10 :: (Coercible a b, Coercible f g) => (a -> f x) -> (b -> g x) 135 | coerce10 = coerce 136 | 137 | -- | Help GHC with type inference when direct use of 'coerce' does not compile. 138 | coerce20 :: (Coercible a b, Coercible c d, Coercible f g) 139 | => (a -> c -> f x) -> (b -> d -> g x) 140 | coerce20 = coerce 141 | 142 | -- | Help GHC with type inference when direct use of 'coerce' does not compile. 143 | coerce01 :: (Coercible a b, Coercible f g) => (f x -> a) -> (g x -> b) 144 | coerce01 = coerce 145 | 146 | -- | Help GHC with type inference when direct use of 'coerce' does not compile. 147 | coerce11 :: (Coercible a b, Coercible c d, Coercible f g) 148 | => (a -> f x -> c) -> (b -> g x -> d) 149 | coerce11 = coerce 150 | 151 | -- | Help GHC with type inference when direct use of 'coerce' does not compile. 152 | coerce21 :: (Coercible a b, Coercible c d, Coercible p q, Coercible f g) 153 | => (a -> c -> f x -> p) -> (b -> d -> g x -> q) 154 | coerce21 = coerce 155 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Graph.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Test.Graph 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Testsuite for "Algebra.Graph" and polymorphic functions defined in 10 | -- "Algebra.Graph.HigherKinded.Class". 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Test.Graph ( 13 | -- * Testsuite 14 | testGraph 15 | ) where 16 | 17 | import Data.Either 18 | 19 | import Algebra.Graph 20 | import Algebra.Graph.Test 21 | import Algebra.Graph.Test.API (toIntAPI, graphAPI) 22 | import Algebra.Graph.Test.Generic 23 | import Algebra.Graph.ToGraph (reachable) 24 | 25 | import qualified Data.Graph as KL 26 | 27 | tPoly :: Testsuite Graph Ord 28 | tPoly = ("Graph.", graphAPI) 29 | 30 | t :: TestsuiteInt Graph 31 | t = fmap toIntAPI tPoly 32 | 33 | type G = Graph Int 34 | 35 | testGraph :: IO () 36 | testGraph = do 37 | putStrLn "\n============ Graph ============" 38 | test "Axioms of graphs" (axioms @G) 39 | test "Theorems of graphs" (theorems @G) 40 | 41 | testBasicPrimitives t 42 | testIsSubgraphOf t 43 | testToGraph t 44 | testSize t 45 | testGraphFamilies t 46 | testTransformations t 47 | testInduceJust tPoly 48 | 49 | ---------------------------------------------------------------- 50 | -- Generic relational composition tests, plus an additional one 51 | testCompose t 52 | test "size (compose x y) <= edgeCount x + edgeCount y + 1" $ \(x :: G) y -> 53 | size (compose x y) <= edgeCount x + edgeCount y + 1 54 | ---------------------------------------------------------------- 55 | 56 | putStrLn "\n============ Graph.(===) ============" 57 | test " x === x == True" $ \(x :: G) -> 58 | (x === x) == True 59 | 60 | test " x === x + empty == False" $ \(x :: G) -> 61 | (x === x + empty)== False 62 | 63 | test "x + y === x + y == True" $ \(x :: G) y -> 64 | (x + y === x + y) == True 65 | 66 | test "1 + 2 === 2 + 1 == False" $ 67 | (1 + 2 === 2 + (1 :: G)) == False 68 | 69 | test "x + y === x * y == False" $ \(x :: G) y -> 70 | (x + y === x * y) == False 71 | 72 | 73 | testMesh tPoly 74 | testTorus tPoly 75 | testDeBruijn tPoly 76 | testSplitVertex t 77 | testBind t 78 | testSimplify t 79 | testBox tPoly 80 | 81 | putStrLn "\n============ Graph.sparsify ============" 82 | test "sort . reachable x == sort . rights . reachable (sparsify x) . Right" $ \(x :: G) y -> 83 | (sort . reachable x) y ==(sort . rights . reachable (sparsify x) . Right) y 84 | 85 | test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> 86 | vertexCount (sparsify x) <= vertexCount x + size x + 1 87 | 88 | test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> 89 | edgeCount (sparsify x) <= 3 * size x 90 | 91 | test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> 92 | size (sparsify x) <= 3 * size x 93 | 94 | putStrLn "\n============ Graph.sparsifyKL ============" 95 | test "sort . reachable x == sort . filter (<= n) . reachable (sparsifyKL n x)" $ \(Positive n) -> do 96 | let pairs = (,) <$> choose (1, n) <*> choose (1, n) 97 | es <- listOf pairs 98 | let x = vertices [1..n] `overlay` edges es 99 | y <- choose (1, n) 100 | return $ (sort . reachable x) y == (sort . filter (<= n) . KL.reachable (sparsifyKL n x)) y 101 | 102 | test "length (vertices $ sparsifyKL n x) <= vertexCount x + size x + 1" $ \(Positive n) -> do 103 | let pairs = (,) <$> choose (1, n) <*> choose (1, n) 104 | es <- listOf pairs 105 | let x = vertices [1..n] `overlay` edges es 106 | return $ length (KL.vertices $ sparsifyKL n x) <= vertexCount x + size x + 1 107 | 108 | test "length (edges $ sparsifyKL n x) <= 3 * size x" $ \(Positive n) -> do 109 | let pairs = (,) <$> choose (1, n) <*> choose (1, n) 110 | es <- listOf pairs 111 | let x = vertices [1..n] `overlay` edges es 112 | return $ length (KL.edges $ sparsifyKL n x) <= 3 * size x 113 | 114 | putStrLn "\n============ Graph.context ============" 115 | test "context (const False) x == Nothing" $ \x -> 116 | context (const False) (x :: G) == Nothing 117 | 118 | test "context (== 1) (edge 1 2) == Just (Context [ ] [2 ])" $ 119 | context (== 1) (edge 1 2 :: G) == Just (Context [ ] [2 ]) 120 | 121 | test "context (== 2) (edge 1 2) == Just (Context [1 ] [ ])" $ 122 | context (== 2) (edge 1 2 :: G) == Just (Context [1 ] [ ]) 123 | 124 | test "context (const True ) (edge 1 2) == Just (Context [1 ] [2 ])" $ 125 | context (const True ) (edge 1 2 :: G) == Just (Context [1 ] [2 ]) 126 | 127 | test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [3,1] [1,5])" $ 128 | context (== 4) (3 * 1 * 4 * 1 * 5 :: G) == Just (Context [3,1] [1,5]) 129 | 130 | putStrLn "\n============ Graph.buildg ============" 131 | test "buildg (\\e _ _ _ -> e) == empty" $ 132 | buildg (\e _ _ _ -> e) == (empty :: G) 133 | 134 | test "buildg (\\_ v _ _ -> v x) == vertex x" $ \(x :: Int) -> 135 | buildg (\_ v _ _ -> v x) == vertex x 136 | 137 | test "buildg (\\e v o c -> o (foldg e v o c x) (foldg e v o c y)) == overlay x y" $ \(x :: G) y -> 138 | buildg (\e v o c -> o (foldg e v o c x) (foldg e v o c y)) == overlay x y 139 | 140 | test "buildg (\\e v o c -> c (foldg e v o c x) (foldg e v o c y)) == connect x y" $ \(x :: G) y -> 141 | buildg (\e v o c -> c (foldg e v o c x) (foldg e v o c y)) == connect x y 142 | 143 | test "buildg (\\e v o _ -> foldr o e (map v xs)) == vertices xs" $ \(xs :: [Int]) -> 144 | buildg (\e v o _ -> foldr o e (map v xs)) == vertices xs 145 | 146 | test "buildg (\\e v o c -> foldg e v o (flip c) g) == transpose g" $ \(g :: G) -> 147 | buildg (\e v o c -> foldg e v o (flip c) g) == transpose g 148 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Export.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Export 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 11 | -- in Haskell. See for the 12 | -- motivation behind the library, the underlying theory, and implementation details. 13 | -- 14 | -- This module defines basic functionality for exporting graphs in textual and 15 | -- binary formats. "Algebra.Graph.Export.Dot" provides DOT-specific functions. 16 | ----------------------------------------------------------------------------- 17 | module Algebra.Graph.Export ( 18 | -- * Constructing and exporting documents 19 | Doc, isEmpty, literal, render, 20 | 21 | -- * Common combinators for text documents 22 | (<+>), brackets, doubleQuotes, indent, unlines, 23 | 24 | -- * Generic graph export 25 | export 26 | ) where 27 | 28 | import Data.Foldable (fold) 29 | import Data.String hiding (unlines) 30 | import Prelude hiding (unlines) 31 | 32 | import Algebra.Graph.ToGraph (ToGraph, ToVertex, toAdjacencyMap) 33 | import Algebra.Graph.AdjacencyMap (vertexList, edgeList) 34 | import Algebra.Graph.Internal 35 | 36 | -- | An abstract document data type with /O(1)/ time concatenation (the current 37 | -- implementation uses difference lists). Here @s@ is the type of abstract 38 | -- symbols or strings (text or binary). 'Doc' @s@ is a 'Monoid', therefore 39 | -- 'mempty' corresponds to the /empty document/ and two documents can be 40 | -- concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Documents 41 | -- comprising a single symbol or string can be constructed using the function 42 | -- 'literal'. Alternatively, you can construct documents as string literals, 43 | -- e.g. simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To 44 | -- extract the document contents use the function 'render'. 45 | -- 46 | -- Note that the document comprising a single empty string is considered to be 47 | -- different from the empty document. This design choice is motivated by the 48 | -- desire to support string types @s@ that have no 'Eq' instance, such as 49 | -- "Data.ByteString.Builder", for which there is no way to check whether a 50 | -- string is empty or not. As a consequence, the 'Eq' and 'Ord' instances are 51 | -- defined as follows: 52 | -- 53 | -- @ 54 | -- 'mempty' /= 'literal' "" 55 | -- 'mempty' < 'literal' "" 56 | -- @ 57 | newtype Doc s = Doc (List s) deriving (Monoid, Semigroup) 58 | 59 | instance (Monoid s, Show s) => Show (Doc s) where 60 | show = show . render 61 | 62 | instance (Monoid s, Eq s) => Eq (Doc s) where 63 | x == y | isEmpty x = isEmpty y 64 | | isEmpty y = False 65 | | otherwise = render x == render y 66 | 67 | -- | The empty document is smallest. 68 | instance (Monoid s, Ord s) => Ord (Doc s) where 69 | compare x y | isEmpty x = if isEmpty y then EQ else LT 70 | | isEmpty y = GT 71 | | otherwise = compare (render x) (render y) 72 | 73 | instance IsString s => IsString (Doc s) where 74 | fromString = literal . fromString 75 | 76 | -- | Check if a document is empty. The result is the same as when comparing the 77 | -- given document to 'mempty', but this function does not require the 'Eq' @s@ 78 | -- constraint. Note that the document comprising a single empty string is 79 | -- considered to be different from the empty document. 80 | -- 81 | -- @ 82 | -- isEmpty 'mempty' == True 83 | -- isEmpty ('literal' \"\") == False 84 | -- isEmpty x == (x == 'mempty') 85 | -- @ 86 | isEmpty :: Doc s -> Bool 87 | isEmpty (Doc xs) = null xs 88 | 89 | -- | Construct a document comprising a single symbol or string. If @s@ is an 90 | -- instance of class 'IsString', then documents of type 'Doc' @s@ can be 91 | -- constructed directly from string literals (see the second example below). 92 | -- 93 | -- @ 94 | -- literal "Hello, " 'Data.Semigroup.<>' literal "World!" == literal "Hello, World!" 95 | -- literal "I am just a string literal" == "I am just a string literal" 96 | -- 'render' . literal == 'id' 97 | -- @ 98 | literal :: s -> Doc s 99 | literal = Doc . pure 100 | 101 | -- | Render the document as a single string. An inverse of the function 'literal'. 102 | -- 103 | -- @ 104 | -- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s 105 | -- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") == "alga" 106 | -- render 'mempty' == 'mempty' 107 | -- render . 'literal' == 'id' 108 | -- @ 109 | render :: Monoid s => Doc s -> s 110 | render (Doc x) = fold x 111 | 112 | -- | Concatenate two documents, separated by a single space, unless one of the 113 | -- documents is empty. The operator \<+\> is associative with identity 'mempty'. 114 | -- 115 | -- @ 116 | -- x \<+\> 'mempty' == x 117 | -- 'mempty' \<+\> x == x 118 | -- x \<+\> (y \<+\> z) == (x \<+\> y) \<+\> z 119 | -- "name" \<+\> "surname" == "name surname" 120 | -- @ 121 | (<+>) :: IsString s => Doc s -> Doc s -> Doc s 122 | x <+> y | isEmpty x = y 123 | | isEmpty y = x 124 | | otherwise = x <> " " <> y 125 | 126 | infixl 7 <+> 127 | 128 | -- | Wrap a document in square brackets. 129 | -- 130 | -- @ 131 | -- brackets "i" == "[i]" 132 | -- brackets 'mempty' == "[]" 133 | -- @ 134 | brackets :: IsString s => Doc s -> Doc s 135 | brackets x = "[" <> x <> "]" 136 | 137 | -- | Wrap a document into double quotes. 138 | -- 139 | -- @ 140 | -- doubleQuotes "\/path\/with spaces" == "\\"\/path\/with spaces\\"" 141 | -- doubleQuotes (doubleQuotes 'mempty') == "\\"\\"\\"\\"" 142 | -- @ 143 | doubleQuotes :: IsString s => Doc s -> Doc s 144 | doubleQuotes x = "\"" <> x <> "\"" 145 | 146 | -- | Prepend a given number of spaces to a document. 147 | -- 148 | -- @ 149 | -- indent 0 == 'id' 150 | -- indent 1 'mempty' == " " 151 | -- @ 152 | indent :: IsString s => Int -> Doc s -> Doc s 153 | indent spaces x = fromString (replicate spaces ' ') <> x 154 | 155 | -- | Concatenate documents after appending a terminating newline symbol to each. 156 | -- 157 | -- @ 158 | -- unlines [] == 'mempty' 159 | -- unlines ['mempty'] == "\\n" 160 | -- unlines ["title", "subtitle"] == "title\\nsubtitle\\n" 161 | -- @ 162 | unlines :: IsString s => [Doc s] -> Doc s 163 | unlines [] = mempty 164 | unlines (x:xs) = x <> "\n" <> unlines xs 165 | 166 | -- TODO: Avoid round-trip graph conversion if g :: AdjacencyMap a. 167 | -- | Export a graph into a document given two functions that construct documents 168 | -- for individual vertices and edges. The order of export is: vertices, sorted 169 | -- by 'Ord' @a@, and then edges, sorted by 'Ord' @(a, a)@. 170 | -- 171 | -- For example: 172 | -- 173 | -- @ 174 | -- vDoc x = 'literal' ('show' x) <> "\\n" 175 | -- eDoc x y = 'literal' ('show' x) <> " -> " <> 'literal' ('show' y) <> "\\n" 176 | -- > putStrLn $ 'render' $ export vDoc eDoc (1 + 2 * (3 + 4) :: 'Algebra.Graph.Graph' Int) 177 | -- 178 | -- 1 179 | -- 2 180 | -- 3 181 | -- 4 182 | -- 2 -> 3 183 | -- 2 -> 4 184 | -- @ 185 | export :: (Ord a, ToGraph g, ToVertex g ~ a) => (a -> Doc s) -> (a -> a -> Doc s) -> g -> Doc s 186 | export v e g = vDoc <> eDoc 187 | where 188 | vDoc = mconcat $ map v (vertexList adjMap) 189 | eDoc = mconcat $ map (uncurry e) (edgeList adjMap) 190 | adjMap = toAdjacencyMap g 191 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Export/Dot.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Export.Dot 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 11 | -- in Haskell. See for the 12 | -- motivation behind the library, the underlying theory, and implementation details. 13 | -- 14 | -- This module defines functions for exporting graphs in the DOT file format. 15 | ----------------------------------------------------------------------------- 16 | module Algebra.Graph.Export.Dot ( 17 | -- * Graph attributes and style 18 | Attribute (..), Quoting (..), Style (..), defaultStyle, defaultStyleViaShow, 19 | 20 | -- * Export functions 21 | export, exportAsIs, exportViaShow 22 | ) where 23 | 24 | import Data.List (intersperse) 25 | import Data.Monoid 26 | import Data.String hiding (unlines) 27 | import Prelude hiding (unlines) 28 | 29 | import Algebra.Graph.ToGraph (ToGraph (..)) 30 | import Algebra.Graph.Export hiding (export) 31 | import qualified Algebra.Graph.Export as E 32 | 33 | -- | An attribute is just a key-value pair, for example @"shape" := "box"@. 34 | -- Attributes are used to specify the style of graph elements during export. 35 | data Attribute s = (:=) s s 36 | 37 | -- TODO: Do we need other quoting styles, for example, 'SingleQuotes'? 38 | -- TODO: Shall we use 'Quoting' for vertex names too? 39 | -- | The style of quoting used when exporting attributes; 'DoubleQuotes' is the 40 | -- default. 41 | data Quoting = DoubleQuotes | NoQuotes 42 | 43 | -- | The record 'Style' @a@ @s@ specifies the style to use when exporting a 44 | -- graph in the DOT format. Here @a@ is the type of the graph vertices, and @s@ 45 | -- is the type of string to represent the resulting DOT document (e.g. String, 46 | -- Text, etc.). The only field that has no obvious default value is 47 | -- 'vertexName', which holds a function of type @a -> s@ to compute vertex 48 | -- names. See the function 'export' for an example. 49 | data Style a s = Style 50 | { graphName :: s 51 | -- ^ Name of the graph. 52 | , preamble :: [s] 53 | -- ^ Preamble (a list of lines) is added at the beginning of the DOT file body. 54 | , graphAttributes :: [Attribute s] 55 | -- ^ Graph style, e.g. @["bgcolor" := "azure"]@. 56 | , defaultVertexAttributes :: [Attribute s] 57 | -- ^ Default vertex style, e.g. @["shape" := "diamond"]@. 58 | , defaultEdgeAttributes :: [Attribute s] 59 | -- ^ Default edge style, e.g. @["style" := "dashed"]@. 60 | , vertexName :: a -> s 61 | -- ^ Compute a vertex name. 62 | , vertexAttributes :: a -> [Attribute s] 63 | -- ^ Attributes of a specific vertex. 64 | , edgeAttributes :: a -> a -> [Attribute s] 65 | -- ^ Attributes of a specific edge. 66 | , attributeQuoting :: Quoting 67 | -- ^ The quoting style used for attributes. 68 | } 69 | 70 | -- | Default style for exporting graphs. The 'vertexName' field is provided as 71 | -- the only argument; the other fields are set to trivial defaults. 72 | defaultStyle :: Monoid s => (a -> s) -> Style a s 73 | defaultStyle v = Style mempty [] [] [] [] v (const []) (\_ _ -> []) DoubleQuotes 74 | 75 | -- | Default style for exporting graphs with 'Show'-able vertices. The 76 | -- 'vertexName' field is computed using 'show'; the other fields are set to 77 | -- trivial defaults. 78 | -- 79 | -- @ 80 | -- defaultStyleViaShow = 'defaultStyle' ('fromString' . 'show') 81 | -- @ 82 | defaultStyleViaShow :: (Show a, IsString s, Monoid s) => Style a s 83 | defaultStyleViaShow = defaultStyle (fromString . show) 84 | 85 | -- | Export a graph with a given style. 86 | -- 87 | -- For example: 88 | -- 89 | -- @ 90 | -- style :: 'Style' Int String 91 | -- style = 'Style' 92 | -- { 'graphName' = \"Example\" 93 | -- , 'preamble' = [" // This is an example", ""] 94 | -- , 'graphAttributes' = ["label" := \"Example\", "labelloc" := "top"] 95 | -- , 'defaultVertexAttributes' = ["shape" := "circle"] 96 | -- , 'defaultEdgeAttributes' = 'mempty' 97 | -- , 'vertexName' = \\x -> "v" ++ 'show' x 98 | -- , 'vertexAttributes' = \\x -> ["color" := "blue" | 'odd' x ] 99 | -- , 'edgeAttributes' = \\x y -> ["style" := "dashed" | 'odd' (x * y)] 100 | -- , 'attributeQuoting' = 'DoubleQuotes' } 101 | -- 102 | -- > putStrLn $ export style (1 * 2 + 3 * 4 * 5 :: 'Graph' Int) 103 | -- 104 | -- digraph Example 105 | -- { 106 | -- // This is an example 107 | -- 108 | -- graph [label=\"Example\" labelloc="top"] 109 | -- node [shape="circle"] 110 | -- "v1" [color="blue"] 111 | -- "v2" 112 | -- "v3" [color="blue"] 113 | -- "v4" 114 | -- "v5" [color="blue"] 115 | -- "v1" -> "v2" 116 | -- "v3" -> "v4" 117 | -- "v3" -> "v5" [style="dashed"] 118 | -- "v4" -> "v5" 119 | -- } 120 | -- @ 121 | export :: (IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s 122 | export Style {..} g = render $ header <> body <> "}\n" 123 | where 124 | header = "digraph" <+> literal graphName <> "\n{\n" 125 | with x as = if null as then mempty else line (x <+> attributes attributeQuoting as) 126 | line s = indent 2 s <> "\n" 127 | body = unlines (map literal preamble) 128 | <> ("graph" `with` graphAttributes) 129 | <> ("node" `with` defaultVertexAttributes) 130 | <> ("edge" `with` defaultEdgeAttributes) 131 | <> E.export vDoc eDoc g 132 | label = doubleQuotes . literal . vertexName 133 | vDoc x = line $ label x <+> attributes attributeQuoting (vertexAttributes x) 134 | eDoc x y = line $ label x <> " -> " <> label y <+> attributes attributeQuoting (edgeAttributes x y) 135 | 136 | -- | Export a list of attributes using a specified quoting style. 137 | -- Example: @attributes DoubleQuotes ["label" := "A label", "shape" := "box"]@ 138 | -- corresponds to document: @[label="A label" shape="box"]@. 139 | attributes :: IsString s => Quoting -> [Attribute s] -> Doc s 140 | attributes _ [] = mempty 141 | attributes q as = brackets . mconcat . intersperse " " $ map dot as 142 | where 143 | dot (k := v) = literal k <> "=" <> quote (literal v) 144 | quote = case q of 145 | DoubleQuotes -> doubleQuotes 146 | NoQuotes -> id 147 | 148 | -- | Export a graph whose vertices are represented simply by their names. 149 | -- 150 | -- For example: 151 | -- 152 | -- @ 153 | -- > Text.putStrLn $ exportAsIs ('Algebra.Graph.AdjacencyMap.circuit' ["a", "b", "c"] :: 'Algebra.Graph.AdjacencyMap.AdjacencyMap' Text) 154 | -- 155 | -- digraph 156 | -- { 157 | -- "a" 158 | -- "b" 159 | -- "c" 160 | -- "a" -> "b" 161 | -- "b" -> "c" 162 | -- "c" -> "a" 163 | -- } 164 | -- @ 165 | exportAsIs :: (IsString s, Monoid s, Ord (ToVertex g), ToGraph g, ToVertex g ~ s) => g -> s 166 | exportAsIs = export (defaultStyle id) 167 | 168 | -- | Export a graph using the 'defaultStyleViaShow'. 169 | -- 170 | -- For example: 171 | -- 172 | -- @ 173 | -- > putStrLn $ exportViaShow (1 + 2 * (3 + 4) :: 'Algebra.Graph.Graph' Int) 174 | -- 175 | -- digraph 176 | -- { 177 | -- "1" 178 | -- "2" 179 | -- "3" 180 | -- "4" 181 | -- "2" -> "3" 182 | -- "2" -> "4" 183 | -- } 184 | -- @ 185 | exportViaShow :: (IsString s, Monoid s, Ord (ToVertex g), Show (ToVertex g), ToGraph g) => g -> s 186 | exportViaShow = export defaultStyleViaShow 187 | -------------------------------------------------------------------------------- /test/Data/Graph/Test/Typed.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Graph.Test.Typed 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Testsuite for "Data.Graph.Typed". 10 | ----------------------------------------------------------------------------- 11 | module Data.Graph.Test.Typed ( 12 | -- * Testsuite 13 | testTyped 14 | ) where 15 | 16 | import Algebra.Graph.Test 17 | import Algebra.Graph.AdjacencyMap ( forest, empty, vertex, edge, vertices 18 | , isSubgraphOf, vertexList, hasVertex ) 19 | 20 | import Data.Array (array) 21 | import Data.Graph.Typed 22 | import Data.Tree 23 | import Data.List (nub) 24 | 25 | import qualified Data.Graph as KL 26 | import qualified Data.IntSet as IntSet 27 | 28 | import qualified Algebra.Graph.AdjacencyMap as AM 29 | import qualified Algebra.Graph.AdjacencyIntMap as AIM 30 | 31 | type AI = AM.AdjacencyMap Int 32 | 33 | -- TODO: Improve the alignment in the testsuite to match the documentation. 34 | (%) :: (GraphKL Int -> a) -> AM.AdjacencyMap Int -> a 35 | f % x = f (fromAdjacencyMap x) 36 | 37 | testTyped :: IO () 38 | testTyped = do 39 | putStrLn "\n============ Typed ============" 40 | 41 | putStrLn "\n============ Typed.fromAdjacencyMap ============" 42 | 43 | test "toGraphKL (fromAdjacencyMap (1 * 2 + 3 * 1)) == array (0,2) [(0,[1]), (1,[]), (2,[0])]" $ 44 | toGraphKL (fromAdjacencyMap (1 * 2 + 3 * 1 :: AI)) == array (0,2) [(0,[1]), (1,[]), (2,[0])] 45 | 46 | test "toGraphKL (fromAdjacencyMap (1 * 2 + 2 * 1)) == array (0,1) [(0,[1]), (1,[0])]" $ 47 | toGraphKL (fromAdjacencyMap (1 * 2 + 2 * 1 :: AI)) == array (0,1) [(0,[1]), (1,[0])] 48 | 49 | test "map (fromVertexKL h) (vertices $ toGraphKL h) == vertexList g" 50 | $ \(g :: AI) -> let h = fromAdjacencyMap g in 51 | map (fromVertexKL h) (KL.vertices $ toGraphKL h) == AM.vertexList g 52 | 53 | test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" 54 | $ \(g :: AI) -> let h = fromAdjacencyMap g in 55 | map (\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == AM.edgeList g 56 | 57 | putStrLn "\n============ Typed.fromAdjacencyIntMap ============" 58 | 59 | test "toGraphKL (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == array (0,2) [(0,[1]), (1,[]), (2,[0])]" $ 60 | toGraphKL (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == array (0,2) [(0,[1]), (1,[]), (2,[0])] 61 | 62 | test "toGraphKL (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == array (0,1) [(0,[1]), (1,[0])]" $ 63 | toGraphKL (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == array (0,1) [(0,[1]), (1,[0])] 64 | 65 | test "map (fromVertexKL h) (vertices $ toGraphKL h) == IntSet.toAscList (vertexIntSet g)" 66 | $ \g -> let h = fromAdjacencyIntMap g in 67 | map (fromVertexKL h) (KL.vertices $ toGraphKL h) == IntSet.toAscList (AIM.vertexIntSet g) 68 | 69 | test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" 70 | $ \g -> let h = fromAdjacencyIntMap g in 71 | map (\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == AIM.edgeList g 72 | 73 | putStrLn $ "\n============ Typed.dfsForest ============" 74 | test "forest (dfsForest % edge 1 1) == vertex 1" $ 75 | forest (dfsForest % edge 1 1) == vertex 1 76 | 77 | test "forest (dfsForest % edge 1 2) == edge 1 2" $ 78 | forest (dfsForest % edge 1 2) == edge 1 2 79 | 80 | test "forest (dfsForest % edge 2 1) == vertices [1, 2]" $ 81 | forest (dfsForest % edge 2 1) == vertices [1, 2] 82 | 83 | test "isSubgraphOf (forest $ dfsForest % x) x == True" $ \x -> 84 | isSubgraphOf (forest $ dfsForest % x) x == True 85 | 86 | test "dfsForest % forest (dfsForest % x) == dfsForest % x" $ \x -> 87 | dfsForest % forest (dfsForest % x) == dfsForest % x 88 | 89 | test "dfsForest % vertices vs == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> 90 | dfsForest % vertices vs == map (\v -> Node v []) (nub $ sort vs) 91 | 92 | test "dfsForest % (3 * (1 + 4) * (1 + 5)) == " $ 93 | dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 94 | , subForest = [ Node { rootLabel = 5 95 | , subForest = [] }]} 96 | , Node { rootLabel = 3 97 | , subForest = [ Node { rootLabel = 4 98 | , subForest = [] }]}] 99 | 100 | putStrLn $ "\n============ Typed.dfsForestFrom ============" 101 | test "forest $ (dfsForestFrom % edge 1 1) [1] == vertex 1" $ 102 | (forest $ (dfsForestFrom % edge 1 1) [1]) == vertex 1 103 | 104 | test "forest $ (dfsForestFrom % edge 1 2) [0] == empty" $ 105 | (forest $ (dfsForestFrom % edge 1 2) [0]) == empty 106 | 107 | test "forest $ (dfsForestFrom % edge 1 2) [1] == edge 1 2" $ 108 | (forest $ (dfsForestFrom % edge 1 2) [1]) == edge 1 2 109 | 110 | test "forest $ (dfsForestFrom % edge 1 2) [2] == vertex 2" $ 111 | (forest $ (dfsForestFrom % edge 1 2) [2]) == vertex 2 112 | 113 | test "forest $ (dfsForestFrom % edge 1 2) [2,1] == vertices [1,2]" $ 114 | (forest $ (dfsForestFrom % edge 1 2) [2,1]) == vertices [1,2] 115 | 116 | test "isSubgraphOf (forest $ dfsForestFrom % x $ vs) x == True" $ \x vs -> 117 | isSubgraphOf (forest $ dfsForestFrom % x $ vs) x == True 118 | 119 | test "dfsForestFrom % x $ vertexList x == dfsForest % x" $ \x -> 120 | (dfsForestFrom % x $ vertexList x) == dfsForest % x 121 | 122 | test "dfsForestFrom % vertices vs $ vs == map (\\v -> Node v []) (nub vs)" $ \vs -> 123 | (dfsForestFrom % vertices vs $ vs) == map (\v -> Node v []) (nub vs) 124 | 125 | test "dfsForestFrom % x $ [] == []" $ \x -> 126 | (dfsForestFrom % x $ []) == [] 127 | 128 | test "dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4] == " $ 129 | (dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4])== [ Node { rootLabel = 1 130 | , subForest = [ Node { rootLabel = 5 131 | , subForest = [] }]} 132 | , Node { rootLabel = 4 133 | , subForest = [] }] 134 | 135 | putStrLn $ "\n============ Typed.dfs ============" 136 | test "dfs % edge 1 1 $ [1] == [1]" $ 137 | (dfs % edge 1 1 $ [1]) == [1] 138 | 139 | test "dfs % edge 1 2 $ [0] == []" $ 140 | (dfs % edge 1 2 $ [0]) == [] 141 | 142 | test "dfs % edge 1 2 $ [1] == [1,2]" $ 143 | (dfs % edge 1 2 $ [1]) == [1,2] 144 | 145 | test "dfs % edge 1 2 $ [2] == [2]" $ 146 | (dfs % edge 1 2 $ [2]) == [2] 147 | 148 | test "dfs % edge 1 2 $ [1,2] == [1,2]" $ 149 | (dfs % edge 1 2 $ [1,2])== [1,2] 150 | 151 | test "dfs % edge 1 2 $ [2,1] == [2,1]" $ 152 | (dfs % edge 1 2 $ [2,1])== [2,1] 153 | 154 | test "dfs % x $ [] == []" $ \x -> 155 | (dfs % x $ []) == [] 156 | 157 | putStrLn "" 158 | test "dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [1,5,4]" $ 159 | (dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4]) == [1,5,4] 160 | 161 | test "and [ hasVertex v x | v <- dfs % x $ vs ] == True" $ \x vs -> 162 | and [ hasVertex v x | v <- dfs % x $ vs ] == True 163 | 164 | putStrLn "\n============ Typed.topSort ============" 165 | test "topSort % (1 * 2 + 3 * 1) == [3,1,2]" $ 166 | topSort % (1 * 2 + 3 * 1) == ([3,1,2] :: [Int]) 167 | 168 | test "topSort % (1 * 2 + 2 * 1) == [1,2]" $ 169 | topSort % (1 * 2 + 2 * 1) == ([1,2] :: [Int]) 170 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Export.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Test.Export 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- Testsuite for "Algebra.Graph.Export" and "Algebra.Graph.Export.Dot". 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Test.Export ( 13 | -- * Testsuite 14 | testExport 15 | ) where 16 | 17 | import Algebra.Graph (Graph, circuit) 18 | import Algebra.Graph.Export hiding (unlines) 19 | import Algebra.Graph.Export.Dot (Attribute (..)) 20 | import Algebra.Graph.Test 21 | 22 | import qualified Algebra.Graph.Export as E 23 | import qualified Algebra.Graph.Export.Dot as ED 24 | 25 | testExport :: IO () 26 | testExport = do 27 | putStrLn "\n============ Export.Eq ============" 28 | test "mempty /= literal \"\"" $ 29 | mempty /= (literal "" :: Doc String) 30 | 31 | putStrLn "\n============ Export.Ord ============" 32 | test "mempty < literal \"\"" $ 33 | mempty < (literal "" :: Doc String) 34 | 35 | putStrLn "\n============ Export.isEmpty ============" 36 | test "isEmpty mempty == True" $ 37 | isEmpty mempty == True 38 | 39 | test "isEmpty (literal \"\") == False" $ 40 | isEmpty (literal "" :: Doc String) == False 41 | 42 | test "isEmpty x == (x == mempty)" $ \(x :: Doc String) -> 43 | isEmpty x == (x == mempty) 44 | 45 | putStrLn "\n============ Export.literal ============" 46 | test "literal \"Hello, \" <> literal \"World!\" == literal \"Hello, World!\"" $ 47 | literal "Hello, " <> literal "World!" == literal ("Hello, World!" :: String) 48 | 49 | test "literal \"I am just a string literal\" == \"I am just a string literal\"" $ 50 | literal "I am just a string literal" == ("I am just a string literal" :: Doc String) 51 | 52 | test "render . literal == id" $ \(x :: String) -> 53 | (render . literal) x == x 54 | 55 | putStrLn "\n============ Export.render ============" 56 | test "render (literal \"al\" <> literal \"ga\") == \"alga\"" $ 57 | render (literal "al" <> literal "ga") == ("alga" :: String) 58 | 59 | test "render mempty == mempty" $ 60 | render mempty == (mempty :: Doc String) 61 | 62 | putStrLn "\n============ Export.<+> ============" 63 | test "x <+> mempty == x" $ \(x :: Doc String) -> 64 | x <+> mempty == x 65 | 66 | test "mempty <+> x == x" $ \(x :: Doc String) -> 67 | mempty <+> x == x 68 | 69 | test "x <+> (y <+> z) == (x <+> y) <+> z" $ \(x :: Doc String) y z -> 70 | x <+> (y <+> z) == (x <+> y) <+> z 71 | 72 | test "\"name\" <+> \"surname\" == \"name surname\"" $ 73 | "name" <+> "surname" == ("name surname" :: Doc String) 74 | 75 | putStrLn "\n============ Export.brackets ============" 76 | test "brackets \"i\" == \"[i]\"" $ 77 | brackets "i" == ("[i]" :: Doc String) 78 | 79 | test "brackets mempty == \"[]\"" $ 80 | brackets mempty == ("[]" :: Doc String) 81 | 82 | putStrLn "\n============ Export.doubleQuotes ============" 83 | test "doubleQuotes \"/path/with spaces\" == \"\\\"/path/with spaces\\\"\"" $ 84 | doubleQuotes "/path/with spaces" == ("\"/path/with spaces\"" :: Doc String) 85 | 86 | test "doubleQuotes (doubleQuotes mempty) == \"\\\"\\\"\\\"\\\"\"" $ 87 | doubleQuotes (doubleQuotes mempty) == ("\"\"\"\"" :: Doc String) 88 | 89 | putStrLn "\n============ Export.indent ============" 90 | test "indent 0 == id" $ \(x :: String) -> 91 | indent 0 (literal x) == literal x 92 | 93 | test "indent 1 mempty == \" \"" $ 94 | indent 1 mempty == (" " :: Doc String) 95 | 96 | putStrLn "\n============ Export.unlines ============" 97 | test "unlines [] == mempty" $ 98 | E.unlines [] == (mempty :: Doc String) 99 | 100 | test "unlines [mempty] == \"\\n\"" $ 101 | E.unlines [mempty] == ("\n" :: Doc String) 102 | 103 | test "unlines [\"title\", \"subtitle\"] == \"title\\nsubtitle\\n\"" $ 104 | E.unlines ["title", "subtitle" ] == ("title\nsubtitle\n" :: Doc String) 105 | 106 | putStrLn "\n============ Export.export ============" 107 | let vDoc x = literal (show x) <> "\n" 108 | eDoc x y = literal (show x) <> " -> " <> literal (show y) <> "\n" 109 | test "render $ export vDoc eDoc (1 + 2 * (3 + 4) :: Graph Int)" $ 110 | (render (export vDoc eDoc (1 + 2 * (3 + 4) :: Graph Int)) :: String) == 111 | unlines [ "1" 112 | , "2" 113 | , "3" 114 | , "4" 115 | , "2 -> 3" 116 | , "2 -> 4" ] 117 | 118 | putStrLn "\n============ Export.Dot.export ============" 119 | let style = ED.Style 120 | { ED.graphName = "Example" 121 | , ED.preamble = [" // This is an example", ""] 122 | , ED.graphAttributes = ["label" := "Example", "labelloc" := "top"] 123 | , ED.defaultVertexAttributes = ["shape" := "circle"] 124 | , ED.defaultEdgeAttributes = mempty 125 | , ED.vertexName = \x -> "v" ++ show x 126 | , ED.vertexAttributes = \x -> ["color" := "blue" | odd x ] 127 | , ED.edgeAttributes = \x y -> ["style" := "dashed" | odd (x * y)] 128 | , ED.attributeQuoting = ED.DoubleQuotes } 129 | test "export style (1 * 2 + 3 * 4 * 5 :: Graph Int)" $ 130 | (ED.export style (1 * 2 + 3 * 4 * 5 :: Graph Int) :: String) == 131 | unlines [ "digraph Example" 132 | , "{" 133 | , " // This is an example" 134 | , "" 135 | , " graph [label=\"Example\" labelloc=\"top\"]" 136 | , " node [shape=\"circle\"]" 137 | , " \"v1\" [color=\"blue\"]" 138 | , " \"v2\"" 139 | , " \"v3\" [color=\"blue\"]" 140 | , " \"v4\"" 141 | , " \"v5\" [color=\"blue\"]" 142 | , " \"v1\" -> \"v2\"" 143 | , " \"v3\" -> \"v4\"" 144 | , " \"v3\" -> \"v5\" [style=\"dashed\"]" 145 | , " \"v4\" -> \"v5\"" 146 | , "}" ] 147 | 148 | putStrLn "\n=========== Export.Dot.attributeQuoting ============" 149 | let style' = style { ED.attributeQuoting = ED.NoQuotes } 150 | test "export style' (1 * 2 + 3 * 4 * 5 :: Graph Int)" $ 151 | (ED.export style' (1 * 2 + 3 * 4 * 5 :: Graph Int) :: String) == 152 | unlines [ "digraph Example" 153 | , "{" 154 | , " // This is an example" 155 | , "" 156 | , " graph [label=Example labelloc=top]" 157 | , " node [shape=circle]" 158 | , " \"v1\" [color=blue]" 159 | , " \"v2\"" 160 | , " \"v3\" [color=blue]" 161 | , " \"v4\"" 162 | , " \"v5\" [color=blue]" 163 | , " \"v1\" -> \"v2\"" 164 | , " \"v3\" -> \"v4\"" 165 | , " \"v3\" -> \"v5\" [style=dashed]" 166 | , " \"v4\" -> \"v5\"" 167 | , "}" ] 168 | 169 | putStrLn "\n============ Export.Dot.exportAsIs ============" 170 | test "exportAsIs (circuit [\"a\", \"b\", \"c\"] :: Graph String)" $ 171 | (ED.exportAsIs (circuit ["a", "b", "c"] :: Graph String) :: String) == 172 | unlines [ "digraph " 173 | , "{" 174 | , " \"a\"" 175 | , " \"b\"" 176 | , " \"c\"" 177 | , " \"a\" -> \"b\"" 178 | , " \"b\" -> \"c\"" 179 | , " \"c\" -> \"a\"" 180 | , "}" ] 181 | 182 | putStrLn "\n============ Export.Dot.exportViaShow ============" 183 | test "exportViaShow (1 + 2 * (3 + 4) :: Graph Int)" $ 184 | (ED.exportViaShow (1 + 2 * (3 + 4) :: Graph Int) :: String) == 185 | unlines [ "digraph " 186 | , "{" 187 | , " \"1\"" 188 | , " \"2\"" 189 | , " \"3\"" 190 | , " \"4\"" 191 | , " \"2\" -> \"3\"" 192 | , " \"2\" -> \"4\"" 193 | , "}" ] 194 | -------------------------------------------------------------------------------- /algebraic-graphs.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: algebraic-graphs 3 | version: 0.8 4 | synopsis: A library for algebraic graph construction and transformation 5 | license: MIT 6 | license-file: LICENSE 7 | author: Andrey Mokhov , github: @snowleopard 8 | maintainer: Andrey Mokhov , github: @snowleopard, 9 | Alexandre Moine , github: @nobrakal 10 | copyright: Andrey Mokhov, 2016-2025 11 | homepage: https://github.com/snowleopard/alga 12 | bug-reports: https://github.com/snowleopard/alga/issues 13 | category: Algebra, Algorithms, Data Structures, Graphs 14 | build-type: Simple 15 | 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 16 | description: 17 | is a library for algebraic construction and 18 | manipulation of graphs in Haskell. See 19 | for the motivation behind the library, the underlying theory and implementation details. 20 | . 21 | The top-level module 22 | 23 | defines the main data type for /algebraic graphs/ 24 | , 25 | as well as associated algorithms. For type-safe representation and 26 | manipulation of /non-empty algebraic graphs/, see 27 | . 28 | Furthermore, /algebraic graphs with edge labels/ are implemented in 29 | . 30 | . 31 | The library also provides conventional graph data structures, such as 32 | 33 | along with its various flavours: 34 | . 35 | * adjacency maps specialised to graphs with vertices of type 'Int' 36 | (), 37 | * non-empty adjacency maps 38 | (), 39 | * adjacency maps for undirected bipartite graphs 40 | (), 41 | * adjacency maps with edge labels 42 | (), 43 | * acyclic adjacency maps 44 | (), 45 | . 46 | A large part of the API of algebraic graphs and adjacency maps is available 47 | through the 'Foldable'-like type class 48 | . 49 | . 50 | The type classes defined in 51 | 52 | and 53 | 54 | can be used for polymorphic construction and manipulation of graphs. 55 | . 56 | This is an experimental library and the API is expected to remain unstable until version 1.0.0. 57 | Please consider contributing to the on-going 58 | . 59 | 60 | extra-doc-files: 61 | AUTHORS.md 62 | CHANGES.md 63 | README.md 64 | 65 | source-repository head 66 | type: git 67 | location: https://github.com/snowleopard/alga.git 68 | 69 | common common-settings 70 | build-depends: array >= 0.4 && < 0.6, 71 | base >= 4.12 && < 5, 72 | containers >= 0.5.5.1 && < 0.9, 73 | deepseq >= 1.3.0.1 && < 1.6, 74 | transformers >= 0.4 && < 0.7 75 | default-language: Haskell2010 76 | default-extensions: ConstraintKinds 77 | DeriveFunctor 78 | DeriveGeneric 79 | FlexibleContexts 80 | FlexibleInstances 81 | GADTs 82 | GeneralizedNewtypeDeriving 83 | MultiParamTypeClasses 84 | RankNTypes 85 | ScopedTypeVariables 86 | TupleSections 87 | TypeApplications 88 | TypeFamilies 89 | TypeOperators 90 | other-extensions: CPP 91 | OverloadedStrings 92 | RecordWildCards 93 | ViewPatterns 94 | ghc-options: -Wall 95 | -Wcompat 96 | -Wincomplete-record-updates 97 | -Wincomplete-uni-patterns 98 | -Wredundant-constraints 99 | -fno-warn-name-shadowing 100 | -fno-warn-unused-imports 101 | -fspec-constr 102 | 103 | library 104 | import: common-settings 105 | hs-source-dirs: src 106 | exposed-modules: Algebra.Graph, 107 | Algebra.Graph.Undirected, 108 | Algebra.Graph.Acyclic.AdjacencyMap, 109 | Algebra.Graph.AdjacencyIntMap, 110 | Algebra.Graph.AdjacencyIntMap.Algorithm, 111 | Algebra.Graph.AdjacencyMap, 112 | Algebra.Graph.AdjacencyMap.Algorithm, 113 | Algebra.Graph.Bipartite.AdjacencyMap, 114 | Algebra.Graph.Bipartite.AdjacencyMap.Algorithm, 115 | Algebra.Graph.Class, 116 | Algebra.Graph.Example.Todo, 117 | Algebra.Graph.Export, 118 | Algebra.Graph.Export.Dot, 119 | Algebra.Graph.HigherKinded.Class, 120 | Algebra.Graph.Internal, 121 | Algebra.Graph.Label, 122 | Algebra.Graph.Labelled, 123 | Algebra.Graph.Labelled.AdjacencyMap, 124 | Algebra.Graph.Labelled.Example.Automaton, 125 | Algebra.Graph.Labelled.Example.Network, 126 | Algebra.Graph.NonEmpty, 127 | Algebra.Graph.NonEmpty.AdjacencyMap, 128 | Algebra.Graph.Relation, 129 | Algebra.Graph.Relation.Preorder, 130 | Algebra.Graph.Relation.Reflexive, 131 | Algebra.Graph.Relation.Symmetric, 132 | Algebra.Graph.Relation.Transitive, 133 | Algebra.Graph.ToGraph, 134 | Data.Graph.Typed 135 | 136 | test-suite main 137 | import: common-settings 138 | hs-source-dirs: test 139 | type: exitcode-stdio-1.0 140 | main-is: Main.hs 141 | other-modules: Algebra.Graph.Test, 142 | Algebra.Graph.Test.API, 143 | Algebra.Graph.Test.Acyclic.AdjacencyMap, 144 | Algebra.Graph.Test.AdjacencyIntMap, 145 | Algebra.Graph.Test.AdjacencyMap, 146 | Algebra.Graph.Test.Arbitrary, 147 | Algebra.Graph.Test.Bipartite.AdjacencyMap, 148 | Algebra.Graph.Test.Example.Todo 149 | Algebra.Graph.Test.Export, 150 | Algebra.Graph.Test.Generic, 151 | Algebra.Graph.Test.Graph, 152 | Algebra.Graph.Test.Undirected, 153 | Algebra.Graph.Test.Internal, 154 | Algebra.Graph.Test.Label, 155 | Algebra.Graph.Test.Labelled.AdjacencyMap, 156 | Algebra.Graph.Test.Labelled.Graph, 157 | Algebra.Graph.Test.NonEmpty.AdjacencyMap, 158 | Algebra.Graph.Test.NonEmpty.Graph, 159 | Algebra.Graph.Test.Relation, 160 | Algebra.Graph.Test.Relation.Symmetric, 161 | Algebra.Graph.Test.RewriteRules, 162 | Data.Graph.Test.Typed 163 | build-depends: algebraic-graphs, 164 | extra >= 1.4 && < 2, 165 | inspection-testing >= 0.4.2.2 && < 0.7, 166 | QuickCheck >= 2.14 && < 2.16 167 | other-extensions: ConstrainedClassMethods 168 | TemplateHaskell 169 | -------------------------------------------------------------------------------- /src/Data/Graph/Typed.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Graph.Typed 4 | -- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com 7 | -- Stability : unstable 8 | -- 9 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 10 | -- in Haskell. See for the 11 | -- motivation behind the library, the underlying theory, and implementation details. 12 | -- 13 | -- This module provides primitives for interoperability between this library and 14 | -- the "Data.Graph" module of the containers library. It is for internal use only 15 | -- and may be removed without notice at any point. 16 | ----------------------------------------------------------------------------- 17 | module Data.Graph.Typed ( 18 | -- * Data type and construction 19 | GraphKL(..), fromAdjacencyMap, fromAdjacencyIntMap, 20 | 21 | -- * Basic algorithms 22 | dfsForest, dfsForestFrom, dfs, topSort, scc 23 | ) where 24 | 25 | import Data.Tree 26 | import Data.Maybe 27 | import Data.Foldable 28 | 29 | import qualified Data.Graph as KL 30 | 31 | import qualified Algebra.Graph.AdjacencyMap as AM 32 | import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty 33 | import qualified Algebra.Graph.AdjacencyIntMap as AIM 34 | 35 | import qualified Data.Map.Strict as Map 36 | import qualified Data.Set as Set 37 | 38 | -- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in 39 | -- the "Data.Graph" module of the @containers@ library. 40 | data GraphKL a = GraphKL { 41 | -- | Array-based graph representation (King and Launchbury, 1995). 42 | toGraphKL :: KL.Graph, 43 | -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. 44 | -- This is partial and may fail if the vertex is out of bounds. 45 | fromVertexKL :: KL.Vertex -> a, 46 | -- | A mapping from vertices of type @a@ to "Data.Graph.Vertex". 47 | -- Returns 'Nothing' if the argument is not in the graph. 48 | toVertexKL :: a -> Maybe KL.Vertex } 49 | 50 | -- | Build 'GraphKL' from an 'AM.AdjacencyMap'. If @fromAdjacencyMap g == h@ 51 | -- then the following holds: 52 | -- 53 | -- @ 54 | -- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'AM.vertexList' g 55 | -- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'AM.edgeList' g 56 | -- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] 57 | -- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] 58 | -- @ 59 | fromAdjacencyMap :: Ord a => AM.AdjacencyMap a -> GraphKL a 60 | fromAdjacencyMap am = GraphKL 61 | { toGraphKL = g 62 | , fromVertexKL = \u -> case r u of (_, v, _) -> v 63 | , toVertexKL = t } 64 | where 65 | (g, r, t) = KL.graphFromEdges [ ((), x, ys) | (x, ys) <- AM.adjacencyList am ] 66 | 67 | -- | Build 'GraphKL' from an 'AIM.AdjacencyIntMap'. If 68 | -- @fromAdjacencyIntMap g == h@ then the following holds: 69 | -- 70 | -- @ 71 | -- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Data.IntSet.toAscList' ('Algebra.Graph.AdjacencyIntMap.vertexIntSet' g) 72 | -- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyIntMap.edgeList' g 73 | -- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] 74 | -- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] 75 | -- @ 76 | fromAdjacencyIntMap :: AIM.AdjacencyIntMap -> GraphKL Int 77 | fromAdjacencyIntMap aim = GraphKL 78 | { toGraphKL = g 79 | , fromVertexKL = \x -> case r x of (_, v, _) -> v 80 | , toVertexKL = t } 81 | where 82 | (g, r, t) = KL.graphFromEdges [ ((), x, ys) | (x, ys) <- AIM.adjacencyList aim ] 83 | 84 | -- | Compute the /depth-first search/ forest of a graph. 85 | -- 86 | -- In the following examples we will use the helper function: 87 | -- 88 | -- @ 89 | -- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b 90 | -- f % x = f ('fromAdjacencyMap' x) 91 | -- @ 92 | -- 93 | -- for greater clarity. 94 | -- 95 | -- @ 96 | -- 'AM.forest' (dfsForest % 'AM.edge' 1 1) == 'AM.vertex' 1 97 | -- 'AM.forest' (dfsForest % 'AM.edge' 1 2) == 'AM.edge' 1 2 98 | -- 'AM.forest' (dfsForest % 'AM.edge' 2 1) == 'AM.vertices' [1,2] 99 | -- 'AM.isSubgraphOf' ('AM.forest' $ dfsForest % x) x == True 100 | -- dfsForest % 'AM.forest' (dfsForest % x) == dfsForest % x 101 | -- dfsForest % 'AM.vertices' vs == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) 102 | -- dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 103 | -- , subForest = [ Node { rootLabel = 5 104 | -- , subForest = [] }]} 105 | -- , Node { rootLabel = 3 106 | -- , subForest = [ Node { rootLabel = 4 107 | -- , subForest = [] }]}] 108 | -- @ 109 | dfsForest :: GraphKL a -> Forest a 110 | dfsForest (GraphKL g r _) = fmap (fmap r) (KL.dff g) 111 | 112 | -- | Compute the /depth-first search/ forest of a graph, searching from each of 113 | -- the given vertices in order. Note that the resulting forest does not 114 | -- necessarily span the whole graph, as some vertices may be unreachable. 115 | -- 116 | -- In the following examples we will use the helper function: 117 | -- 118 | -- @ 119 | -- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b 120 | -- f % x = f ('fromAdjacencyMap' x) 121 | -- @ 122 | -- 123 | -- for greater clarity. 124 | -- 125 | -- @ 126 | -- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 1) [1] == 'AM.vertex' 1 127 | -- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [0] == 'AM.empty' 128 | -- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [1] == 'AM.edge' 1 2 129 | -- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [2] == 'AM.vertex' 2 130 | -- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [2,1] == 'AM.vertices' [1,2] 131 | -- 'AM.isSubgraphOf' ('AM.forest' $ dfsForestFrom % x $ vs) x == True 132 | -- dfsForestFrom % x $ 'AM.vertexList' x == 'dfsForest' % x 133 | -- dfsForestFrom % 'AM.vertices' vs $ vs == 'map' (\\v -> Node v []) ('Data.List.nub' vs) 134 | -- dfsForestFrom % x $ [] == [] 135 | -- dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [ Node { rootLabel = 1 136 | -- , subForest = [ Node { rootLabel = 5 137 | -- , subForest = [] } 138 | -- , Node { rootLabel = 4 139 | -- , subForest = [] }] 140 | -- @ 141 | dfsForestFrom :: GraphKL a -> [a] -> Forest a 142 | dfsForestFrom (GraphKL g r t) = fmap (fmap r) . KL.dfs g . mapMaybe t 143 | 144 | -- | Compute the list of vertices visited by the /depth-first search/ in a 145 | -- graph, when searching from each of the given vertices in order. 146 | -- 147 | -- In the following examples we will use the helper function: 148 | -- 149 | -- @ 150 | -- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b 151 | -- f % x = f ('fromAdjacencyMap' x) 152 | -- @ 153 | -- 154 | -- for greater clarity. 155 | -- 156 | -- @ 157 | -- dfs % 'AM.edge' 1 1 $ [1] == [1] 158 | -- dfs % 'AM.edge' 1 2 $ [0] == [] 159 | -- dfs % 'AM.edge' 1 2 $ [1] == [1,2] 160 | -- dfs % 'AM.edge' 1 2 $ [2] == [2] 161 | -- dfs % 'AM.edge' 1 2 $ [1,2] == [1,2] 162 | -- dfs % 'AM.edge' 1 2 $ [2,1] == [2,1] 163 | -- dfs % x $ [] == [] 164 | -- 165 | -- dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [1,5,4] 166 | -- 'Data.List.and' [ 'AM.hasVertex' v x | v <- dfs % x $ vs ] == True 167 | -- @ 168 | dfs :: GraphKL a -> [a] -> [a] 169 | dfs x = concatMap flatten . dfsForestFrom x 170 | 171 | -- | Compute the /topological sort/ of a graph. Note that this function returns 172 | -- a result even if the graph is cyclic. 173 | -- 174 | -- In the following examples we will use the helper function: 175 | -- 176 | -- @ 177 | -- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b 178 | -- f % x = f ('fromAdjacencyMap' x) 179 | -- @ 180 | -- 181 | -- for greater clarity. 182 | -- 183 | -- @ 184 | -- topSort % (1 * 2 + 3 * 1) == [3,1,2] 185 | -- topSort % (1 * 2 + 2 * 1) == [1,2] 186 | -- @ 187 | topSort :: GraphKL a -> [a] 188 | topSort (GraphKL g r _) = map r (KL.topSort g) 189 | 190 | -- TODO: Add docs and tests. 191 | scc :: Ord a => AM.AdjacencyMap a -> AM.AdjacencyMap (NonEmpty.AdjacencyMap a) 192 | scc m = AM.gmap (component Map.!) $ removeSelfLoops $ AM.gmap (leader Map.!) m 193 | where 194 | GraphKL g decode _ = fromAdjacencyMap m 195 | sccs = map toList (KL.scc g) 196 | leader = Map.fromList [ (decode y, x) | x:xs <- sccs, y <- x:xs ] 197 | component = Map.fromList [ (x, expand (x:xs)) | x:xs <- sccs ] 198 | expand xs = fromJust $ NonEmpty.toNonEmpty $ AM.induce (`Set.member` s) m 199 | where 200 | s = Set.fromList (map decode xs) 201 | 202 | removeSelfLoops :: Ord a => AM.AdjacencyMap a -> AM.AdjacencyMap a 203 | removeSelfLoops m = foldr (\x -> AM.removeEdge x x) m (AM.vertexList m) 204 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Test.Arbitrary 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- Generators and orphan Arbitrary instances for various data types. 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Test.Arbitrary ( 13 | -- * Generators of arbitrary graph instances 14 | arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, 15 | ) where 16 | 17 | import Data.List.NonEmpty (NonEmpty (..), toList) 18 | import Data.Maybe (catMaybes) 19 | import Test.QuickCheck 20 | 21 | import Algebra.Graph 22 | import Algebra.Graph.Export 23 | import Algebra.Graph.Label 24 | 25 | import qualified Algebra.Graph.Undirected as UG 26 | import qualified Algebra.Graph.Acyclic.AdjacencyMap as AAM 27 | import qualified Algebra.Graph.AdjacencyIntMap as AIM 28 | import qualified Algebra.Graph.AdjacencyMap as AM 29 | import qualified Algebra.Graph.Bipartite.AdjacencyMap as BAM 30 | import qualified Algebra.Graph.Bipartite.AdjacencyMap.Algorithm as BAMA 31 | import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM 32 | import qualified Algebra.Graph.Class as C 33 | import qualified Algebra.Graph.Labelled as LG 34 | import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM 35 | import qualified Algebra.Graph.NonEmpty as NonEmpty 36 | import qualified Algebra.Graph.Relation as Relation 37 | import qualified Algebra.Graph.Relation.Preorder as Preorder 38 | import qualified Algebra.Graph.Relation.Reflexive as Reflexive 39 | import qualified Algebra.Graph.Relation.Symmetric as Symmetric 40 | import qualified Algebra.Graph.Relation.Transitive as Transitive 41 | 42 | -- | Generate an arbitrary 'C.Graph' value of a specified size. 43 | arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g 44 | arbitraryGraph = sized expr 45 | where 46 | expr 0 = return C.empty 47 | expr 1 = C.vertex <$> arbitrary 48 | expr n = do 49 | left <- choose (0, n) 50 | oneof [ C.overlay <$> expr left <*> expr (n - left) 51 | , C.connect <$> expr left <*> expr (n - left) ] 52 | 53 | instance Arbitrary a => Arbitrary (Graph a) where 54 | arbitrary = arbitraryGraph 55 | 56 | shrink Empty = [] 57 | shrink (Vertex _) = [Empty] 58 | shrink (Overlay x y) = [Empty, x, y] 59 | ++ [Overlay x' y' | (x', y') <- shrink (x, y) ] 60 | shrink (Connect x y) = [Empty, x, y, Overlay x y] 61 | ++ [Connect x' y' | (x', y') <- shrink (x, y) ] 62 | 63 | -- An Arbitrary instance for Graph.Undirected 64 | instance Arbitrary a => Arbitrary (UG.Graph a) where 65 | arbitrary = arbitraryGraph 66 | 67 | -- An Arbitrary instance for Acyclic.AdjacencyMap 68 | instance (Ord a, Arbitrary a) => Arbitrary (AAM.AdjacencyMap a) where 69 | arbitrary = AAM.shrink <$> arbitrary 70 | 71 | shrink g = shrinkVertices ++ shrinkEdges 72 | where 73 | shrinkVertices = 74 | let vertices = AAM.vertexList g 75 | in [ AAM.removeVertex x g | x <- vertices ] 76 | 77 | shrinkEdges = 78 | let edges = AAM.edgeList g 79 | in [ AAM.removeEdge x y g | (x, y) <- edges ] 80 | 81 | -- | Generate an arbitrary 'NonEmpty.Graph' value of a specified size. 82 | arbitraryNonEmptyGraph :: Arbitrary a => Gen (NonEmpty.Graph a) 83 | arbitraryNonEmptyGraph = sized expr 84 | where 85 | expr 0 = NonEmpty.vertex <$> arbitrary -- can't generate non-empty graph of size 0 86 | expr 1 = NonEmpty.vertex <$> arbitrary 87 | expr n = do 88 | left <- choose (1, n) 89 | oneof [ NonEmpty.overlay <$> expr left <*> expr (n - left) 90 | , NonEmpty.connect <$> expr left <*> expr (n - left) ] 91 | 92 | instance Arbitrary a => Arbitrary (NonEmpty.Graph a) where 93 | arbitrary = arbitraryNonEmptyGraph 94 | 95 | shrink (NonEmpty.Vertex _) = [] 96 | shrink (NonEmpty.Overlay x y) = [x, y] 97 | ++ [NonEmpty.Overlay x' y' | (x', y') <- shrink (x, y) ] 98 | shrink (NonEmpty.Connect x y) = [x, y, NonEmpty.Overlay x y] 99 | ++ [NonEmpty.Connect x' y' | (x', y') <- shrink (x, y) ] 100 | 101 | -- | Generate an arbitrary 'Relation'. 102 | arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation.Relation a) 103 | arbitraryRelation = Relation.stars <$> arbitrary 104 | 105 | -- TODO: Implement a custom shrink method. 106 | instance (Arbitrary a, Ord a) => Arbitrary (Relation.Relation a) where 107 | arbitrary = arbitraryRelation 108 | 109 | shrink g = shrinkVertices ++ shrinkEdges 110 | where 111 | shrinkVertices = 112 | let vertices = Relation.vertexList g 113 | in [ Relation.removeVertex v g | v <- vertices ] 114 | 115 | shrinkEdges = 116 | let edges = Relation.edgeList g 117 | in [ Relation.removeEdge v w g | (v, w) <- edges ] 118 | 119 | -- TODO: Simplify. 120 | instance (Arbitrary a, Ord a) => Arbitrary (Reflexive.ReflexiveRelation a) where 121 | arbitrary = Reflexive.fromRelation . Relation.reflexiveClosure 122 | <$> arbitraryRelation 123 | 124 | instance (Arbitrary a, Ord a) => Arbitrary (Symmetric.Relation a) where 125 | arbitrary = Symmetric.toSymmetric <$> arbitraryRelation 126 | 127 | instance (Arbitrary a, Ord a) => Arbitrary (Transitive.TransitiveRelation a) where 128 | arbitrary = Transitive.fromRelation . Relation.transitiveClosure 129 | <$> arbitraryRelation 130 | 131 | instance (Arbitrary a, Ord a) => Arbitrary (Preorder.PreorderRelation a) where 132 | arbitrary = Preorder.fromRelation . Relation.closure 133 | <$> arbitraryRelation 134 | 135 | -- | Generate an arbitrary 'AdjacencyMap'. It is guaranteed that the 136 | -- resulting adjacency map is 'consistent'. 137 | arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AM.AdjacencyMap a) 138 | arbitraryAdjacencyMap = AM.stars <$> arbitrary 139 | 140 | instance (Arbitrary a, Ord a) => Arbitrary (AM.AdjacencyMap a) where 141 | arbitrary = arbitraryAdjacencyMap 142 | 143 | shrink g = shrinkVertices ++ shrinkEdges 144 | where 145 | shrinkVertices = [ AM.removeVertex v g | v <- AM.vertexList g ] 146 | shrinkEdges = [ AM.removeEdge v w g | (v, w) <- AM.edgeList g ] 147 | 148 | -- | Generate an arbitrary non-empty 'NAM.AdjacencyMap'. It is guaranteed that 149 | -- the resulting adjacency map is 'consistent'. 150 | arbitraryNonEmptyAdjacencyMap :: (Arbitrary a, Ord a) => Gen (NAM.AdjacencyMap a) 151 | arbitraryNonEmptyAdjacencyMap = NAM.stars1 <$> nonEmpty 152 | where 153 | nonEmpty = do 154 | xs <- arbitrary 155 | case xs of 156 | [] -> do 157 | x <- arbitrary 158 | return ((x, []) :| []) -- There must be at least one vertex 159 | (x:xs) -> return (x :| xs) 160 | 161 | instance (Arbitrary a, Ord a) => Arbitrary (NAM.AdjacencyMap a) where 162 | arbitrary = arbitraryNonEmptyAdjacencyMap 163 | 164 | shrink g = shrinkVertices ++ shrinkEdges 165 | where 166 | shrinkVertices = 167 | let vertices = toList $ NAM.vertexList1 g 168 | in catMaybes [ NAM.removeVertex1 v g | v <- vertices ] 169 | 170 | shrinkEdges = 171 | let edges = NAM.edgeList g 172 | in [ NAM.removeEdge v w g | (v, w) <- edges ] 173 | 174 | instance Arbitrary AIM.AdjacencyIntMap where 175 | arbitrary = AIM.stars <$> arbitrary 176 | 177 | shrink g = shrinkVertices ++ shrinkEdges 178 | where 179 | shrinkVertices = [ AIM.removeVertex x g | x <- AIM.vertexList g ] 180 | shrinkEdges = [ AIM.removeEdge x y g | (x, y) <- AIM.edgeList g ] 181 | 182 | -- | Generate an arbitrary labelled 'LAM.AdjacencyMap'. It is guaranteed 183 | -- that the resulting adjacency map is 'consistent'. 184 | arbitraryLabelledAdjacencyMap :: (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Gen (LAM.AdjacencyMap e a) 185 | arbitraryLabelledAdjacencyMap = LAM.fromAdjacencyMaps <$> arbitrary 186 | 187 | instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.AdjacencyMap e a) where 188 | arbitrary = arbitraryLabelledAdjacencyMap 189 | 190 | shrink g = shrinkVertices ++ shrinkEdges 191 | where 192 | shrinkVertices = 193 | let vertices = LAM.vertexList g 194 | in [ LAM.removeVertex v g | v <- vertices ] 195 | 196 | shrinkEdges = 197 | let edges = LAM.edgeList g 198 | in [ LAM.removeEdge v w g | (_, v, w) <- edges ] 199 | 200 | -- | Generate an arbitrary labelled 'LAM.Graph' value of a specified size. 201 | arbitraryLabelledGraph :: (Arbitrary a, Arbitrary e) => Gen (LG.Graph e a) 202 | arbitraryLabelledGraph = sized expr 203 | where 204 | expr 0 = return LG.empty 205 | expr 1 = LG.vertex <$> arbitrary 206 | expr n = do 207 | label <- arbitrary 208 | left <- choose (0, n) 209 | LG.connect label <$> expr left <*> expr (n - left) 210 | 211 | instance (Arbitrary a, Arbitrary e, Monoid e) => Arbitrary (LG.Graph e a) where 212 | arbitrary = arbitraryLabelledGraph 213 | 214 | shrink LG.Empty = [] 215 | shrink (LG.Vertex _) = [LG.Empty] 216 | shrink (LG.Connect e x y) = [LG.Empty, x, y, LG.Connect mempty x y] 217 | ++ [LG.Connect e x' y' | (x', y') <- shrink (x, y) ] 218 | 219 | -- TODO: Implement a custom shrink method. 220 | instance Arbitrary s => Arbitrary (Doc s) where 221 | arbitrary = mconcat . map literal <$> arbitrary 222 | 223 | instance (Arbitrary a, Num a, Ord a) => Arbitrary (Distance a) where 224 | arbitrary = (\x -> if x < 0 then distance infinite else distance (unsafeFinite x)) <$> arbitrary 225 | 226 | instance (Arbitrary a, Num a, Ord a) => Arbitrary (Capacity a) where 227 | arbitrary = (\x -> if x < 0 then capacity infinite else capacity (unsafeFinite x)) <$> arbitrary 228 | 229 | instance (Arbitrary a, Num a, Ord a) => Arbitrary (Count a) where 230 | arbitrary = (\x -> if x < 0 then count infinite else count (unsafeFinite x)) <$> arbitrary 231 | 232 | instance Arbitrary a => Arbitrary (Minimum a) where 233 | arbitrary = frequency [(10, pure <$> arbitrary), (1, pure noMinimum)] 234 | 235 | instance (Arbitrary a, Ord a) => Arbitrary (PowerSet a) where 236 | arbitrary = PowerSet <$> arbitrary 237 | 238 | instance (Arbitrary o, Arbitrary a) => Arbitrary (Optimum o a) where 239 | arbitrary = Optimum <$> arbitrary <*> arbitrary 240 | 241 | instance (Arbitrary a, Arbitrary b, Ord a, Ord b) => Arbitrary (BAM.AdjacencyMap a b) where 242 | arbitrary = BAM.toBipartite <$> arbitrary 243 | shrink = map BAM.toBipartite . shrink . BAM.fromBipartite 244 | 245 | instance (Arbitrary a, Arbitrary b) => Arbitrary (BAM.List a b) where 246 | arbitrary = sized go 247 | where 248 | go 0 = return BAM.Nil 249 | go 1 = do h <- arbitrary 250 | return $ BAM.Cons h BAM.Nil 251 | go n = do f <- arbitrary 252 | s <- arbitrary 253 | (BAM.Cons f . BAM.Cons s) <$> go (n - 2) 254 | 255 | instance (Arbitrary a, Arbitrary b, Ord a, Ord b) => Arbitrary (BAMA.Matching a b) where 256 | arbitrary = BAMA.matching <$> arbitrary 257 | -------------------------------------------------------------------------------- /test/Algebra/Graph/Test/RewriteRules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.Test.RewriteRules 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : experimental 9 | -- 10 | -- Testsuite for "Algebra.Graph" rewrite rules. 11 | ----------------------------------------------------------------------------- 12 | module Algebra.Graph.Test.RewriteRules where 13 | 14 | import Data.Maybe (fromMaybe) 15 | 16 | import qualified Algebra.Graph.AdjacencyMap as AM 17 | import qualified Data.Set as Set 18 | 19 | import Algebra.Graph hiding ((===)) 20 | import Algebra.Graph.Internal 21 | 22 | import GHC.Base (build) 23 | 24 | import Test.Inspection 25 | 26 | type Build a = forall b. (a -> b -> b) -> b -> b 27 | type Buildg a = forall b. b -> (a -> b) -> (b -> b ->b ) -> (b -> b-> b) -> b 28 | 29 | {- We suffix various values using the following convention: 30 | 31 | * "R": the desired outcome of a rewrite rule 32 | * "C": the "good consumer" property 33 | * "P": the "good producer" property 34 | * "I": inlining 35 | * "T": specialisation for a type 36 | -} 37 | 38 | -- 'foldg' 39 | emptyI, emptyIR :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b 40 | emptyI e v o c = foldg e v o c Empty 41 | emptyIR e _ _ _ = e 42 | 43 | inspect $ 'emptyI === 'emptyIR 44 | 45 | vertexI, vertexIR :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> a -> b 46 | vertexI e v o c x = foldg e v o c (Vertex x) 47 | vertexIR _ v _ _ x = v x 48 | 49 | inspect $ 'vertexI === 'vertexIR 50 | 51 | overlayI, overlayIR :: 52 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> Graph a -> b 53 | overlayI e v o c x y = foldg e v o c (Overlay x y) 54 | overlayIR e v o c x y = o (foldg e v o c x) (foldg e v o c y) 55 | 56 | inspect $ 'overlayI === 'overlayIR 57 | 58 | connectI, connectIR :: 59 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> Graph a -> b 60 | connectI e v o c x y = foldg e v o c (Connect x y) 61 | connectIR e v o c x y = c (foldg e v o c x) (foldg e v o c y) 62 | 63 | inspect $ 'connectI === 'connectIR 64 | 65 | -- overlays 66 | overlaysC :: Build (Graph a) -> Graph a 67 | overlaysC xs = overlays (build xs) 68 | 69 | inspect $ 'overlaysC `hasNoType` ''[] 70 | 71 | overlaysP, overlaysPR :: 72 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [Graph a] -> b 73 | overlaysP e v o c xs = foldg e v o c (overlays xs) 74 | overlaysPR e v o c xs = fromMaybe e (foldr (maybeF o . foldg e v o c) Nothing xs) 75 | 76 | inspect $ 'overlaysP === 'overlaysPR 77 | 78 | -- vertices 79 | verticesCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> b 80 | verticesCP e v o c xs = foldg e v o c (vertices (build xs)) 81 | 82 | inspect $ 'verticesCP `hasNoType` ''[] 83 | inspect $ 'verticesCP `hasNoType` ''Graph 84 | 85 | -- connects 86 | connectsC :: Build (Graph a) -> Graph a 87 | connectsC xs = connects (build xs) 88 | 89 | inspect $ 'connectsC `hasNoType` ''[] 90 | 91 | connectsP, connectsPR :: 92 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [Graph a] -> b 93 | connectsP e v o c xs = foldg e v o c (connects xs) 94 | connectsPR e v o c xs = fromMaybe e (foldr (maybeF c . foldg e v o c) Nothing xs) 95 | 96 | inspect $ 'connectsP === 'connectsPR 97 | 98 | -- isSubgraphOf 99 | isSubgraphOfC :: Ord a => Buildg a -> Buildg a -> Bool 100 | isSubgraphOfC x y = isSubgraphOf (buildg x) (buildg y) 101 | 102 | inspect $ 'isSubgraphOfC `hasNoType` ''Graph 103 | 104 | -- clique 105 | cliqueCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> b 106 | cliqueCP e v o c xs = foldg e v o c (clique (build xs)) 107 | 108 | inspect $ 'cliqueCP `hasNoType` ''[] 109 | inspect $ 'cliqueCP `hasNoType` ''Graph 110 | 111 | -- edges 112 | edgesCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build (a,a) -> b 113 | edgesCP e v o c xs = foldg e v o c (edges (build xs)) 114 | 115 | inspect $ 'edgesCP `hasNoType` ''[] 116 | inspect $ 'edgesCP `hasNoType` ''Graph 117 | 118 | -- star 119 | starCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> a -> Build a -> b 120 | starCP e v o c x xs = foldg e v o c (star x (build xs)) 121 | 122 | inspect $ 'starCP `hasNoType` ''[] 123 | inspect $ 'starCP `hasNoType` ''Graph 124 | 125 | -- fmap 126 | fmapCP :: 127 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> a) -> Buildg c -> b 128 | fmapCP e v o c f g = foldg e v o c (fmap f (buildg g)) 129 | 130 | inspect $ 'fmapCP `hasNoType` ''Graph 131 | 132 | -- bind 133 | bindC, bindCR :: (a -> Graph b) -> Buildg a -> Graph b 134 | bindC f g = (buildg g) >>= f 135 | bindCR f g = g Empty (\x -> f x) Overlay Connect 136 | 137 | inspect $ 'bindC === 'bindCR 138 | 139 | bindP, bindPR :: 140 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> Graph a) -> Graph c -> b 141 | bindP e v o c f g = foldg e v o c (g >>= f) 142 | bindPR e v o c f g = foldg e (foldg e v o c . f) o c g 143 | 144 | inspect $ 'bindP === 'bindPR 145 | 146 | -- ap 147 | apC, apCR :: Buildg (a -> b) -> Graph a -> Graph b 148 | apC f x = buildg f <*> x 149 | apCR f x = f Empty (\v -> foldg Empty (Vertex . v) Overlay Connect x) Overlay Connect 150 | 151 | inspect $ 'apC === 'apCR 152 | 153 | apP, apPR :: 154 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph (c -> a) -> Graph c -> b 155 | apP e v o c f x = foldg e v o c (f <*> x) 156 | apPR e v o c f x = 157 | foldg e (\w -> foldg e (v . w) o c x) o c f 158 | 159 | inspect $ 'apP === 'apPR 160 | 161 | -- eq 162 | eqC :: Ord a => Buildg a -> Buildg a -> Bool 163 | eqC x y = buildg x == buildg y 164 | 165 | inspect $ 'eqC `hasNoType` ''Graph 166 | 167 | eqT :: Graph Int -> Graph Int -> Bool 168 | eqT x y = x == y 169 | 170 | inspect $ 'eqT `hasNoType` ''AM.AdjacencyMap 171 | 172 | -- ord 173 | ordC :: Ord a => Buildg a -> Buildg a -> Ordering 174 | ordC x y = compare (buildg x) (buildg y) 175 | 176 | inspect $ 'ordC `hasNoType` ''Graph 177 | 178 | ordT :: Graph Int -> Graph Int -> Ordering 179 | ordT x y = compare x y 180 | 181 | inspect $ 'ordT `hasNoType` ''AM.AdjacencyMap 182 | 183 | -- isEmpty 184 | isEmptyC :: Buildg a -> Bool 185 | isEmptyC g = isEmpty (buildg g) 186 | 187 | inspect $ 'isEmptyC `hasNoType` ''Graph 188 | 189 | -- size 190 | sizeC :: Buildg a -> Int 191 | sizeC g = size (buildg g) 192 | 193 | inspect $ 'sizeC `hasNoType` ''Graph 194 | 195 | -- vertexSet 196 | vertexSetC :: Ord a => Buildg a -> Set.Set a 197 | vertexSetC g = vertexSet (buildg g) 198 | 199 | inspect $ 'vertexSetC `hasNoType` ''Graph 200 | 201 | -- vertexCount 202 | vertexCountC :: Ord a => Buildg a -> Int 203 | vertexCountC g = vertexCount (buildg g) 204 | 205 | inspect $ 'vertexSetC `hasNoType` ''Graph 206 | 207 | vertexCountT :: Graph Int -> Int 208 | vertexCountT g = vertexCount g 209 | 210 | inspect $ 'vertexCountT `hasNoType` ''Set.Set 211 | 212 | -- edgeCount 213 | edgeCountC :: Ord a => Buildg a -> Int 214 | edgeCountC g = edgeCount (buildg g) 215 | 216 | inspect $ 'edgeCountC `hasNoType` ''Graph 217 | 218 | edgeCountT :: Graph Int -> Int 219 | edgeCountT g = edgeCount g 220 | 221 | inspect $ 'edgeCountT `hasNoType` ''Set.Set 222 | 223 | -- vertexList 224 | vertexListCP :: Ord a => (a -> b -> b) -> b -> Buildg a -> b 225 | vertexListCP k c g = foldr k c (vertexList (buildg g)) 226 | 227 | inspect $ 'vertexListCP `hasNoType` ''Graph 228 | inspect $ 'vertexListCP `hasNoType` ''[] 229 | 230 | vertexListT :: Graph Int -> [Int] 231 | vertexListT g = vertexList g 232 | 233 | inspect $ 'vertexListT `hasNoType` ''Set.Set 234 | 235 | -- edgeSet 236 | edgeSetC :: Ord a => Buildg a -> Set.Set (a,a) 237 | edgeSetC g = edgeSet (buildg g) 238 | 239 | inspect $ 'edgeSetC `hasNoType` ''Graph 240 | 241 | edgeSetT :: Graph Int -> Set.Set (Int,Int) 242 | edgeSetT g = edgeSet g 243 | 244 | inspect $ 'vertexListT `hasNoType` ''AM.AdjacencyMap 245 | 246 | -- edgeList 247 | edgeListCP :: Ord a => ((a,a) -> b -> b) -> b -> Buildg a -> b 248 | edgeListCP k c g = foldr k c (edgeList (buildg g)) 249 | 250 | inspect $ 'edgeListCP `hasNoType` ''Graph 251 | inspect $ 'edgeListCP `hasNoType` ''[] 252 | 253 | edgeListT :: Graph Int -> [(Int,Int)] 254 | edgeListT g = edgeList g 255 | 256 | inspect $ 'edgeListT `hasNoType` ''AM.AdjacencyMap 257 | 258 | -- hasVertex 259 | hasVertexC :: Eq a => a -> Buildg a -> Bool 260 | hasVertexC x g = hasVertex x (buildg g) 261 | 262 | inspect $ 'hasVertexC `hasNoType` ''Graph 263 | 264 | -- hasEdge 265 | hasEdgeC :: Eq a => a -> a -> Buildg a -> Bool 266 | hasEdgeC x y g = hasEdge x y (buildg g) 267 | 268 | inspect $ 'hasEdgeC `hasNoType` ''Graph 269 | 270 | -- adjacencyList 271 | adjacencyListC :: Ord a => Buildg a -> [(a, [a])] 272 | adjacencyListC g = adjacencyList (buildg g) 273 | 274 | inspect $ 'adjacencyListC `hasNoType` ''Graph 275 | 276 | -- path 277 | pathP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [a] -> b 278 | pathP e v o c xs = foldg e v o c (path xs) 279 | 280 | inspect $ 'pathP `hasNoType` ''Graph 281 | 282 | -- circuit 283 | circuitP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [a] -> b 284 | circuitP e v o c xs = foldg e v o c (circuit xs) 285 | 286 | inspect $ 'circuitP `hasNoType` ''Graph 287 | 288 | -- biclique 289 | bicliqueCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> Build a -> b 290 | bicliqueCP e v o c xs ys = foldg e v o c (biclique (build xs) (build ys)) 291 | 292 | inspect $ 'bicliqueCP `hasNoType` ''[] 293 | inspect $ 'bicliqueCP `hasNoType` ''Graph 294 | 295 | -- replaceVertex 296 | replaceVertexCP :: Eq a => a -> a -> 297 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b 298 | replaceVertexCP u v e v' o c g = 299 | foldg e v' o c (replaceVertex u v (buildg g)) 300 | 301 | inspect $ 'replaceVertexCP `hasNoType` ''Graph 302 | 303 | -- mergeVertices 304 | mergeVerticesCP :: (a -> Bool) -> a -> 305 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b 306 | mergeVerticesCP p v e v' o c g = 307 | foldg e v' o c (mergeVertices p v (buildg g)) 308 | 309 | inspect $ 'mergeVerticesCP `hasNoType` ''Graph 310 | 311 | -- splitVertex 312 | splitVertexCP :: Eq a => a -> Build a -> 313 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b 314 | splitVertexCP x us e v o c g = foldg e v o c (splitVertex x (build us) (buildg g)) 315 | 316 | inspect $ 'splitVertexCP `hasNoType` ''[] 317 | inspect $ 'splitVertexCP `hasNoType` ''Graph 318 | 319 | -- transpose 320 | transposeCP :: 321 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b 322 | transposeCP e v o c g = foldg e v o c (transpose (buildg g)) 323 | 324 | inspect $ 'transposeCP `hasNoType` ''Graph 325 | 326 | -- simplify 327 | simple :: Eq g => (g -> g -> g) -> g -> g -> g 328 | simple op x y 329 | | x == z = x 330 | | y == z = y 331 | | otherwise = z 332 | where 333 | z = op x y 334 | 335 | simplifyC, simplifyCR :: Ord a => Buildg a -> Graph a 336 | simplifyC g = simplify (buildg g) 337 | simplifyCR g = g Empty Vertex (simple Overlay) (simple Connect) 338 | 339 | inspect $ 'simplifyC === 'simplifyCR 340 | 341 | -- compose 342 | composeCP :: Ord a => b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> Buildg a -> b 343 | composeCP e v o c x y = foldg e v o c $ compose (buildg x) (buildg y) 344 | 345 | inspect $ 'composeCP `hasNoType` ''Graph 346 | 347 | -- induce 348 | induceCP :: 349 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (a -> Bool) -> Buildg a -> b 350 | induceCP e v o c p g = foldg e v o c (induce p (buildg g)) 351 | 352 | inspect $ 'induceCP `hasNoType` ''Graph 353 | 354 | -- induceJust 355 | induceJustCP :: 356 | b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg (Maybe a) -> b 357 | induceJustCP e v o c g = foldg e v o c (induceJust (buildg g)) 358 | 359 | inspect $ 'induceJustCP `hasNoType` ''Graph 360 | 361 | -- context 362 | contextC :: (a -> Bool) -> Buildg a -> Maybe (Context a) 363 | contextC p g = context p (buildg g) 364 | 365 | inspect $ 'contextC `hasNoType` ''Graph 366 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Class.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Class 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 10 | -- in Haskell. See for the 11 | -- motivation behind the library, the underlying theory, and implementation details. 12 | -- 13 | -- This module defines the core type class 'Graph', a few graph subclasses, and 14 | -- basic polymorphic graph construction primitives. Functions that cannot be 15 | -- implemented fully polymorphically and require the use of an intermediate data 16 | -- type are not included. For example, to compute the number of vertices in a 17 | -- 'Graph' expression you will need to use a concrete data type, such as 18 | -- "Algebra.Graph.Graph" or "Algebra.Graph.AdjacencyMap". 19 | -- 20 | -- See "Algebra.Graph.HigherKinded.Class" for the higher-kinded version of the 21 | -- core graph type class. 22 | ----------------------------------------------------------------------------- 23 | module Algebra.Graph.Class ( 24 | -- * The core type class 25 | Graph (..), 26 | 27 | -- * Undirected graphs 28 | Undirected, 29 | 30 | -- * Reflexive graphs 31 | Reflexive, 32 | 33 | -- * Transitive graphs 34 | Transitive, 35 | 36 | -- * Preorders 37 | Preorder, 38 | 39 | -- * Basic graph construction primitives 40 | edge, vertices, overlays, connects, edges, 41 | 42 | -- * Relations on graphs 43 | isSubgraphOf, 44 | 45 | -- * Standard families of graphs 46 | path, circuit, clique, biclique, star, tree, forest 47 | ) where 48 | 49 | import Data.Tree (Forest, Tree (..)) 50 | 51 | import Algebra.Graph.Label (Dioid, one) 52 | 53 | import qualified Algebra.Graph as G 54 | import qualified Algebra.Graph.Undirected as UG 55 | import qualified Algebra.Graph.AdjacencyMap as AM 56 | import qualified Algebra.Graph.Labelled as LG 57 | import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM 58 | import qualified Algebra.Graph.AdjacencyIntMap as AIM 59 | import qualified Algebra.Graph.Relation as R 60 | import qualified Algebra.Graph.Relation.Symmetric as RS 61 | 62 | {-| 63 | The core type class for constructing algebraic graphs, characterised by the 64 | following minimal set of axioms. In equations we use @+@ and @*@ as convenient 65 | shortcuts for 'overlay' and 'connect', respectively. 66 | 67 | * 'overlay' is commutative and associative: 68 | 69 | > x + y == y + x 70 | > x + (y + z) == (x + y) + z 71 | 72 | * 'connect' is associative and has 'empty' as the identity: 73 | 74 | > x * empty == x 75 | > empty * x == x 76 | > x * (y * z) == (x * y) * z 77 | 78 | * 'connect' distributes over 'overlay': 79 | 80 | > x * (y + z) == x * y + x * z 81 | > (x + y) * z == x * z + y * z 82 | 83 | * 'connect' can be decomposed: 84 | 85 | > x * y * z == x * y + x * z + y * z 86 | 87 | The following useful theorems can be proved from the above set of axioms. 88 | 89 | * 'overlay' has 'empty' as the identity and is idempotent: 90 | 91 | > x + empty == x 92 | > empty + x == x 93 | > x + x == x 94 | 95 | * Absorption and saturation of 'connect': 96 | 97 | > x * y + x + y == x * y 98 | > x * x * x == x * x 99 | 100 | The core type class 'Graph' corresponds to unlabelled directed graphs. 101 | 'Undirected', 'Reflexive', 'Transitive' and 'Preorder' graphs can be obtained 102 | by extending the minimal set of axioms. 103 | 104 | When specifying the time and memory complexity of graph algorithms, /n/ will 105 | denote the number of vertices in the graph, /m/ will denote the number of 106 | edges in the graph, and /s/ will denote the /size/ of the corresponding 107 | 'Graph' expression. 108 | -} 109 | class Graph g where 110 | -- | The type of graph vertices. 111 | type Vertex g 112 | -- | Construct the empty graph. 113 | empty :: g 114 | -- | Construct the graph with a single vertex. 115 | vertex :: Vertex g -> g 116 | -- | Overlay two graphs. 117 | overlay :: g -> g -> g 118 | -- | Connect two graphs. 119 | connect :: g -> g -> g 120 | 121 | instance Graph (G.Graph a) where 122 | type Vertex (G.Graph a) = a 123 | empty = G.empty 124 | vertex = G.vertex 125 | overlay = G.overlay 126 | connect = G.connect 127 | 128 | instance Graph (UG.Graph a) where 129 | type Vertex (UG.Graph a) = a 130 | empty = UG.empty 131 | vertex = UG.vertex 132 | overlay = UG.overlay 133 | connect = UG.connect 134 | 135 | instance Undirected (UG.Graph a) 136 | 137 | instance Ord a => Graph (AM.AdjacencyMap a) where 138 | type Vertex (AM.AdjacencyMap a) = a 139 | empty = AM.empty 140 | vertex = AM.vertex 141 | overlay = AM.overlay 142 | connect = AM.connect 143 | 144 | instance Graph AIM.AdjacencyIntMap where 145 | type Vertex AIM.AdjacencyIntMap = Int 146 | empty = AIM.empty 147 | vertex = AIM.vertex 148 | overlay = AIM.overlay 149 | connect = AIM.connect 150 | 151 | instance Dioid e => Graph (LG.Graph e a) where 152 | type Vertex (LG.Graph e a) = a 153 | empty = LG.empty 154 | vertex = LG.vertex 155 | overlay = LG.overlay 156 | connect = LG.connect one 157 | 158 | instance (Dioid e, Eq e, Ord a) => Graph (LAM.AdjacencyMap e a) where 159 | type Vertex (LAM.AdjacencyMap e a) = a 160 | empty = LAM.empty 161 | vertex = LAM.vertex 162 | overlay = LAM.overlay 163 | connect = LAM.connect one 164 | 165 | instance Ord a => Graph (R.Relation a) where 166 | type Vertex (R.Relation a) = a 167 | empty = R.empty 168 | vertex = R.vertex 169 | overlay = R.overlay 170 | connect = R.connect 171 | 172 | instance Ord a => Graph (RS.Relation a) where 173 | type Vertex (RS.Relation a) = a 174 | empty = RS.empty 175 | vertex = RS.vertex 176 | overlay = RS.overlay 177 | connect = RS.connect 178 | 179 | instance Ord a => Undirected (RS.Relation a) 180 | 181 | {-| 182 | The class of /undirected graphs/ that satisfy the following additional axiom. 183 | 184 | * 'connect' is commutative: 185 | 186 | > x * y == y * x 187 | -} 188 | class Graph g => Undirected g 189 | 190 | {-| 191 | The class of /reflexive graphs/ that satisfy the following additional axiom. 192 | 193 | * Each vertex has a /self-loop/: 194 | 195 | > vertex x == vertex x * vertex x 196 | 197 | Note that by applying the axiom in the reverse direction, one can always remove 198 | all self-loops resulting in an /irreflexive graph/. This type class can 199 | therefore be also used in the context of irreflexive graphs. 200 | -} 201 | class Graph g => Reflexive g 202 | 203 | {-| 204 | The class of /transitive graphs/ that satisfy the following additional axiom. 205 | 206 | * The /closure/ axiom: graphs with equal transitive closures are equal. 207 | 208 | > y /= empty ==> x * y + x * z + y * z == x * y + y * z 209 | 210 | By repeated application of the axiom one can turn any graph into its transitive 211 | closure or transitive reduction. 212 | -} 213 | class Graph g => Transitive g 214 | 215 | {-| 216 | The class of /preorder graphs/ that are both reflexive and transitive. 217 | -} 218 | class (Reflexive g, Transitive g) => Preorder g 219 | 220 | instance Graph () where 221 | type Vertex () = () 222 | empty = () 223 | vertex _ = () 224 | overlay _ _ = () 225 | connect _ _ = () 226 | 227 | instance Undirected () 228 | instance Reflexive () 229 | instance Transitive () 230 | instance Preorder () 231 | 232 | -- Note: Maybe g and (a -> g) instances are identical and use the Applicative's 233 | -- pure and <*>. We do not provide a general instance for all Applicative 234 | -- functors because that would lead to overlapping instances. 235 | instance Graph g => Graph (Maybe g) where 236 | type Vertex (Maybe g) = Vertex g 237 | empty = pure empty 238 | vertex = pure . vertex 239 | overlay x y = overlay <$> x <*> y 240 | connect x y = connect <$> x <*> y 241 | 242 | instance Undirected g => Undirected (Maybe g) 243 | instance Reflexive g => Reflexive (Maybe g) 244 | instance Transitive g => Transitive (Maybe g) 245 | instance Preorder g => Preorder (Maybe g) 246 | 247 | instance Graph g => Graph (a -> g) where 248 | type Vertex (a -> g) = Vertex g 249 | empty = pure empty 250 | vertex = pure . vertex 251 | overlay x y = overlay <$> x <*> y 252 | connect x y = connect <$> x <*> y 253 | 254 | instance Undirected g => Undirected (a -> g) 255 | instance Reflexive g => Reflexive (a -> g) 256 | instance Transitive g => Transitive (a -> g) 257 | instance Preorder g => Preorder (a -> g) 258 | 259 | instance (Graph g, Graph h) => Graph (g, h) where 260 | type Vertex (g, h) = (Vertex g , Vertex h ) 261 | empty = (empty , empty ) 262 | vertex (x, y ) = (vertex x , vertex y ) 263 | overlay (x1, y1) (x2, y2) = (overlay x1 x2, overlay y1 y2) 264 | connect (x1, y1) (x2, y2) = (connect x1 x2, connect y1 y2) 265 | 266 | instance (Undirected g, Undirected h) => Undirected (g, h) 267 | instance (Reflexive g, Reflexive h) => Reflexive (g, h) 268 | instance (Transitive g, Transitive h) => Transitive (g, h) 269 | instance (Preorder g, Preorder h) => Preorder (g, h) 270 | 271 | instance (Graph g, Graph h, Graph i) => Graph (g, h, i) where 272 | type Vertex (g, h, i) = (Vertex g , Vertex h , Vertex i ) 273 | empty = (empty , empty , empty ) 274 | vertex (x, y , z ) = (vertex x , vertex y , vertex z ) 275 | overlay (x1, y1, z1) (x2, y2, z2) = (overlay x1 x2, overlay y1 y2, overlay z1 z2) 276 | connect (x1, y1, z1) (x2, y2, z2) = (connect x1 x2, connect y1 y2, connect z1 z2) 277 | 278 | instance (Undirected g, Undirected h, Undirected i) => Undirected (g, h, i) 279 | instance (Reflexive g, Reflexive h, Reflexive i) => Reflexive (g, h, i) 280 | instance (Transitive g, Transitive h, Transitive i) => Transitive (g, h, i) 281 | instance (Preorder g, Preorder h, Preorder i) => Preorder (g, h, i) 282 | 283 | -- | Construct the graph comprising a single edge. 284 | -- 285 | -- @ 286 | -- edge x y == 'connect' ('vertex' x) ('vertex' y) 287 | -- @ 288 | edge :: Graph g => Vertex g -> Vertex g -> g 289 | edge x y = connect (vertex x) (vertex y) 290 | 291 | -- | Construct the graph comprising a given list of isolated vertices. 292 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 293 | -- given list. 294 | -- 295 | -- @ 296 | -- vertices [] == 'empty' 297 | -- vertices [x] == 'vertex' x 298 | -- vertices == 'overlays' . map 'vertex' 299 | -- @ 300 | vertices :: Graph g => [Vertex g] -> g 301 | vertices = overlays . map vertex 302 | 303 | -- | Construct the graph from a list of edges. 304 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 305 | -- given list. 306 | -- 307 | -- @ 308 | -- edges [] == 'empty' 309 | -- edges [(x,y)] == 'edge' x y 310 | -- @ 311 | edges :: Graph g => [(Vertex g, Vertex g)] -> g 312 | edges = overlays . map (uncurry edge) 313 | 314 | -- | Overlay a given list of graphs. 315 | -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length 316 | -- of the given list, and /S/ is the sum of sizes of the graphs in the list. 317 | -- 318 | -- @ 319 | -- overlays [] == 'empty' 320 | -- overlays [x] == x 321 | -- overlays [x,y] == 'overlay' x y 322 | -- overlays == 'foldr' 'overlay' 'empty' 323 | -- @ 324 | overlays :: Graph g => [g] -> g 325 | overlays [] = empty 326 | overlays [x] = x 327 | overlays (x:xs) = x `overlay` overlays xs 328 | 329 | -- | Connect a given list of graphs. 330 | -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length 331 | -- of the given list, and /S/ is the sum of sizes of the graphs in the list. 332 | -- 333 | -- @ 334 | -- connects [] == 'empty' 335 | -- connects [x] == x 336 | -- connects [x,y] == 'connect' x y 337 | -- connects == 'foldr' 'connect' 'empty' 338 | -- @ 339 | connects :: Graph g => [g] -> g 340 | connects [] = empty 341 | connects [x] = x 342 | connects (x:xs) = x `connect` connects xs 343 | 344 | -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the 345 | -- first graph is a /subgraph/ of the second. Here is the current implementation: 346 | -- 347 | -- @ 348 | -- isSubgraphOf x y = 'overlay' x y == y 349 | -- @ 350 | -- The complexity therefore depends on the complexity of equality testing of 351 | -- the specific graph instance. 352 | -- 353 | -- @ 354 | -- isSubgraphOf 'empty' x == True 355 | -- isSubgraphOf ('vertex' x) 'empty' == False 356 | -- isSubgraphOf x ('overlay' x y) == True 357 | -- isSubgraphOf ('overlay' x y) ('connect' x y) == True 358 | -- isSubgraphOf ('path' xs) ('circuit' xs) == True 359 | -- @ 360 | isSubgraphOf :: (Graph g, Eq g) => g -> g -> Bool 361 | isSubgraphOf x y = overlay x y == y 362 | 363 | -- | The /path/ on a list of vertices. 364 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 365 | -- given list. 366 | -- 367 | -- @ 368 | -- path [] == 'empty' 369 | -- path [x] == 'vertex' x 370 | -- path [x,y] == 'edge' x y 371 | -- @ 372 | path :: Graph g => [Vertex g] -> g 373 | path xs = case xs of [] -> empty 374 | [x] -> vertex x 375 | (_:ys) -> edges (zip xs ys) 376 | 377 | -- | The /circuit/ on a list of vertices. 378 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 379 | -- given list. 380 | -- 381 | -- @ 382 | -- circuit [] == 'empty' 383 | -- circuit [x] == 'edge' x x 384 | -- circuit [x,y] == 'edges' [(x,y), (y,x)] 385 | -- @ 386 | circuit :: Graph g => [Vertex g] -> g 387 | circuit [] = empty 388 | circuit (x:xs) = path $ [x] ++ xs ++ [x] 389 | 390 | -- | The /clique/ on a list of vertices. 391 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 392 | -- given list. 393 | -- 394 | -- @ 395 | -- clique [] == 'empty' 396 | -- clique [x] == 'vertex' x 397 | -- clique [x,y] == 'edge' x y 398 | -- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] 399 | -- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) 400 | -- @ 401 | clique :: Graph g => [Vertex g] -> g 402 | clique = connects . map vertex 403 | 404 | -- | The /biclique/ on two lists of vertices. 405 | -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the 406 | -- lengths of the given lists. 407 | -- 408 | -- @ 409 | -- biclique [] [] == 'empty' 410 | -- biclique [x] [] == 'vertex' x 411 | -- biclique [] [y] == 'vertex' y 412 | -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] 413 | -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) 414 | -- @ 415 | biclique :: Graph g => [Vertex g] -> [Vertex g] -> g 416 | biclique xs [] = vertices xs 417 | biclique [] ys = vertices ys 418 | biclique xs ys = connect (vertices xs) (vertices ys) 419 | 420 | -- | The /star/ formed by a centre vertex connected to a list of leaves. 421 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 422 | -- given list. 423 | -- 424 | -- @ 425 | -- star x [] == 'vertex' x 426 | -- star x [y] == 'edge' x y 427 | -- star x [y,z] == 'edges' [(x,y), (x,z)] 428 | -- star x ys == 'connect' ('vertex' x) ('vertices' ys) 429 | -- @ 430 | star :: Graph g => Vertex g -> [Vertex g] -> g 431 | star x [] = vertex x 432 | star x ys = connect (vertex x) (vertices ys) 433 | 434 | -- | The /tree graph/ constructed from a given 'Tree' data structure. 435 | -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the 436 | -- given tree (i.e. the number of vertices in the tree). 437 | -- 438 | -- @ 439 | -- tree (Node x []) == 'vertex' x 440 | -- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] 441 | -- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] 442 | -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] 443 | -- @ 444 | tree :: Graph g => Tree (Vertex g) -> g 445 | tree (Node x []) = vertex x 446 | tree (Node x f ) = star x (map rootLabel f) 447 | `overlay` forest (filter (not . null . subForest) f) 448 | 449 | -- | The /forest graph/ constructed from a given 'Forest' data structure. 450 | -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the 451 | -- given forest (i.e. the number of vertices in the forest). 452 | -- 453 | -- @ 454 | -- forest [] == 'empty' 455 | -- forest [x] == 'tree' x 456 | -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] 457 | -- forest == 'overlays' . 'map' 'tree' 458 | -- @ 459 | forest :: Graph g => Forest (Vertex g) -> g 460 | forest = overlays . map tree 461 | -------------------------------------------------------------------------------- /src/Algebra/Graph/Label.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.Label 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 10 | -- in Haskell. See for the 11 | -- motivation behind the library, the underlying theory, and implementation details. 12 | -- 13 | -- This module provides basic data types and type classes for representing edge 14 | -- labels in edge-labelled graphs, e.g. see "Algebra.Graph.Labelled". 15 | -- 16 | ----------------------------------------------------------------------------- 17 | module Algebra.Graph.Label ( 18 | -- * Semirings and dioids 19 | Semiring (..), zero, (<+>), StarSemiring (..), Dioid, 20 | 21 | -- * Data types for edge labels 22 | NonNegative, finite, finiteWord, unsafeFinite, infinite, getFinite, 23 | Distance, distance, getDistance, Capacity, capacity, getCapacity, 24 | Count, count, getCount, PowerSet (..), Minimum, getMinimum, noMinimum, 25 | Path, Label, symbol, symbols, isZero, RegularExpression, 26 | 27 | -- * Combining edge labels 28 | Optimum (..), ShortestPath, AllShortestPaths, CountShortestPaths, WidestPath 29 | ) where 30 | 31 | import Control.Monad 32 | import Data.Coerce 33 | import Data.Maybe 34 | import Data.Monoid (Any (..), Sum (..)) 35 | import Data.Semigroup (Max (..), Min (..)) 36 | import Data.Set (Set) 37 | import GHC.Exts (IsList (..)) 38 | 39 | import Algebra.Graph.Internal 40 | 41 | import qualified Data.Set as Set 42 | 43 | {-| A /semiring/ extends a commutative 'Monoid' with operation '<.>' that acts 44 | similarly to multiplication over the underlying (additive) monoid and has 'one' 45 | as the identity. This module also provides two convenient aliases: 'zero' for 46 | 'mempty', and '<+>' for '<>', which makes the interface more uniform. 47 | 48 | Instances of this type class must satisfy the following semiring laws: 49 | 50 | * Associativity of '<+>' and '<.>': 51 | 52 | > x <+> (y <+> z) == (x <+> y) <+> z 53 | > x <.> (y <.> z) == (x <.> y) <.> z 54 | 55 | * Identities of '<+>' and '<.>': 56 | 57 | > zero <+> x == x == x <+> zero 58 | > one <.> x == x == x <.> one 59 | 60 | * Commutativity of '<+>': 61 | 62 | > x <+> y == y <+> x 63 | 64 | * Annihilating 'zero': 65 | 66 | > x <.> zero == zero 67 | > zero <.> x == zero 68 | 69 | * Distributivity: 70 | 71 | > x <.> (y <+> z) == x <.> y <+> x <.> z 72 | > (x <+> y) <.> z == x <.> z <+> y <.> z 73 | -} 74 | class Monoid a => Semiring a where 75 | one :: a 76 | (<.>) :: a -> a -> a 77 | 78 | {-| A /star semiring/ is a 'Semiring' with an additional unary operator 'star' 79 | satisfying the following two laws: 80 | 81 | > star a = one <+> a <.> star a 82 | > star a = one <+> star a <.> a 83 | -} 84 | class Semiring a => StarSemiring a where 85 | star :: a -> a 86 | 87 | {-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following 88 | /idempotence/ law in addition to the 'Semiring' laws: 89 | 90 | > x <+> x == x 91 | -} 92 | class Semiring a => Dioid a 93 | 94 | -- | An alias for 'mempty'. 95 | zero :: Monoid a => a 96 | zero = mempty 97 | 98 | -- | An alias for '<>'. 99 | (<+>) :: Semigroup a => a -> a -> a 100 | (<+>) = (<>) 101 | 102 | infixr 6 <+> 103 | infixr 7 <.> 104 | 105 | instance Semiring Any where 106 | one = Any True 107 | Any x <.> Any y = Any (x && y) 108 | 109 | instance StarSemiring Any where 110 | star _ = Any True 111 | 112 | instance Dioid Any 113 | 114 | -- | A non-negative value that can be 'finite' or 'infinite'. Note: the current 115 | -- implementation of the 'Num' instance raises an error on negative literals 116 | -- and on the 'negate' method. 117 | newtype NonNegative a = NonNegative (Extended a) 118 | deriving (Applicative, Eq, Functor, Ord, Monad) 119 | 120 | instance (Num a, Show a) => Show (NonNegative a) where 121 | show (NonNegative Infinite ) = "infinite" 122 | show (NonNegative (Finite x)) = show x 123 | 124 | instance Num a => Bounded (NonNegative a) where 125 | minBound = unsafeFinite 0 126 | maxBound = infinite 127 | 128 | instance (Num a, Ord a) => Num (NonNegative a) where 129 | fromInteger x | f < 0 = error "NonNegative values cannot be negative" 130 | | otherwise = unsafeFinite f 131 | where 132 | f = fromInteger x 133 | 134 | (+) = coerce ((+) :: Extended a -> Extended a -> Extended a) 135 | (*) = coerce ((*) :: Extended a -> Extended a -> Extended a) 136 | 137 | negate _ = error "NonNegative values cannot be negated" 138 | 139 | signum (NonNegative Infinite) = 1 140 | signum x = signum <$> x 141 | 142 | abs = id 143 | 144 | -- | A finite non-negative value or @Nothing@ if the argument is negative. 145 | finite :: (Num a, Ord a) => a -> Maybe (NonNegative a) 146 | finite x | x < 0 = Nothing 147 | | otherwise = Just (unsafeFinite x) 148 | 149 | -- | A finite 'Word'. 150 | finiteWord :: Word -> NonNegative Word 151 | finiteWord = unsafeFinite 152 | 153 | -- | A non-negative finite value, created /unsafely/: the argument is not 154 | -- checked for being non-negative, so @unsafeFinite (-1)@ compiles just fine. 155 | unsafeFinite :: a -> NonNegative a 156 | unsafeFinite = NonNegative . Finite 157 | 158 | -- | The (non-negative) infinite value. 159 | infinite :: NonNegative a 160 | infinite = NonNegative Infinite 161 | 162 | -- | Get a finite value or @Nothing@ if the value is infinite. 163 | getFinite :: NonNegative a -> Maybe a 164 | getFinite (NonNegative x) = fromExtended x 165 | 166 | -- | A /capacity/ is a non-negative value that can be 'finite' or 'infinite'. 167 | -- Capacities form a 'Dioid' as follows: 168 | -- 169 | -- @ 170 | -- 'zero' = 0 171 | -- 'one' = 'capacity' 'infinite' 172 | -- ('<+>') = 'max' 173 | -- ('<.>') = 'min' 174 | -- @ 175 | newtype Capacity a = Capacity (Max (NonNegative a)) 176 | deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) 177 | 178 | instance Show a => Show (Capacity a) where 179 | show (Capacity (Max (NonNegative (Finite x)))) = show x 180 | show _ = "capacity infinite" 181 | 182 | instance (Num a, Ord a) => Semiring (Capacity a) where 183 | one = capacity infinite 184 | (<.>) = min 185 | 186 | instance (Num a, Ord a) => StarSemiring (Capacity a) where 187 | star _ = one 188 | 189 | instance (Num a, Ord a) => Dioid (Capacity a) 190 | 191 | -- | A non-negative capacity. 192 | capacity :: NonNegative a -> Capacity a 193 | capacity = Capacity . Max 194 | 195 | -- | Get the value of a capacity. 196 | getCapacity :: Capacity a -> NonNegative a 197 | getCapacity (Capacity (Max x)) = x 198 | 199 | -- | A /count/ is a non-negative value that can be 'finite' or 'infinite'. 200 | -- Counts form a 'Semiring' as follows: 201 | -- 202 | -- @ 203 | -- 'zero' = 0 204 | -- 'one' = 1 205 | -- ('<+>') = ('+') 206 | -- ('<.>') = ('*') 207 | -- @ 208 | newtype Count a = Count (Sum (NonNegative a)) 209 | deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) 210 | 211 | instance Show a => Show (Count a) where 212 | show (Count (Sum (NonNegative (Finite x)))) = show x 213 | show _ = "count infinite" 214 | 215 | instance (Num a, Ord a) => Semiring (Count a) where 216 | one = 1 217 | (<.>) = (*) 218 | 219 | instance (Num a, Ord a) => StarSemiring (Count a) where 220 | star x | x == zero = one 221 | | otherwise = count infinite 222 | 223 | -- | A non-negative count. 224 | count :: NonNegative a -> Count a 225 | count = Count . Sum 226 | 227 | -- | Get the value of a count. 228 | getCount :: Count a -> NonNegative a 229 | getCount (Count (Sum x)) = x 230 | 231 | -- | A /distance/ is a non-negative value that can be 'finite' or 'infinite'. 232 | -- Distances form a 'Dioid' as follows: 233 | -- 234 | -- @ 235 | -- 'zero' = 'distance' 'infinite' 236 | -- 'one' = 0 237 | -- ('<+>') = 'min' 238 | -- ('<.>') = ('+') 239 | -- @ 240 | newtype Distance a = Distance (Min (NonNegative a)) 241 | deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) 242 | 243 | instance Show a => Show (Distance a) where 244 | show (Distance (Min (NonNegative (Finite x)))) = show x 245 | show _ = "distance infinite" 246 | 247 | instance (Num a, Ord a) => Semiring (Distance a) where 248 | one = 0 249 | (<.>) = (+) 250 | 251 | instance (Num a, Ord a) => StarSemiring (Distance a) where 252 | star _ = one 253 | 254 | instance (Num a, Ord a) => Dioid (Distance a) 255 | 256 | -- | A non-negative distance. 257 | distance :: NonNegative a -> Distance a 258 | distance = Distance . Min 259 | 260 | -- | Get the value of a distance. 261 | getDistance :: Distance a -> NonNegative a 262 | getDistance (Distance (Min x)) = x 263 | 264 | -- This data type extends the underlying type @a@ with a new 'Infinite' value. 265 | data Extended a = Finite a | Infinite 266 | deriving (Eq, Functor, Ord, Show) 267 | 268 | instance Applicative Extended where 269 | pure = Finite 270 | (<*>) = ap 271 | 272 | instance Monad Extended where 273 | return = pure 274 | 275 | Infinite >>= _ = Infinite 276 | Finite x >>= f = f x 277 | 278 | -- Extract the finite value or @Nothing@ if the value is 'Infinite'. 279 | fromExtended :: Extended a -> Maybe a 280 | fromExtended (Finite a) = Just a 281 | fromExtended Infinite = Nothing 282 | 283 | -- A type alias for a binary function on Extended. 284 | instance (Num a, Eq a) => Num (Extended a) where 285 | fromInteger = Finite . fromInteger 286 | 287 | (+) = liftM2 (+) 288 | 289 | Finite 0 * _ = Finite 0 290 | _ * Finite 0 = Finite 0 291 | x * y = liftM2 (*) x y 292 | 293 | negate = fmap negate 294 | signum = fmap signum 295 | abs = fmap abs 296 | 297 | -- | If @a@ is a monoid, 'Minimum' @a@ forms the following 'Dioid': 298 | -- 299 | -- @ 300 | -- 'zero' = 'noMinimum' 301 | -- 'one' = 'pure' 'mempty' 302 | -- ('<+>') = 'liftA2' 'min' 303 | -- ('<.>') = 'liftA2' 'mappend' 304 | -- @ 305 | -- 306 | -- To create a singleton value of type 'Minimum' @a@ use the 'pure' function. 307 | -- For example: 308 | -- 309 | -- @ 310 | -- getMinimum ('pure' "Hello, " '<+>' 'pure' "World!") == Just "Hello, " 311 | -- getMinimum ('pure' "Hello, " '<.>' 'pure' "World!") == Just "Hello, World!" 312 | -- @ 313 | newtype Minimum a = Minimum (Extended a) 314 | deriving (Applicative, Eq, Functor, Ord, Monad) 315 | 316 | -- | Extract the minimum or @Nothing@ if it does not exist. 317 | getMinimum :: Minimum a -> Maybe a 318 | getMinimum (Minimum x) = fromExtended x 319 | 320 | -- | The value corresponding to the lack of minimum, e.g. the minimum of the 321 | -- empty set. 322 | noMinimum :: Minimum a 323 | noMinimum = Minimum Infinite 324 | 325 | instance Ord a => Semigroup (Minimum a) where 326 | (<>) = min 327 | 328 | instance (Monoid a, Ord a) => Monoid (Minimum a) where 329 | mempty = noMinimum 330 | 331 | instance (Monoid a, Ord a) => Semiring (Minimum a) where 332 | one = pure mempty 333 | (<.>) = liftM2 mappend 334 | 335 | instance (Monoid a, Ord a) => Dioid (Minimum a) 336 | 337 | instance Show a => Show (Minimum a) where 338 | show (Minimum Infinite ) = "one" 339 | show (Minimum (Finite x)) = show x 340 | 341 | instance IsList a => IsList (Minimum a) where 342 | type Item (Minimum a) = Item a 343 | fromList = Minimum . Finite . fromList 344 | toList (Minimum x) = toList $ fromMaybe errorMessage (fromExtended x) 345 | where 346 | errorMessage = error "Minimum.toList applied to noMinimum value." 347 | 348 | -- | The /power set/ over the underlying set of elements @a@. If @a@ is a 349 | -- monoid, then the power set forms a 'Dioid' as follows: 350 | -- 351 | -- @ 352 | -- 'zero' = PowerSet Set.'Set.empty' 353 | -- 'one' = PowerSet $ Set.'Set.singleton' 'mempty' 354 | -- x '<+>' y = PowerSet $ Set.'Set.union' (getPowerSet x) (getPowerSet y) 355 | -- x '<.>' y = PowerSet $ 'cartesianProductWith' 'mappend' (getPowerSet x) (getPowerSet y) 356 | -- @ 357 | newtype PowerSet a = PowerSet { getPowerSet :: Set a } 358 | deriving (Eq, Monoid, Ord, Semigroup, Show) 359 | 360 | instance (Monoid a, Ord a) => Semiring (PowerSet a) where 361 | one = PowerSet (Set.singleton mempty) 362 | PowerSet x <.> PowerSet y = PowerSet (cartesianProductWith mappend x y) 363 | 364 | instance (Monoid a, Ord a) => Dioid (PowerSet a) where 365 | 366 | -- | The type of /free labels/ over the underlying set of symbols @a@. 'Label' values 367 | -- can be manipulated via its 'Semigroup', 'Monoid' and 'StarSemiring' class instances. 368 | data Label a = Zero 369 | | One 370 | | Symbol a 371 | | Label a :+: Label a 372 | | Label a :*: Label a 373 | | Star (Label a) 374 | deriving Functor 375 | 376 | infixl 6 :+: 377 | infixl 7 :*: 378 | 379 | -- | Wrap a value into a 'Symbol' constructor 380 | symbol :: a -> Label a 381 | symbol = Symbol 382 | 383 | -- | Wrap a list of values into 'Symbol' constructors terminated by 'Zero' 384 | symbols :: Foldable t => t a -> Label a 385 | symbols = foldr ((<>) . Symbol) Zero 386 | 387 | instance IsList (Label a) where 388 | type Item (Label a) = a 389 | fromList = symbols 390 | toList = error "Label.toList cannot be given a reasonable definition" 391 | 392 | instance Show a => Show (Label a) where 393 | showsPrec p label = case label of 394 | Zero -> shows (0 :: Int) 395 | One -> shows (1 :: Int) 396 | Symbol x -> shows x 397 | x :+: y -> showParen (p >= 6) $ showsPrec 6 x . (" | " ++) . showsPrec 6 y 398 | x :*: y -> showParen (p >= 7) $ showsPrec 7 x . (" ; " ++) . showsPrec 7 y 399 | Star x -> showParen (p >= 8) $ showsPrec 8 x . ("*" ++) 400 | 401 | instance Semigroup (Label a) where 402 | Zero <> x = x 403 | x <> Zero = x 404 | One <> One = One 405 | One <> Star x = Star x 406 | Star x <> One = Star x 407 | x <> y = x :+: y 408 | 409 | instance Monoid (Label a) where 410 | mempty = Zero 411 | 412 | instance Semiring (Label a) where 413 | one = One 414 | 415 | One <.> x = x 416 | x <.> One = x 417 | Zero <.> _ = Zero 418 | _ <.> Zero = Zero 419 | x <.> y = x :*: y 420 | 421 | instance StarSemiring (Label a) where 422 | star Zero = One 423 | star One = One 424 | star (Star x) = star x 425 | star x = Star x 426 | 427 | -- | Check if a 'Label' is 'zero'. 428 | isZero :: Label a -> Bool 429 | isZero Zero = True 430 | isZero _ = False 431 | 432 | -- | A type synonym for /regular expressions/, built on top of /free labels/. 433 | type RegularExpression a = Label a 434 | 435 | -- | An /optimum semiring/ obtained by combining a semiring @o@ that defines an 436 | -- /optimisation criterion/, and a semiring @a@ that describes the /arguments/ 437 | -- of an optimisation problem. For example, by choosing @o = 'Distance' Int@ and 438 | -- and @a = 'Minimum' ('Path' String)@, we obtain the /shortest path semiring/ 439 | -- for computing the shortest path in an @Int@-labelled graph with @String@ 440 | -- vertices. 441 | -- 442 | -- We assume that the semiring @o@ is /selective/ i.e. for all @x@ and @y@: 443 | -- 444 | -- > x <+> y == x || x <+> y == y 445 | -- 446 | -- In words, the operation '<+>' always simply selects one of its arguments. For 447 | -- example, the 'Capacity' and 'Distance' semirings are selective, whereas the 448 | -- the 'Count' semiring is not. 449 | data Optimum o a = Optimum { getOptimum :: o, getArgument :: a } 450 | deriving (Eq, Ord, Show) 451 | 452 | -- TODO: Add tests. 453 | -- This is similar to geodetic semirings. 454 | -- See http://vlado.fmf.uni-lj.si/vlado/papers/SemiRingSNA.pdf 455 | instance (Eq o, Monoid a, Monoid o) => Semigroup (Optimum o a) where 456 | Optimum o1 a1 <> Optimum o2 a2 457 | | o1 == o2 = Optimum o1 (mappend a1 a2) 458 | | otherwise = Optimum o a 459 | where 460 | o = mappend o1 o2 461 | a = if o == o1 then a1 else a2 462 | 463 | -- TODO: Add tests. 464 | instance (Eq o, Monoid a, Monoid o) => Monoid (Optimum o a) where 465 | mempty = Optimum mempty mempty 466 | 467 | -- TODO: Add tests. 468 | instance (Eq o, Semiring a, Semiring o) => Semiring (Optimum o a) where 469 | one = Optimum one one 470 | Optimum o1 a1 <.> Optimum o2 a2 = Optimum (o1 <.> o2) (a1 <.> a2) 471 | 472 | -- TODO: Add tests. 473 | instance (Eq o, StarSemiring a, StarSemiring o) => StarSemiring (Optimum o a) where 474 | star (Optimum o a) = Optimum (star o) (star a) 475 | 476 | -- TODO: Add tests. 477 | instance (Eq o, Dioid a, Dioid o) => Dioid (Optimum o a) where 478 | 479 | -- | A /path/ is a list of edges. 480 | type Path a = [(a, a)] 481 | 482 | -- TODO: Add tests. 483 | -- | The 'Optimum' semiring specialised to 484 | -- /finding the lexicographically smallest shortest path/. 485 | type ShortestPath e a = Optimum (Distance e) (Minimum (Path a)) 486 | 487 | -- TODO: Add tests. 488 | -- | The 'Optimum' semiring specialised to /finding all shortest paths/. 489 | type AllShortestPaths e a = Optimum (Distance e) (PowerSet (Path a)) 490 | 491 | -- TODO: Add tests. 492 | -- | The 'Optimum' semiring specialised to /counting all shortest paths/. 493 | type CountShortestPaths e = Optimum (Distance e) (Count Integer) 494 | 495 | -- TODO: Add tests. 496 | -- | The 'Optimum' semiring specialised to 497 | -- /finding the lexicographically smallest widest path/. 498 | type WidestPath e a = Optimum (Capacity e) (Minimum (Path a)) 499 | -------------------------------------------------------------------------------- /src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.Graph.AdjacencyIntMap.Algorithm 5 | -- Copyright : (c) Andrey Mokhov 2016-2025 6 | -- License : MIT (see the file LICENSE) 7 | -- Maintainer : andrey.mokhov@gmail.com 8 | -- Stability : unstable 9 | -- 10 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 11 | -- in Haskell. See for the 12 | -- motivation behind the library, the underlying theory, and implementation details. 13 | -- 14 | -- This module provides basic graph algorithms, such as /depth-first search/, 15 | -- implemented for the "Algebra.Graph.AdjacencyIntMap" data type. 16 | -- 17 | -- Some of the worst-case complexities include the term /min(n,W)/. 18 | -- Following 'IntSet.IntSet' and 'IntMap.IntMap', the /W/ stands for 19 | -- word size (usually 32 or 64 bits). 20 | ----------------------------------------------------------------------------- 21 | module Algebra.Graph.AdjacencyIntMap.Algorithm ( 22 | -- * Algorithms 23 | bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable, 24 | topSort, isAcyclic, 25 | 26 | -- * Correctness properties 27 | isDfsForestOf, isTopSortOf, 28 | 29 | -- * Type synonyms 30 | Cycle 31 | ) where 32 | 33 | import Control.Monad 34 | import Control.Monad.Trans.Cont 35 | import Control.Monad.Trans.State.Strict 36 | import Data.Either 37 | import Data.List.NonEmpty (NonEmpty(..), (<|)) 38 | import Data.Tree 39 | 40 | import Algebra.Graph.AdjacencyIntMap 41 | 42 | import qualified Data.List as List 43 | import qualified Data.IntMap.Strict as IntMap 44 | import qualified Data.IntSet as IntSet 45 | 46 | -- | Compute the /breadth-first search/ forest of a graph, such that adjacent 47 | -- vertices are explored in the increasing order. The search is seeded by a list 48 | -- of vertices that will become the roots of the resulting forest. Duplicates in 49 | -- the list will have their first occurrence explored and subsequent ones 50 | -- ignored. The seed vertices that do not belong to the graph are also ignored. 51 | -- 52 | -- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the 53 | -- number of seed vertices. 54 | -- 55 | -- @ 56 | -- 'forest' $ bfsForest ('edge' 1 2) [0] == 'empty' 57 | -- 'forest' $ bfsForest ('edge' 1 2) [1] == 'edge' 1 2 58 | -- 'forest' $ bfsForest ('edge' 1 2) [2] == 'vertex' 2 59 | -- 'forest' $ bfsForest ('edge' 1 2) [0,1,2] == 'vertices' [1,2] 60 | -- 'forest' $ bfsForest ('edge' 1 2) [2,1,0] == 'vertices' [1,2] 61 | -- 'forest' $ bfsForest ('edge' 1 1) [1] == 'vertex' 1 62 | -- 'isSubgraphOf' ('forest' $ bfsForest x vs) x == True 63 | -- bfsForest x ('vertexList' x) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'vertexList' x) 64 | -- bfsForest x [] == [] 65 | -- bfsForest 'empty' vs == [] 66 | -- bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 67 | -- , subForest = [ Node { rootLabel = 5 68 | -- , subForest = [] }]} 69 | -- , Node { rootLabel = 4 70 | -- , subForest = [] }] 71 | -- 'forest' $ bfsForest ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1] + 'path' [3,4,5] 72 | -- 73 | -- @ 74 | bfsForest :: AdjacencyIntMap -> [Int] -> Forest Int 75 | bfsForest g vs= evalState (explore [ v | v <- vs, hasVertex v g ]) IntSet.empty 76 | where 77 | explore = filterM discovered >=> unfoldForestM_BF walk 78 | walk v = (v,) <$> adjacentM v 79 | adjacentM v = filterM discovered $ IntSet.toList (postIntSet v g) 80 | discovered v = do new <- gets (not . IntSet.member v) 81 | when new $ modify' (IntSet.insert v) 82 | return new 83 | 84 | -- | A version of 'bfsForest' where the resulting forest is converted to a level 85 | -- structure. Adjacent vertices are explored in the increasing order. Flattening 86 | -- the result via @'concat'@ @.@ @'bfs'@ @x@ gives an enumeration of reachable 87 | -- vertices in the breadth-first search order. 88 | -- 89 | -- Complexity: /O((L + m) * min(n,W))/ time and /O(n)/ space, where /L/ is the 90 | -- number of seed vertices. 91 | -- 92 | -- @ 93 | -- bfs ('edge' 1 2) [0] == [] 94 | -- bfs ('edge' 1 2) [1] == [[1], [2]] 95 | -- bfs ('edge' 1 2) [2] == [[2]] 96 | -- bfs ('edge' 1 2) [1,2] == [[1,2]] 97 | -- bfs ('edge' 1 2) [2,1] == [[2,1]] 98 | -- bfs ('edge' 1 1) [1] == [[1]] 99 | -- bfs 'empty' vs == [] 100 | -- bfs x [] == [] 101 | -- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]] 102 | -- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]] 103 | -- bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]] 104 | -- 105 | -- bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [[2], [1,3], [5,4]] 106 | -- 'concat' $ bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,4,1,5] 107 | -- 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' x == bfs x 108 | -- @ 109 | bfs :: AdjacencyIntMap -> [Int] -> [[Int]] 110 | bfs g = map concat . List.transpose . map levels . bfsForest g 111 | 112 | dfsForestFromImpl :: AdjacencyIntMap -> [Int] -> Forest Int 113 | dfsForestFromImpl g vs = evalState (explore vs) IntSet.empty 114 | where 115 | explore (v:vs) = discovered v >>= \case 116 | True -> (:) <$> walk v <*> explore vs 117 | False -> explore vs 118 | explore [] = return [] 119 | walk v = Node v <$> explore (adjacent v) 120 | adjacent v = IntSet.toList (postIntSet v g) 121 | discovered v = do new <- gets (not . IntSet.member v) 122 | when new $ modify' (IntSet.insert v) 123 | return new 124 | 125 | -- | Compute the /depth-first search/ forest of a graph, where adjacent vertices 126 | -- are explored in the increasing order. 127 | -- 128 | -- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. 129 | -- 130 | -- @ 131 | -- 'forest' $ dfsForest 'empty' == 'empty' 132 | -- 'forest' $ dfsForest ('edge' 1 1) == 'vertex' 1 133 | -- 'forest' $ dfsForest ('edge' 1 2) == 'edge' 1 2 134 | -- 'forest' $ dfsForest ('edge' 2 1) == 'vertices' [1,2] 135 | -- 'isSubgraphOf' ('forest' $ dfsForest x) x == True 136 | -- 'isDfsForestOf' (dfsForest x) x == True 137 | -- dfsForest . 'forest' . dfsForest == dfsForest 138 | -- dfsForest ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) 139 | -- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 140 | -- , subForest = [ Node { rootLabel = 5 141 | -- , subForest = [] }]} 142 | -- , Node { rootLabel = 3 143 | -- , subForest = [ Node { rootLabel = 4 144 | -- , subForest = [] }]}] 145 | -- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5] 146 | -- @ 147 | dfsForest :: AdjacencyIntMap -> Forest Int 148 | dfsForest g = dfsForestFromImpl g (vertexList g) 149 | 150 | -- | Compute the /depth-first search/ forest of a graph starting from the given 151 | -- seed vertices, where adjacent vertices are explored in the increasing order. 152 | -- Note that the resulting forest does not necessarily span the whole graph, as 153 | -- some vertices may be unreachable. The seed vertices which do not belong to 154 | -- the graph are ignored. 155 | -- 156 | -- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the 157 | -- number of seed vertices. 158 | -- 159 | -- @ 160 | -- 'forest' $ dfsForestFrom 'empty' vs == 'empty' 161 | -- 'forest' $ dfsForestFrom ('edge' 1 1) [1] == 'vertex' 1 162 | -- 'forest' $ dfsForestFrom ('edge' 1 2) [0] == 'empty' 163 | -- 'forest' $ dfsForestFrom ('edge' 1 2) [1] == 'edge' 1 2 164 | -- 'forest' $ dfsForestFrom ('edge' 1 2) [2] == 'vertex' 2 165 | -- 'forest' $ dfsForestFrom ('edge' 1 2) [1,2] == 'edge' 1 2 166 | -- 'forest' $ dfsForestFrom ('edge' 1 2) [2,1] == 'vertices' [1,2] 167 | -- 'isSubgraphOf' ('forest' $ dfsForestFrom x vs) x == True 168 | -- 'isDfsForestOf' (dfsForestFrom x ('vertexList' x)) x == True 169 | -- dfsForestFrom x ('vertexList' x) == 'dfsForest' x 170 | -- dfsForestFrom x [] == [] 171 | -- dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 172 | -- , subForest = [ Node { rootLabel = 5 173 | -- , subForest = [] } 174 | -- , Node { rootLabel = 4 175 | -- , subForest = [] }] 176 | -- 'forest' $ dfsForestFrom ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1,5,4] 177 | -- @ 178 | dfsForestFrom :: AdjacencyIntMap -> [Int] -> Forest Int 179 | dfsForestFrom g vs = dfsForestFromImpl g [ v | v <- vs, hasVertex v g ] 180 | 181 | 182 | -- | Return the list vertices visited by the /depth-first search/ in a graph, 183 | -- starting from the given seed vertices. Adjacent vertices are explored in the 184 | -- increasing order. 185 | -- 186 | -- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the 187 | -- number of seed vertices. 188 | -- 189 | -- @ 190 | -- dfs 'empty' vs == [] 191 | -- dfs ('edge' 1 1) [1] == [1] 192 | -- dfs ('edge' 1 2) [0] == [] 193 | -- dfs ('edge' 1 2) [1] == [1,2] 194 | -- dfs ('edge' 1 2) [2] == [2] 195 | -- dfs ('edge' 1 2) [1,2] == [1,2] 196 | -- dfs ('edge' 1 2) [2,1] == [2,1] 197 | -- dfs x [] == [] 198 | -- 199 | -- 'Data.List.and' [ 'hasVertex' v x | v <- dfs x vs ] == True 200 | -- dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4] 201 | -- dfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,1,5,4] 202 | -- @ 203 | dfs :: AdjacencyIntMap -> [Int] -> [Int] 204 | dfs x = concatMap flatten . dfsForestFrom x 205 | 206 | -- | Return the list of vertices /reachable/ from a source vertex in a graph. 207 | -- The vertices in the resulting list appear in the /depth-first search order/. 208 | -- 209 | -- Complexity: /O(m * log n)/ time and /O(n)/ space. 210 | -- 211 | -- @ 212 | -- reachable 'empty' x == [] 213 | -- reachable ('vertex' 1) 1 == [1] 214 | -- reachable ('edge' 1 1) 1 == [1] 215 | -- reachable ('edge' 1 2) 0 == [] 216 | -- reachable ('edge' 1 2) 1 == [1,2] 217 | -- reachable ('edge' 1 2) 2 == [2] 218 | -- reachable ('path' [1..8] ) 4 == [4..8] 219 | -- reachable ('circuit' [1..8] ) 4 == [4..8] ++ [1..3] 220 | -- reachable ('clique' [8,7..1]) 8 == [8] ++ [1..7] 221 | -- 222 | -- 'Data.List.and' [ 'hasVertex' v x | v <- reachable x y ] == True 223 | -- @ 224 | reachable :: AdjacencyIntMap -> Int -> [Int] 225 | reachable x y = dfs x [y] 226 | 227 | type Cycle = NonEmpty 228 | type Result = Either (Cycle Int) [Int] 229 | data NodeState = Entered | Exited 230 | data S = S { parent :: IntMap.IntMap Int 231 | , entry :: IntMap.IntMap NodeState 232 | , order :: [Int] } 233 | 234 | topSortImpl :: AdjacencyIntMap -> StateT S (Cont Result) Result 235 | topSortImpl g = liftCallCC' callCC $ \cyclic -> 236 | do let vertices = map fst $ IntMap.toDescList $ adjacencyIntMap g 237 | adjacent = IntSet.toDescList . flip postIntSet g 238 | dfsRoot x = nodeState x >>= \case 239 | Nothing -> enterRoot x >> dfs x >> exit x 240 | _ -> return () 241 | dfs x = forM_ (adjacent x) $ \y -> 242 | nodeState y >>= \case 243 | Nothing -> enter x y >> dfs y >> exit y 244 | Just Exited -> return () 245 | Just Entered -> cyclic . Left . retrace x y =<< gets parent 246 | forM_ vertices dfsRoot 247 | Right <$> gets order 248 | where 249 | nodeState v = gets (IntMap.lookup v . entry) 250 | enter u v = modify' (\(S m n vs) -> S (IntMap.insert v u m) 251 | (IntMap.insert v Entered n) 252 | vs) 253 | enterRoot v = modify' (\(S m n vs) -> S m (IntMap.insert v Entered n) vs) 254 | exit v = modify' (\(S m n vs) -> S m (IntMap.alter (fmap leave) v n) (v:vs)) 255 | where leave = \case 256 | Entered -> Exited 257 | Exited -> error "Internal error: dfs search order violated" 258 | retrace curr head parent = aux (curr :| []) where 259 | aux xs@(curr :| _) 260 | | head == curr = xs 261 | | otherwise = aux (parent IntMap.! curr <| xs) 262 | 263 | -- | Compute a topological sort of a graph or discover a cycle. 264 | -- 265 | -- Vertices are explored in the decreasing order according to their 'Ord' 266 | -- instance. This gives the lexicographically smallest topological ordering in 267 | -- the case of success. In the case of failure, the cycle is characterized by 268 | -- being the lexicographically smallest up to rotation with respect to 269 | -- @Ord@ @(Dual@ @Int)@ in the first connected component of the graph containing 270 | -- a cycle, where the connected components are ordered by their largest vertex 271 | -- with respect to @Ord a@. 272 | -- 273 | -- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. 274 | -- 275 | -- @ 276 | -- topSort (1 * 2 + 3 * 1) == Right [3,1,2] 277 | -- topSort ('path' [1..5]) == Right [1..5] 278 | -- topSort (3 * (1 * 4 + 2 * 5)) == Right [3,1,2,4,5] 279 | -- topSort (1 * 2 + 2 * 1) == Left (2 ':|' [1]) 280 | -- topSort ('path' [5,4..1] + 'edge' 2 4) == Left (4 ':|' [3,2]) 281 | -- topSort ('circuit' [1..3]) == Left (3 ':|' [1,2]) 282 | -- topSort ('circuit' [1..3] + 'circuit' [3,2,1]) == Left (3 ':|' [2]) 283 | -- topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 ':|' [2]) 284 | -- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Right False 285 | -- topSort . 'vertices' == Right . 'nub' . 'sort' 286 | -- @ 287 | topSort :: AdjacencyIntMap -> Either (Cycle Int) [Int] 288 | topSort g = runCont (evalStateT (topSortImpl g) initialState) id 289 | where 290 | initialState = S IntMap.empty IntMap.empty [] 291 | 292 | -- | Check if a given graph is /acyclic/. 293 | -- 294 | -- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. 295 | -- 296 | -- @ 297 | -- isAcyclic (1 * 2 + 3 * 1) == True 298 | -- isAcyclic (1 * 2 + 2 * 1) == False 299 | -- isAcyclic . 'circuit' == 'null' 300 | -- isAcyclic == 'isRight' . 'topSort' 301 | -- @ 302 | isAcyclic :: AdjacencyIntMap -> Bool 303 | isAcyclic = isRight . topSort 304 | 305 | -- | Check if a given forest is a correct /depth-first search/ forest of a graph. 306 | -- The implementation is based on the paper "Depth-First Search and Strong 307 | -- Connectivity in Coq" by François Pottier. 308 | -- 309 | -- @ 310 | -- isDfsForestOf [] 'empty' == True 311 | -- isDfsForestOf [] ('vertex' 1) == False 312 | -- isDfsForestOf [Node 1 []] ('vertex' 1) == True 313 | -- isDfsForestOf [Node 1 []] ('vertex' 2) == False 314 | -- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False 315 | -- isDfsForestOf [Node 1 []] ('edge' 1 1) == True 316 | -- isDfsForestOf [Node 1 []] ('edge' 1 2) == False 317 | -- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False 318 | -- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True 319 | -- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True 320 | -- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True 321 | -- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True 322 | -- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False 323 | -- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True 324 | -- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False 325 | -- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True 326 | -- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True 327 | -- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False 328 | -- @ 329 | isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool 330 | isDfsForestOf f am = case go IntSet.empty f of 331 | Just seen -> seen == vertexIntSet am 332 | Nothing -> False 333 | where 334 | go seen [] = Just seen 335 | go seen (t:ts) = do 336 | let root = rootLabel t 337 | guard $ root `IntSet.notMember` seen 338 | guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] 339 | newSeen <- go (IntSet.insert root seen) (subForest t) 340 | guard $ postIntSet root am `IntSet.isSubsetOf` newSeen 341 | go newSeen ts 342 | 343 | -- | Check if a given list of vertices is a correct /topological sort/ of a graph. 344 | -- 345 | -- @ 346 | -- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True 347 | -- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False 348 | -- isTopSortOf [] (1 * 2 + 3 * 1) == False 349 | -- isTopSortOf [] 'empty' == True 350 | -- isTopSortOf [x] ('vertex' x) == True 351 | -- isTopSortOf [x] ('edge' x x) == False 352 | -- @ 353 | isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool 354 | isTopSortOf xs m = go IntSet.empty xs 355 | where 356 | go seen [] = seen == IntMap.keysSet (adjacencyIntMap m) 357 | go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty 358 | && go newSeen vs 359 | where 360 | newSeen = IntSet.insert v seen 361 | -------------------------------------------------------------------------------- /src/Algebra/Graph/HigherKinded/Class.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Algebra.Graph.HigherKinded.Class 4 | -- Copyright : (c) Andrey Mokhov 2016-2025 5 | -- License : MIT (see the file LICENSE) 6 | -- Maintainer : andrey.mokhov@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- __Alga__ is a library for algebraic construction and manipulation of graphs 10 | -- in Haskell. See for the 11 | -- motivation behind the library, the underlying theory, and implementation details. 12 | -- 13 | -- This module defines the core type class 'Graph', a few graph subclasses, and 14 | -- basic polymorphic graph construction primitives. Functions that cannot be 15 | -- implemented fully polymorphically and require the use of an intermediate data 16 | -- type are not included. For example, to compute the size of a 'Graph' 17 | -- expression you will need to use a concrete data type, such as "Algebra.Graph". 18 | -- 19 | -- See "Algebra.Graph.Class" for alternative definitions where the core type 20 | -- class is not higher-kinded and permits more instances. 21 | ----------------------------------------------------------------------------- 22 | module Algebra.Graph.HigherKinded.Class ( 23 | -- * The core type class 24 | Graph (..), empty, vertex, overlay, 25 | 26 | -- * Undirected graphs 27 | Undirected, 28 | 29 | -- * Reflexive graphs 30 | Reflexive, 31 | 32 | -- * Transitive graphs 33 | Transitive, 34 | 35 | -- * Preorders 36 | Preorder, 37 | 38 | -- * Basic graph construction primitives 39 | edge, vertices, edges, overlays, connects, 40 | 41 | -- * Relations on graphs 42 | isSubgraphOf, 43 | 44 | -- * Graph properties 45 | hasEdge, 46 | 47 | -- * Standard families of graphs 48 | path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus, 49 | deBruijn, 50 | 51 | -- * Graph transformation 52 | removeVertex, replaceVertex, mergeVertices, splitVertex, induce 53 | ) where 54 | 55 | import Control.Applicative (Alternative(empty, (<|>))) 56 | import Control.Monad (MonadPlus, mfilter) 57 | import Data.Tree (Forest, Tree (..)) 58 | 59 | import qualified Algebra.Graph as G 60 | 61 | {-| 62 | The core type class for constructing algebraic graphs is defined by introducing 63 | the 'connect' method to the standard 'MonadPlus' class and reusing the following 64 | existing methods: 65 | 66 | * The 'empty' method comes from the 'Control.Applicative.Alternative' class and 67 | corresponds to the /empty graph/. This module simply re-exports it. 68 | 69 | * The 'vertex' graph construction primitive is an alias for 'pure' of the 70 | 'Applicative' type class. 71 | 72 | * Graph 'overlay' is an alias for 'mplus' of the 'MonadPlus' type class. 73 | 74 | The 'Graph' type class is characterised by the following minimal set of axioms. 75 | In equations we use @+@ and @*@ as convenient shortcuts for 'overlay' and 76 | 'connect', respectively. 77 | 78 | * 'overlay' is commutative and associative: 79 | 80 | > x + y == y + x 81 | > x + (y + z) == (x + y) + z 82 | 83 | * 'connect' is associative and has 'empty' as the identity: 84 | 85 | > x * empty == x 86 | > empty * x == x 87 | > x * (y * z) == (x * y) * z 88 | 89 | * 'connect' distributes over 'overlay': 90 | 91 | > x * (y + z) == x * y + x * z 92 | > (x + y) * z == x * z + y * z 93 | 94 | * 'connect' can be decomposed: 95 | 96 | > x * y * z == x * y + x * z + y * z 97 | 98 | The following useful theorems can be proved from the above set of axioms. 99 | 100 | * 'overlay' has 'empty' as the identity and is idempotent: 101 | 102 | > x + empty == x 103 | > empty + x == x 104 | > x + x == x 105 | 106 | * Absorption and saturation of 'connect': 107 | 108 | > x * y + x + y == x * y 109 | > x * x * x == x * x 110 | 111 | The core type class 'Graph' corresponds to unlabelled directed graphs. 112 | 'Undirected', 'Reflexive', 'Transitive' and 'Preorder' graphs can be obtained 113 | by extending the minimal set of axioms. 114 | 115 | When specifying the time and memory complexity of graph algorithms, /n/ will 116 | denote the number of vertices in the graph, /m/ will denote the number of 117 | edges in the graph, and /s/ will denote the /size/ of the corresponding 118 | 'Graph' expression. 119 | -} 120 | class MonadPlus g => Graph g where 121 | -- | Connect two graphs. 122 | connect :: g a -> g a -> g a 123 | 124 | instance Graph G.Graph where 125 | connect = G.connect 126 | 127 | -- | Construct the graph comprising a single isolated vertex. An alias for 'pure'. 128 | vertex :: Graph g => a -> g a 129 | vertex = pure 130 | 131 | -- | Overlay two graphs. An alias for '<|>'. 132 | overlay :: Graph g => g a -> g a -> g a 133 | overlay = (<|>) 134 | 135 | {-| 136 | The class of /undirected graphs/ that satisfy the following additional axiom. 137 | 138 | * 'connect' is commutative: 139 | 140 | > x * y == y * x 141 | -} 142 | class Graph g => Undirected g 143 | 144 | {-| 145 | The class of /reflexive graphs/ that satisfy the following additional axiom. 146 | 147 | * Each vertex has a /self-loop/: 148 | 149 | > vertex x == vertex x * vertex x 150 | 151 | Or, alternatively, if we remember that 'vertex' is an alias for 'pure': 152 | 153 | > pure x == pure x * pure x 154 | 155 | Note that by applying the axiom in the reverse direction, one can always remove 156 | all self-loops resulting in an /irreflexive graph/. This type class can 157 | therefore be also used in the context of irreflexive graphs. 158 | -} 159 | class Graph g => Reflexive g 160 | 161 | {-| 162 | The class of /transitive graphs/ that satisfy the following additional axiom. 163 | 164 | * The /closure/ axiom: graphs with equal transitive closures are equal. 165 | 166 | > y /= empty ==> x * y + x * z + y * z == x * y + y * z 167 | 168 | By repeated application of the axiom one can turn any graph into its transitive 169 | closure or transitive reduction. 170 | -} 171 | class Graph g => Transitive g 172 | 173 | {-| 174 | The class of /preorder graphs/ that are both reflexive and transitive. 175 | -} 176 | class (Reflexive g, Transitive g) => Preorder g 177 | 178 | -- | Construct the graph comprising a single edge. 179 | -- 180 | -- @ 181 | -- edge x y == 'connect' ('vertex' x) ('vertex' y) 182 | -- 'vertexCount' (edge 1 1) == 1 183 | -- 'vertexCount' (edge 1 2) == 2 184 | -- @ 185 | edge :: Graph g => a -> a -> g a 186 | edge x y = connect (vertex x) (vertex y) 187 | 188 | -- | Construct the graph comprising a given list of isolated vertices. 189 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 190 | -- given list. 191 | -- 192 | -- @ 193 | -- vertices [] == 'empty' 194 | -- vertices [x] == 'vertex' x 195 | -- vertices == 'overlays' . map 'vertex' 196 | -- 'hasVertex' x . vertices == 'elem' x 197 | -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' 198 | -- 'vertexSet' . vertices == Set.'Set.fromList' 199 | -- @ 200 | vertices :: Graph g => [a] -> g a 201 | vertices [] = empty 202 | vertices [x] = vertex x 203 | vertices (x:xs) = vertex x `overlay` vertices xs 204 | 205 | -- | Construct the graph from a list of edges. 206 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 207 | -- given list. 208 | -- 209 | -- @ 210 | -- edges [] == 'empty' 211 | -- edges [(x,y)] == 'edge' x y 212 | -- @ 213 | edges :: Graph g => [(a, a)] -> g a 214 | edges = overlays . map (uncurry edge) 215 | 216 | -- | Overlay a given list of graphs. 217 | -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length 218 | -- of the given list, and /S/ is the sum of sizes of the graphs in the list. 219 | -- 220 | -- @ 221 | -- overlays [] == 'empty' 222 | -- overlays [x] == x 223 | -- overlays [x,y] == 'overlay' x y 224 | -- overlays == 'foldr' 'overlay' 'empty' 225 | -- 'isEmpty' . overlays == 'all' 'isEmpty' 226 | -- @ 227 | overlays :: Graph g => [g a] -> g a 228 | overlays [] = empty 229 | overlays [x] = x 230 | overlays (x:xs) = x `overlay` overlays xs 231 | 232 | -- | Connect a given list of graphs. 233 | -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length 234 | -- of the given list, and /S/ is the sum of sizes of the graphs in the list. 235 | -- 236 | -- @ 237 | -- connects [] == 'empty' 238 | -- connects [x] == x 239 | -- connects [x,y] == 'connect' x y 240 | -- connects == 'foldr' 'connect' 'empty' 241 | -- 'isEmpty' . connects == 'all' 'isEmpty' 242 | -- @ 243 | connects :: Graph g => [g a] -> g a 244 | connects [] = empty 245 | connects [x] = x 246 | connects (x:xs) = x `connect` connects xs 247 | 248 | -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the 249 | -- first graph is a /subgraph/ of the second. Here is the current implementation: 250 | -- 251 | -- @ 252 | -- isSubgraphOf x y = 'overlay' x y == y 253 | -- @ 254 | -- The complexity therefore depends on the complexity of equality testing of 255 | -- the specific graph instance. 256 | -- 257 | -- @ 258 | -- isSubgraphOf 'empty' x == True 259 | -- isSubgraphOf ('vertex' x) 'empty' == False 260 | -- isSubgraphOf x ('overlay' x y) == True 261 | -- isSubgraphOf ('overlay' x y) ('connect' x y) == True 262 | -- isSubgraphOf ('path' xs) ('circuit' xs) == True 263 | -- @ 264 | isSubgraphOf :: (Graph g, Eq (g a)) => g a -> g a -> Bool 265 | isSubgraphOf x y = overlay x y == y 266 | 267 | -- | Check if a graph contains a given edge. 268 | -- Complexity: /O(s)/ time. 269 | -- 270 | -- @ 271 | -- hasEdge x y 'empty' == False 272 | -- hasEdge x y ('vertex' z) == False 273 | -- hasEdge x y ('edge' x y) == True 274 | -- hasEdge x y == 'elem' (x,y) . 'edgeList' 275 | -- @ 276 | hasEdge :: (Eq (g a), Graph g, Ord a) => a -> a -> g a -> Bool 277 | hasEdge u v = (edge u v `isSubgraphOf`) . induce (\x -> x == u || x == v) 278 | 279 | -- | The /path/ on a list of vertices. 280 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 281 | -- given list. 282 | -- 283 | -- @ 284 | -- path [] == 'empty' 285 | -- path [x] == 'vertex' x 286 | -- path [x,y] == 'edge' x y 287 | -- @ 288 | path :: Graph g => [a] -> g a 289 | path xs = case xs of [] -> empty 290 | [x] -> vertex x 291 | (_:ys) -> edges (zip xs ys) 292 | 293 | -- | The /circuit/ on a list of vertices. 294 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 295 | -- given list. 296 | -- 297 | -- @ 298 | -- circuit [] == 'empty' 299 | -- circuit [x] == 'edge' x x 300 | -- circuit [x,y] == 'edges' [(x,y), (y,x)] 301 | -- @ 302 | circuit :: Graph g => [a] -> g a 303 | circuit [] = empty 304 | circuit (x:xs) = path $ [x] ++ xs ++ [x] 305 | 306 | -- | The /clique/ on a list of vertices. 307 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 308 | -- given list. 309 | -- 310 | -- @ 311 | -- clique [] == 'empty' 312 | -- clique [x] == 'vertex' x 313 | -- clique [x,y] == 'edge' x y 314 | -- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] 315 | -- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) 316 | -- @ 317 | clique :: Graph g => [a] -> g a 318 | clique = connects . map vertex 319 | 320 | -- | The /biclique/ on two lists of vertices. 321 | -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the 322 | -- lengths of the given lists. 323 | -- 324 | -- @ 325 | -- biclique [] [] == 'empty' 326 | -- biclique [x] [] == 'vertex' x 327 | -- biclique [] [y] == 'vertex' y 328 | -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] 329 | -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) 330 | -- @ 331 | biclique :: Graph g => [a] -> [a] -> g a 332 | biclique xs [] = vertices xs 333 | biclique [] ys = vertices ys 334 | biclique xs ys = connect (vertices xs) (vertices ys) 335 | 336 | -- | The /star/ formed by a centre vertex connected to a list of leaves. 337 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the 338 | -- given list. 339 | -- 340 | -- @ 341 | -- star x [] == 'vertex' x 342 | -- star x [y] == 'edge' x y 343 | -- star x [y,z] == 'edges' [(x,y), (x,z)] 344 | -- star x ys == 'connect' ('vertex' x) ('vertices' ys) 345 | -- @ 346 | star :: Graph g => a -> [a] -> g a 347 | star x [] = vertex x 348 | star x ys = connect (vertex x) (vertices ys) 349 | 350 | -- | The /stars/ formed by overlaying a list of 'star's. An inverse of 351 | -- 'adjacencyList'. 352 | -- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the 353 | -- input. 354 | -- 355 | -- @ 356 | -- stars [] == 'empty' 357 | -- stars [(x, [])] == 'vertex' x 358 | -- stars [(x, [y])] == 'edge' x y 359 | -- stars [(x, ys)] == 'star' x ys 360 | -- stars == 'overlays' . 'map' ('uncurry' 'star') 361 | -- stars . 'adjacencyList' == id 362 | -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) 363 | -- @ 364 | stars :: Graph g => [(a, [a])] -> g a 365 | stars = overlays . map (uncurry star) 366 | 367 | -- | The /tree graph/ constructed from a given 'Tree' data structure. 368 | -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the 369 | -- given tree (i.e. the number of vertices in the tree). 370 | -- 371 | -- @ 372 | -- tree (Node x []) == 'vertex' x 373 | -- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] 374 | -- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] 375 | -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] 376 | -- @ 377 | tree :: Graph g => Tree a -> g a 378 | tree (Node x []) = vertex x 379 | tree (Node x f ) = star x (map rootLabel f) 380 | `overlay` forest (filter (not . null . subForest) f) 381 | 382 | -- | The /forest graph/ constructed from a given 'Forest' data structure. 383 | -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the 384 | -- given forest (i.e. the number of vertices in the forest). 385 | -- 386 | -- @ 387 | -- forest [] == 'empty' 388 | -- forest [x] == 'tree' x 389 | -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] 390 | -- forest == 'overlays' . 'map' 'tree' 391 | -- @ 392 | forest :: Graph g => Forest a -> g a 393 | forest = overlays . map tree 394 | 395 | -- | Construct a /mesh graph/ from two lists of vertices. 396 | -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the 397 | -- lengths of the given lists. 398 | -- 399 | -- @ 400 | -- mesh xs [] == 'empty' 401 | -- mesh [] ys == 'empty' 402 | -- mesh [x] [y] == 'vertex' (x, y) 403 | -- mesh xs ys == 'box' ('path' xs) ('path' ys) 404 | -- mesh [1..3] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\')) 405 | -- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ] 406 | -- @ 407 | mesh :: Graph g => [a] -> [b] -> g (a, b) 408 | mesh [] _ = empty 409 | mesh _ [] = empty 410 | mesh [x] [y] = vertex (x, y) 411 | mesh xs ys = stars $ [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ipxs, (b1, b2) <- ipys ] 412 | ++ [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] 413 | ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] 414 | where 415 | lx = last xs 416 | ly = last ys 417 | ipxs = init (pairs xs) 418 | ipys = init (pairs ys) 419 | 420 | -- | Construct a /torus graph/ from two lists of vertices. 421 | -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the 422 | -- lengths of the given lists. 423 | -- 424 | -- @ 425 | -- torus xs [] == 'empty' 426 | -- torus [] ys == 'empty' 427 | -- torus [x] [y] == 'edge' (x,y) (x,y) 428 | -- torus xs ys == 'box' ('circuit' xs) ('circuit' ys) 429 | -- torus [1,2] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\')) 430 | -- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] 431 | -- @ 432 | torus :: Graph g => [a] -> [b] -> g (a, b) 433 | torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] 434 | 435 | -- | Auxiliary function for 'mesh' and 'torus' 436 | pairs :: [a] -> [(a, a)] 437 | pairs [] = [] 438 | pairs as@(x:xs) = zip as (xs ++ [x]) 439 | 440 | -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols 441 | -- from a given alphabet. 442 | -- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the 443 | -- alphabet and /D/ is the dimension of the graph. 444 | -- 445 | -- @ 446 | -- deBruijn 0 xs == 'edge' [] [] 447 | -- n > 0 ==> deBruijn n [] == 'empty' 448 | -- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] 449 | -- deBruijn 2 "0" == 'edge' "00" "00" 450 | -- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") 451 | -- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] 452 | -- transpose (deBruijn n xs) == 'fmap' 'reverse' $ deBruijn n xs 453 | -- 'vertexCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^n 454 | -- n > 0 ==> 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) 455 | -- @ 456 | deBruijn :: Graph g => Int -> [a] -> g [a] 457 | deBruijn 0 _ = edge [] [] 458 | deBruijn len alphabet = skeleton >>= expand 459 | where 460 | overlaps = mapM (const alphabet) [2..len] 461 | skeleton = edges [ (Left s, Right s) | s <- overlaps ] 462 | expand v = vertices [ either ([a] ++) (++ [a]) v | a <- alphabet ] 463 | 464 | -- | Construct the /induced subgraph/ of a given graph by removing the 465 | -- vertices that do not satisfy a given predicate. 466 | -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes 467 | -- constant time. 468 | -- 469 | -- @ 470 | -- induce ('const' True ) x == x 471 | -- induce ('const' False) x == 'empty' 472 | -- induce (/= x) == 'removeVertex' x 473 | -- induce p . induce q == induce (\\x -> p x && q x) 474 | -- 'isSubgraphOf' (induce p x) x == True 475 | -- @ 476 | induce :: Graph g => (a -> Bool) -> g a -> g a 477 | induce = mfilter 478 | 479 | -- | Remove a vertex from a given graph. 480 | -- Complexity: /O(s)/ time, memory and size. 481 | -- 482 | -- @ 483 | -- removeVertex x ('vertex' x) == 'empty' 484 | -- removeVertex 1 ('vertex' 2) == 'vertex' 2 485 | -- removeVertex x ('edge' x x) == 'empty' 486 | -- removeVertex 1 ('edge' 1 2) == 'vertex' 2 487 | -- removeVertex x . removeVertex x == removeVertex x 488 | -- @ 489 | removeVertex :: (Eq a, Graph g) => a -> g a -> g a 490 | removeVertex v = induce (/= v) 491 | 492 | -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a 493 | -- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. 494 | -- Complexity: /O(s)/ time, memory and size. 495 | -- 496 | -- @ 497 | -- replaceVertex x x == id 498 | -- replaceVertex x y ('vertex' x) == 'vertex' y 499 | -- replaceVertex x y == 'mergeVertices' (== x) y 500 | -- @ 501 | replaceVertex :: (Eq a, Graph g) => a -> a -> g a -> g a 502 | replaceVertex u v = fmap $ \w -> if w == u then v else w 503 | 504 | -- | Merge vertices satisfying a given predicate into a given vertex. 505 | -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes 506 | -- constant time. 507 | -- 508 | -- @ 509 | -- mergeVertices ('const' False) x == id 510 | -- mergeVertices (== x) y == 'replaceVertex' x y 511 | -- mergeVertices 'even' 1 (0 * 2) == 1 * 1 512 | -- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 513 | -- @ 514 | mergeVertices :: Graph g => (a -> Bool) -> a -> g a -> g a 515 | mergeVertices p v = fmap $ \w -> if p w then v else w 516 | 517 | -- | Split a vertex into a list of vertices with the same connectivity. 518 | -- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of 519 | -- occurrences of the vertex in the expression and /L/ is the length of the 520 | -- given list. 521 | -- 522 | -- @ 523 | -- splitVertex x [] == 'removeVertex' x 524 | -- splitVertex x [x] == id 525 | -- splitVertex x [y] == 'replaceVertex' x y 526 | -- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) 527 | -- @ 528 | splitVertex :: (Eq a, Graph g) => a -> [a] -> g a -> g a 529 | splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w 530 | --------------------------------------------------------------------------------