Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
661 lines (597 sloc) 25.5 KB
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Algebra.Graph.Labelled
-- Copyright : (c) Andrey Mokhov 2016-2019
-- License : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability : experimental
--
-- __Alga__ is a library for algebraic construction and manipulation of graphs
-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the
-- motivation behind the library, the underlying theory, and implementation details.
--
-- This module provides a minimal and experimental implementation of algebraic
-- graphs with edge labels. The API will be expanded in the next release.
-----------------------------------------------------------------------------
module Algebra.Graph.Labelled (
-- * Algebraic data type for edge-labeleld graphs
Graph (..), empty, vertex, edge, (-<), (>-), overlay, connect, vertices,
edges, overlays,
-- * Graph folding
foldg,
-- * Relations on graphs
isSubgraphOf,
-- * Graph properties
isEmpty, size, hasVertex, hasEdge, edgeLabel, vertexList, edgeList,
vertexSet, edgeSet,
-- * Graph transformation
removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, emap,
induce, induceJust,
-- * Relational operations
closure, reflexiveClosure, symmetricClosure, transitiveClosure,
-- * Types of edge-labelled graphs
UnlabelledGraph, Automaton, Network,
-- * Context
Context (..), context
) where
import Data.Bifunctor
import Data.Monoid (Any (..))
import Data.Semigroup ((<>))
import Control.DeepSeq
import GHC.Generics
import Algebra.Graph.Internal (List (..))
import Algebra.Graph.Label
import qualified Algebra.Graph.Labelled.AdjacencyMap as AM
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified GHC.Exts as Exts
-- | Edge-labelled graphs, where the type variable @e@ stands for edge labels.
-- For example, 'Graph' @Bool@ @a@ is isomorphic to unlabelled graphs defined in
-- the top-level module "Algebra.Graph.Graph", where @False@ and @True@ denote
-- the lack of and the existence of an unlabelled edge, respectively.
data Graph e a = Empty
| Vertex a
| Connect e (Graph e a) (Graph e a)
deriving (Functor, Show, Generic)
instance (Eq e, Monoid e, Ord a) => Eq (Graph e a) where
x == y = toAdjacencyMap x == toAdjacencyMap y
instance (Eq e, Monoid e, Ord a, Ord e) => Ord (Graph e a) where
compare x y = compare (toAdjacencyMap x) (toAdjacencyMap y)
-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph'
-- for more details.
instance (Ord a, Num a, Dioid e) => Num (Graph e a) where
fromInteger = vertex . fromInteger
(+) = overlay
(*) = connect one
signum = const empty
abs = id
negate = id
instance Bifunctor Graph where
bimap f g = foldg Empty (Vertex . g) (Connect . f)
instance (NFData e, NFData a) => NFData (Graph e a) where
rnf Empty = ()
rnf (Vertex x ) = rnf x
rnf (Connect e x y) = e `seq` rnf x `seq` rnf y
-- TODO: This is a very inefficient implementation. Find a way to construct an
-- adjacency map directly, without building intermediate representations for all
-- subgraphs.
-- Extract the adjacency map of a graph.
toAdjacencyMap :: (Eq e, Monoid e, Ord a) => Graph e a -> AM.AdjacencyMap e a
toAdjacencyMap = foldg AM.empty AM.vertex AM.connect
-- Convert the adjacency map to a graph.
fromAdjacencyMap :: Monoid e => AM.AdjacencyMap e a -> Graph e a
fromAdjacencyMap = overlays . map go . Map.toList . AM.adjacencyMap
where
go (u, m) = overlay (vertex u) (edges [ (e, u, v) | (v, e) <- Map.toList m])
-- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying
-- the provided functions to the leaves and internal nodes of the expression.
-- The order of arguments is: empty, vertex and connect.
-- Complexity: /O(s)/ applications of given functions. As an example, the
-- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/.
--
-- @
-- foldg 'empty' 'vertex' 'connect' == 'id'
-- foldg 'empty' 'vertex' ('fmap' 'flip' 'connect') == 'transpose'
-- foldg 1 ('const' 1) ('const' (+)) == 'size'
-- foldg True ('const' False) ('const' (&&)) == 'isEmpty'
-- foldg False (== x) ('const' (||)) == 'hasVertex' x
-- foldg Set.'Set.empty' Set.'Set.singleton' ('const' Set.'Set.union') == 'vertexSet'
-- @
foldg :: b -> (a -> b) -> (e -> b -> b -> b) -> Graph e a -> b
foldg e v c = go
where
go Empty = e
go (Vertex x ) = v x
go (Connect e x y) = c e (go x) (go y)
-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the
-- first graph is a /subgraph/ of the second.
-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a
-- graph can be quadratic with respect to the expression size /s/.
--
-- @
-- isSubgraphOf 'empty' x == True
-- isSubgraphOf ('vertex' x) 'empty' == False
-- isSubgraphOf x ('overlay' x y) == True
-- isSubgraphOf ('overlay' x y) ('connect' x y) == True
-- isSubgraphOf x y ==> x <= y
-- @
isSubgraphOf :: (Eq e, Monoid e, Ord a) => Graph e a -> Graph e a -> Bool
isSubgraphOf x y = overlay x y == y
-- | Construct the /empty graph/. An alias for the constructor 'Empty'.
-- Complexity: /O(1)/ time, memory and size.
--
-- @
-- 'isEmpty' empty == True
-- 'hasVertex' x empty == False
-- 'Algebra.Graph.ToGraph.vertexCount' empty == 0
-- 'Algebra.Graph.ToGraph.edgeCount' empty == 0
-- @
empty :: Graph e a
empty = Empty
-- | Construct the graph comprising /a single isolated vertex/. An alias for the
-- constructor 'Vertex'.
-- Complexity: /O(1)/ time, memory and size.
--
-- @
-- 'isEmpty' (vertex x) == False
-- 'hasVertex' x (vertex x) == True
-- 'Algebra.Graph.ToGraph.vertexCount' (vertex x) == 1
-- 'Algebra.Graph.ToGraph.edgeCount' (vertex x) == 0
-- @
vertex :: a -> Graph e a
vertex = Vertex
-- | Construct the graph comprising /a single labelled edge/.
-- Complexity: /O(1)/ time, memory and size.
--
-- @
-- edge e x y == 'connect' e ('vertex' x) ('vertex' y)
-- edge 'zero' x y == 'vertices' [x,y]
-- 'hasEdge' x y (edge e x y) == (e /= 'zero')
-- 'edgeLabel' x y (edge e x y) == e
-- 'Algebra.Graph.ToGraph.edgeCount' (edge e x y) == if e == 'zero' then 0 else 1
-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 1) == 1
-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 2) == 2
-- @
edge :: e -> a -> a -> Graph e a
edge e x y = connect e (vertex x) (vertex y)
-- | The left-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for
-- creating labelled edges.
--
-- @
-- x -\<e\>- y == 'edge' e x y
-- @
(-<) :: a -> e -> (a, e)
g -< e = (g, e)
-- | The right-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for
-- creating labelled edges.
--
-- @
-- x -\<e\>- y == 'edge' e x y
-- @
(>-) :: (a, e) -> a -> Graph e a
(x, e) >- y = edge e x y
infixl 5 -<
infixl 5 >-
-- | /Overlay/ two graphs. An alias for 'Connect' 'zero'.
-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size.
--
-- @
-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y
-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y
-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) >= 'Algebra.Graph.ToGraph.vertexCount' x
-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y
-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) >= 'Algebra.Graph.ToGraph.edgeCount' x
-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) <= 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y
-- 'Algebra.Graph.ToGraph.vertexCount' (overlay 1 2) == 2
-- 'Algebra.Graph.ToGraph.edgeCount' (overlay 1 2) == 0
-- @
--
-- Note: 'overlay' composes edges in parallel using the operator '<+>' with
-- 'zero' acting as the identity:
--
-- @
-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e
-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<+>' f
-- @
--
-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in
-- sequence using the operator '<.>' with 'one' acting as the identity:
--
-- @
-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e
-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f y z)) == e '<.>' f
-- @
overlay :: Monoid e => Graph e a -> Graph e a -> Graph e a
overlay = connect zero
-- | /Connect/ two graphs with edges labelled by a given label. An alias for
-- 'Connect'.
-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number
-- of edges in the resulting graph is quadratic with respect to the number of
-- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.
--
-- @
-- 'isEmpty' (connect e x y) == 'isEmpty' x && 'isEmpty' y
-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y
-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) >= 'Algebra.Graph.ToGraph.vertexCount' x
-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y
-- 'Algebra.Graph.ToGraph.edgeCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x * 'Algebra.Graph.ToGraph.vertexCount' y + 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y
-- 'Algebra.Graph.ToGraph.vertexCount' (connect e 1 2) == 2
-- 'Algebra.Graph.ToGraph.edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1
-- @
connect :: e -> Graph e a -> Graph e a -> Graph e a
connect = Connect
-- | Construct the graph comprising a given list of isolated vertices.
-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the
-- given list.
--
-- @
-- vertices [] == 'empty'
-- vertices [x] == 'vertex' x
-- 'hasVertex' x . vertices == 'elem' x
-- 'Algebra.Graph.ToGraph.vertexCount' . vertices == 'length' . 'Data.List.nub'
-- 'Algebra.Graph.ToGraph.vertexSet' . vertices == Set.'Set.fromList'
-- @
vertices :: Monoid e => [a] -> Graph e a
vertices = overlays . map vertex
-- | Construct the graph from a list of labelled edges.
-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the
-- given list.
--
-- @
-- edges [] == 'empty'
-- edges [(e,x,y)] == 'edge' e x y
-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y)
-- @
edges :: Monoid e => [(e, a, a)] -> Graph e a
edges = overlays . map (\(e, x, y) -> edge e x y)
-- | Overlay a given list of graphs.
-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length
-- of the given list, and /S/ is the sum of sizes of the graphs in the list.
--
-- @
-- overlays [] == 'empty'
-- overlays [x] == x
-- overlays [x,y] == 'overlay' x y
-- overlays == 'foldr' 'overlay' 'empty'
-- 'isEmpty' . overlays == 'all' 'isEmpty'
-- @
overlays :: Monoid e => [Graph e a] -> Graph e a
overlays = foldr overlay empty
-- | Check if a graph is empty. A convenient alias for 'null'.
-- Complexity: /O(s)/ time.
--
-- @
-- isEmpty 'empty' == True
-- isEmpty ('overlay' 'empty' 'empty') == True
-- isEmpty ('vertex' x) == False
-- isEmpty ('removeVertex' x $ 'vertex' x) == True
-- isEmpty ('removeEdge' x y $ 'edge' e x y) == False
-- @
isEmpty :: Graph e a -> Bool
isEmpty = foldg True (const False) (const (&&))
-- | The /size/ of a graph, i.e. the number of leaves of the expression
-- including 'empty' leaves.
-- Complexity: /O(s)/ time.
--
-- @
-- size 'empty' == 1
-- size ('vertex' x) == 1
-- size ('overlay' x y) == size x + size y
-- size ('connect' x y) == size x + size y
-- size x >= 1
-- size x >= 'Algebra.Graph.ToGraph.vertexCount' x
-- @
size :: Graph e a -> Int
size = foldg 1 (const 1) (const (+))
-- | Check if a graph contains a given vertex.
-- Complexity: /O(s)/ time.
--
-- @
-- hasVertex x 'empty' == False
-- hasVertex x ('vertex' x) == True
-- hasVertex 1 ('vertex' 2) == False
-- hasVertex x . 'removeVertex' x == 'const' False
-- @
hasVertex :: Eq a => a -> Graph e a -> Bool
hasVertex x = foldg False (==x) (const (||))
-- | Check if a graph contains a given edge.
-- Complexity: /O(s)/ time.
--
-- @
-- hasEdge x y 'empty' == False
-- hasEdge x y ('vertex' z) == False
-- hasEdge x y ('edge' e x y) == (e /= 'zero')
-- hasEdge x y . 'removeEdge' x y == 'const' False
-- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList'
-- @
hasEdge :: (Eq e, Monoid e, Ord a) => a -> a -> Graph e a -> Bool
hasEdge x y = (/= zero) . edgeLabel x y
-- | Extract the label of a specified edge from a graph.
edgeLabel :: (Eq a, Monoid e) => a -> a -> Graph e a -> e
edgeLabel s t g = let (res, _, _) = foldg e v c g in res
where
e = (zero , False , False )
v x = (zero , x == s , x == t )
c l (l1, s1, t1) (l2, s2, t2) | s1 && t2 = (mconcat [l1, l, l2], s1 || s2, t1 || t2)
| otherwise = (mconcat [l1, l2], s1 || s2, t1 || t2)
-- | The sorted list of vertices of a given graph.
-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.
--
-- @
-- vertexList 'empty' == []
-- vertexList ('vertex' x) == [x]
-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'
-- @
vertexList :: Ord a => Graph e a -> [a]
vertexList = Set.toAscList . vertexSet
-- | The list of edges of a graph, sorted lexicographically with respect to
-- pairs of connected vertices (i.e. edge-labels are ignored when sorting).
-- Complexity: /O(n + m)/ time and /O(m)/ memory.
--
-- @
-- edgeList 'empty' == []
-- edgeList ('vertex' x) == []
-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)]
-- @
edgeList :: (Eq e, Monoid e, Ord a) => Graph e a -> [(e, a, a)]
edgeList = AM.edgeList . toAdjacencyMap
-- | The set of vertices of a given graph.
-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.
--
-- @
-- vertexSet 'empty' == Set.'Set.empty'
-- vertexSet . 'vertex' == Set.'Set.singleton'
-- vertexSet . 'vertices' == Set.'Set.fromList'
-- @
vertexSet :: Ord a => Graph e a -> Set.Set a
vertexSet = foldg Set.empty Set.singleton (const Set.union)
-- | The set of edges of a given graph.
-- Complexity: /O(n + m)/ time and /O(m)/ memory.
--
-- @
-- edgeSet 'empty' == Set.'Set.empty'
-- edgeSet ('vertex' x) == Set.'Set.empty'
-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y)
-- @
edgeSet :: (Eq e, Monoid e, Ord a) => Graph e a -> Set.Set (e, a, a)
edgeSet = Set.fromAscList . edgeList
-- | Remove a vertex from a given graph.
-- Complexity: /O(s)/ time, memory and size.
--
-- @
-- removeVertex x ('vertex' x) == 'empty'
-- removeVertex 1 ('vertex' 2) == 'vertex' 2
-- removeVertex x ('edge' e x x) == 'empty'
-- removeVertex 1 ('edge' e 1 2) == 'vertex' 2
-- removeVertex x . removeVertex x == removeVertex x
-- @
removeVertex :: Eq a => a -> Graph e a -> Graph e a
removeVertex x = induce (/= x)
-- | Remove an edge from a given graph.
-- Complexity: /O(s)/ time, memory and size.
--
-- @
-- removeEdge x y ('edge' e x y) == 'vertices' [x,y]
-- removeEdge x y . removeEdge x y == removeEdge x y
-- removeEdge x y . 'removeVertex' x == 'removeVertex' x
-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2
-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2
-- @
removeEdge :: (Eq a, Eq e, Monoid e) => a -> a -> Graph e a -> Graph e a
removeEdge s t = filterContext s (/=s) (/=t)
-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a
-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged.
-- Complexity: /O(s)/ time, memory and size.
--
-- @
-- replaceVertex x x == id
-- replaceVertex x y ('vertex' x) == 'vertex' y
-- replaceVertex x y == 'fmap' (\\v -> if v == x then y else v)
-- @
replaceVertex :: Eq a => a -> a -> Graph e a -> Graph e a
replaceVertex u v = fmap $ \w -> if w == u then v else w
-- | Replace an edge from a given graph. If it doesn't exist, it will be created.
-- Complexity: /O(log(n))/ time.
--
-- @
-- replaceEdge e x y z == 'overlay' (removeEdge x y z) ('edge' e x y)
-- replaceEdge e x y ('edge' f x y) == 'edge' e x y
-- 'edgeLabel' x y (replaceEdge e x y z) == e
-- @
replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> Graph e a -> Graph e a
replaceEdge e x y = overlay (edge e x y) . removeEdge x y
-- | Transpose a given graph.
-- Complexity: /O(s)/ time, memory and size.
--
-- @
-- transpose 'empty' == 'empty'
-- transpose ('vertex' x) == 'vertex' x
-- transpose ('edge' e x y) == 'edge' e y x
-- transpose . transpose == id
-- @
transpose :: Graph e a -> Graph e a
transpose = foldg empty vertex (fmap flip connect)
-- | Transform a graph by applying a function to each of its edge labels.
-- Complexity: /O(s)/ time, memory and size.
--
-- The function @h@ is required to be a /homomorphism/ on the underlying type of
-- labels @e@. At the very least it must preserve 'zero' and '<+>':
--
-- @
-- h 'zero' == 'zero'
-- h x '<+>' h y == h (x '<+>' y)
-- @
--
-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative
-- structure:
--
-- @
-- h 'one' == 'one'
-- h x '<.>' h y == h (x '<.>' y)
-- @
--
-- If the above requirements hold, then the implementation provides the
-- following guarantees.
--
-- @
-- emap h 'empty' == 'empty'
-- emap h ('vertex' x) == 'vertex' x
-- emap h ('edge' e x y) == 'edge' (h e) x y
-- emap h ('overlay' x y) == 'overlay' (emap h x) (emap h y)
-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y)
-- emap 'id' == 'id'
-- emap g . emap h == emap (g . h)
-- @
emap :: (e -> f) -> Graph e a -> Graph f a
emap f = foldg Empty Vertex (Connect . f)
-- TODO: Implement via 'induceJust' to reduce code duplication.
-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that do not satisfy a given predicate.
-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes
-- /O(1)/ to be evaluated.
--
-- @
-- induce ('const' True ) x == x
-- induce ('const' False) x == 'empty'
-- induce (/= x) == 'removeVertex' x
-- induce p . induce q == induce (\\x -> p x && q x)
-- 'isSubgraphOf' (induce p x) x == True
-- @
induce :: (a -> Bool) -> Graph e a -> Graph e a
induce p = foldg Empty (\x -> if p x then Vertex x else Empty) c
where
c _ x Empty = x -- Constant folding to get rid of Empty leaves
c _ Empty y = y
c e x y = Connect e x y
-- | Construct the /induced subgraph/ of a given graph by removing the vertices
-- that are 'Nothing'.
-- Complexity: /O(s)/ time, memory and size.
--
-- @
-- induceJust ('vertex' 'Nothing') == 'empty'
-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x
-- induceJust . 'fmap' 'Just' == 'id'
-- induceJust . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p
-- @
induceJust :: Graph e (Maybe a) -> Graph e a
induceJust = foldg Empty (maybe Empty Vertex) c
where
c _ x Empty = x -- Constant folding to get rid of Empty leaves
c _ Empty y = y
c e x y = Connect e x y
-- | Compute the /reflexive and transitive closure/ of a graph over the
-- underlying star semiring using the Warshall-Floyd-Kleene algorithm.
--
-- @
-- closure 'empty' == 'empty'
-- closure ('vertex' x) == 'edge' 'one' x x
-- closure ('edge' e x x) == 'edge' 'one' x x
-- closure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)]
-- closure == 'reflexiveClosure' . 'transitiveClosure'
-- closure == 'transitiveClosure' . 'reflexiveClosure'
-- closure . closure == closure
-- 'Algebra.Graph.ToGraph.postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y)
-- @
closure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a
closure = fromAdjacencyMap . AM.closure . toAdjacencyMap
-- | Compute the /reflexive closure/ of a graph over the underlying semiring by
-- adding a self-loop of weight 'one' to every vertex.
-- Complexity: /O(n * log(n))/ time.
--
-- @
-- reflexiveClosure 'empty' == 'empty'
-- reflexiveClosure ('vertex' x) == 'edge' 'one' x x
-- reflexiveClosure ('edge' e x x) == 'edge' 'one' x x
-- reflexiveClosure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)]
-- reflexiveClosure . reflexiveClosure == reflexiveClosure
-- @
reflexiveClosure :: (Ord a, Semiring e) => Graph e a -> Graph e a
reflexiveClosure x = overlay x $ edges [ (one, v, v) | v <- vertexList x ]
-- | Compute the /symmetric closure/ of a graph by overlaying it with its own
-- transpose.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- symmetricClosure 'empty' == 'empty'
-- symmetricClosure ('vertex' x) == 'vertex' x
-- symmetricClosure ('edge' e x y) == 'edges' [(e,x,y), (e,y,x)]
-- symmetricClosure x == 'overlay' x ('transpose' x)
-- symmetricClosure . symmetricClosure == symmetricClosure
-- @
symmetricClosure :: Monoid e => Graph e a -> Graph e a
symmetricClosure m = overlay m (transpose m)
-- | Compute the /transitive closure/ of a graph over the underlying star
-- semiring using a modified version of the Warshall-Floyd-Kleene algorithm,
-- which omits the reflexivity step.
--
-- @
-- transitiveClosure 'empty' == 'empty'
-- transitiveClosure ('vertex' x) == 'vertex' x
-- transitiveClosure ('edge' e x y) == 'edge' e x y
-- transitiveClosure . transitiveClosure == transitiveClosure
-- @
transitiveClosure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a
transitiveClosure = fromAdjacencyMap . AM.transitiveClosure . toAdjacencyMap
-- | A type synonym for /unlabelled graphs/.
type UnlabelledGraph a = Graph Any a
-- | A type synonym for /automata/ or /labelled transition systems/.
type Automaton a s = Graph (RegularExpression a) s
-- | A /network/ is a graph whose edges are labelled with distances.
type Network e a = Graph (Distance e) a
-- Filter vertices in a subgraph context.
filterContext :: (Eq a, Eq e, Monoid e) => a -> (a -> Bool) -> (a -> Bool) -> Graph e a -> Graph e a
filterContext s i o g = maybe g go $ context (==s) g
where
go (Context is os) = overlays [ vertex s
, induce (/=s) g
, edges [ (e, v, s) | (e, v) <- is, i v ]
, edges [ (e, s, v) | (e, v) <- os, o v ] ]
-- The /focus/ of a graph expression is a flattened represenentation of the
-- subgraph under focus, its context, as well as the list of all encountered
-- vertices. See 'removeEdge' for a use-case example.
data Focus e a = Focus
{ ok :: Bool -- ^ True if focus on the specified subgraph is obtained.
, is :: List (e, a) -- ^ Inputs into the focused subgraph.
, os :: List (e, a) -- ^ Outputs out of the focused subgraph.
, vs :: List a } -- ^ All vertices (leaves) of the graph expression.
-- Focus on the 'empty' graph.
emptyFocus :: Focus e a
emptyFocus = Focus False mempty mempty mempty
-- | Focus on the graph with a single vertex, given a predicate indicating
-- whether the vertex is of interest.
vertexFocus :: (a -> Bool) -> a -> Focus e a
vertexFocus f x = Focus (f x) mempty mempty (pure x)
-- | Connect two foci.
connectFoci :: (Eq e, Monoid e) => e -> Focus e a -> Focus e a -> Focus e a
connectFoci e x y
| e == mempty = Focus (ok x || ok y) (is x <> is y) (os x <> os y) (vs x <> vs y)
| otherwise = Focus (ok x || ok y) (xs <> is y) (os x <> ys ) (vs x <> vs y)
where
xs = if ok y then fmap (e,) (vs x) else is x
ys = if ok x then fmap (e,) (vs y) else os y
-- | 'Focus' on a specified subgraph.
focus :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Focus e a
focus f = foldg emptyFocus (vertexFocus f) connectFoci
-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all
-- the vertices that are connected to the subgraph's vertices (along with the
-- corresponding edge labels). Note that inputs and outputs can belong to the
-- subgraph itself. In general, there are no guarantees on the order of vertices
-- in 'inputs' and 'outputs'; furthermore, there may be repetitions.
data Context e a = Context { inputs :: [(e, a)], outputs :: [(e, a)] }
deriving (Eq, Show)
-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns
-- @Nothing@ if the specified subgraph is empty.
--
-- @
-- context ('const' False) x == Nothing
-- context (== 1) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [ ] [(e,2)])
-- context (== 2) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [ ])
-- context ('const' True ) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [(e,2)])
-- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [('one',3), ('one',1)] [('one',1), ('one',5)])
-- @
context :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Maybe (Context e a)
context p g | ok f = Just $ Context (Exts.toList $ is f) (Exts.toList $ os f)
| otherwise = Nothing
where
f = focus p g
You can’t perform that action at this time.