Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Use Semigroup constraint for LAM instead of Monoid #308

Open
wants to merge 1 commit into
base: main
Choose a base branch
from
Open

Use Semigroup constraint for LAM instead of Monoid #308

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion src/Algebra/Graph/Class.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -155,7 +155,7 @@ instance Dioid e => Graph (LG.Graph e a) where
overlay = LG.overlay
connect = LG.connect one

instance (Dioid e, Eq e, Ord a) => Graph (LAM.AdjacencyMap e a) where
instance (Dioid e, Ord a) => Graph (LAM.AdjacencyMap e a) where
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is a little frustrating but probably acceptable. Technically, LAM.AdjacencyMap seems like it could be a Graph so long as it has the multiplicative monoid even if it doesn't have the additive one (that is, it has <.> and one but doesn't have zero). Thus, the Dioid e constraint is too strong. However, there's no nice way to represent this, so it seems like we should just require the full Dioid e constraint.

type Vertex (LAM.AdjacencyMap e a) = a
empty = LAM.empty
vertex = LAM.vertex
Expand Down
2 changes: 1 addition & 1 deletion src/Algebra/Graph/Labelled.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -118,7 +118,7 @@ instance (Eq e, Monoid e, Ord a) => T.ToGraph (Graph e a) where
-- 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
toAdjacencyMap = foldg AM.empty AM.vertex (\e x y -> AM.trimZeroes $ AM.connect e x y)
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I haven't used this module much, but I'm pretty sure this is the right place to make a minimal change that will appropriately trim zero out of the adjacency maps produced from this module.


-- Convert the adjacency map to a graph.
fromAdjacencyMap :: Monoid e => AM.AdjacencyMap e a -> Graph e a
Expand Down
104 changes: 49 additions & 55 deletions src/Algebra/Graph/Labelled/AdjacencyMap.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,7 @@ module Algebra.Graph.Labelled.AdjacencyMap (

-- * Graph transformation
removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap,
emap, induce, induceJust,
emap, induce, induceJust, trimZeroes,

-- * Relational operations
closure, reflexiveClosure, symmetricClosure, transitiveClosure,
Expand All @@ -59,10 +59,8 @@ import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

-- | Edge-labelled graphs, where the type variable @e@ stands for edge labels.
-- For example, 'AdjacencyMap' @Bool@ @a@ is isomorphic to unlabelled graphs
-- defined in the top-level module "Algebra.Graph.AdjacencyMap", where @False@
-- and @True@ denote the lack of and the existence of an unlabelled edge,
-- respectively.
-- For example, 'AdjacencyMap' @()@ @a@ is isomorphic to unlabelled graphs
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't like that this module becomes so different from Algebra.Graph.Labelled but not sure what to do about this. Something doesn't feel right, still.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I agree. Something still feels off.

I think the weirdness comes down to the fact that the edge type, really, is a monoid, even if it's only declared as a semigroup. This is because any semigroup can be trivially lifted to a monoid by wrapping it with Maybe, or, more generally, by defining a new, separate empty value and properly updating the binary operator to treat it appropriately. In the case of these adjacency maps, we're doing exactly this: we're treating the absence of an edge as mempty, thus forming an ad hoc monoid.

So, I think the reason the above text feels off is that, morally, we're constructing AdjacencyMap (Maybe ()) a as isomorphic to unlabelled graphs, but we're totally hiding the Maybe part as an implementation detail. (To be clear, this "hiding Maybe as an implementation detail" is the whole reason I proposed this change in the first place.) This should probably be called out in this comment.

-- defined in the top-level module "Algebra.Graph.AdjacencyMap".
newtype AdjacencyMap e a = AM {
-- | The /adjacency map/ of an edge-labelled graph: each vertex is
-- associated with a map from its direct successors to the corresponding
Expand Down Expand Up @@ -90,7 +88,7 @@ instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where
showString " " . showsPrec 11 y
xs -> showString "edges " . showsPrec 11 xs

instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where
instance (Ord e, Semigroup e, Ord a) => Ord (AdjacencyMap e a) where
compare x y = mconcat
[ compare (vertexCount x) (vertexCount y)
, compare (vertexSet x) (vertexSet y)
Expand All @@ -117,16 +115,16 @@ instance IsString a => IsString (AdjacencyMap e a) where
fromString = vertex . fromString

-- | Defined via 'overlay'.
instance (Ord a, Eq e, Monoid e) => Semigroup (AdjacencyMap e a) where
instance (Ord a, Semigroup e) => Semigroup (AdjacencyMap e a) where
(<>) = overlay

-- | Defined via 'overlay' and 'empty'.
instance (Ord a, Eq e, Monoid e) => Monoid (AdjacencyMap e a) where
instance (Ord a, Semigroup e) => Monoid (AdjacencyMap e a) where
mempty = empty

-- TODO: Add tests.
-- | Defined via 'skeleton' and the 'T.ToGraph' instance of 'AM.AdjacencyMap'.
instance (Eq e, Monoid e, Ord a) => T.ToGraph (AdjacencyMap e a) where
instance (Ord a, Semigroup e) => T.ToGraph (AdjacencyMap e a) where
type ToVertex (AdjacencyMap e a) = a
toGraph = T.toGraph . skeleton
foldg e v o c = T.foldg e v o c . skeleton
Expand Down Expand Up @@ -174,16 +172,14 @@ vertex x = AM $ Map.singleton x Map.empty
--
-- @
-- 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')
-- 'hasEdge' x y (edge e x y) == True
-- 'edgeLabel' x y (edge e x y) == e
-- 'edgeCount' (edge e x y) == if e == 'zero' then 0 else 1
-- 'edgeCount' (edge e x y) == 1
-- 'vertexCount' (edge e 1 1) == 1
-- 'vertexCount' (edge e 1 2) == 2
-- @
edge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a
edge e x y | e == zero = vertices [x, y]
| x == y = AM $ Map.singleton x (Map.singleton x e)
edge :: (Ord a) => e -> a -> a -> AdjacencyMap e a
edge e x y | x == y = AM $ Map.singleton x (Map.singleton x e)
| otherwise = AM $ Map.fromList [(x, Map.singleton y e), (y, Map.empty)]

-- | The left-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for
Expand All @@ -201,7 +197,7 @@ g -< e = (g, e)
-- @
-- x -\<e\>- y == 'edge' e x y
-- @
(>-) :: (Eq e, Monoid e, Ord a) => (a, e) -> a -> AdjacencyMap e a
(>-) :: (Ord a) => (a, e) -> a -> AdjacencyMap e a
(x, e) >- y = edge e x y

infixl 5 -<
Expand All @@ -222,12 +218,11 @@ infixl 5 >-
-- 'edgeCount' (overlay 1 2) == 0
-- @
--
-- Note: 'overlay' composes edges in parallel using the operator '<+>' with
-- 'zero' acting as the identity:
-- Note: 'overlay' composes edges in parallel using the operator '<>':
--
-- @
-- '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
-- 'edgeLabel' x y $ overlay ('edge' e x y) empty == e
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Overlaying with empty doesn't seem to make much sense here. I think I would actually prefer to keep this comment talking about <+> and zero, for symmetry with the one below, saying something like "Assuming that 'zero' exists...".

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Also, if you're changing examples here, you should update them in the testsuite too.

-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<>' f
-- @
--
-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in
Expand All @@ -237,16 +232,20 @@ infixl 5 >-
-- '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 :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay (AM x) (AM y) = AM $ Map.unionWith nonZeroUnion x y
overlay :: (Semigroup e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay (AM x) (AM y) = AM $ Map.unionWith (Map.unionWith (<>)) x y

-- Union maps, removing zero elements from the result.
nonZeroUnion :: (Eq e, Monoid e, Ord a) => Map a e -> Map a e -> Map a e
nonZeroUnion x y = Map.filter (/= zero) $ Map.unionWith mappend x y

-- Drop all edges with zero labels.
trimZeroes :: (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e)
trimZeroes = Map.map (Map.filter (/= zero))
-- | An 'AdjacencyMap' represents the absense of an edge by excluding the edge
-- from the underlying set of adjacencies. This is both for performance reasons
-- and also to allow edge types that are 'Semigroup' but /not/ 'Monoid' (that
-- is, they have no 'zero' value). For edge types that do have a 'zero' value,
-- then for performance reasons, it is optimal to exclude all 'zero' edges.
--
-- 'trimZeros x' is behaviorally an identity function, but it should be used for
-- performance reasons when a monoidal edge type is used and 'zero' edges may
-- have slipped into the underlying representation.
trimZeroes :: (Eq e, Monoid e) => AdjacencyMap e a -> AdjacencyMap e a
trimZeroes (AM x) = AM $ Map.map (Map.filter (/= zero)) x
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Exposing this seems like an abstraction leak. However, keeping it hidden could cause users to suffer from performance penalties if their edge type has zero.

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Given that the implementation doesn't care much about zeroes, should we provide a more general function like filterEdges?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I want to propose a radical alternative. Instead of exposing trimZeros (or filterEdges), we make the monoid explicit and this function implicit. I feel like Haskell's type classes are not quite equipped to deal with this, but I can think of a work around. We could define:

data AdjacencyMap e a = AM {
    -- | The /adjacency map/ of an edge-labelled graph: each vertex is
    -- associated with a map from its direct successors to the corresponding
    -- edge labels.
    adjacencyMap :: Map a (Map a e),
    zeroEdge :: Maybe e
  } deriving (Eq, Generic, NFData)

Then, we could have two constructors, one that takes a Semigroup constraint and sets zeroEdge = Nothing and the other that takes a Monoid constraint and sets it to mempty. We'd add back in all the uses of filterZeros, but they'd be guarded by whether zeroEdge was Nothing or not.


-- | /Connect/ two graphs with edges labelled by a given label. When applied to
-- the same labels, this is an associative operation with the identity 'empty',
Expand All @@ -262,12 +261,9 @@ trimZeroes = Map.map (Map.filter (/= zero))
-- 'vertexCount' (connect e x y) <= 'vertexCount' x + 'vertexCount' y
-- 'edgeCount' (connect e x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y
-- 'vertexCount' (connect e 1 2) == 2
-- 'edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1
-- @
connect :: (Eq e, Monoid e, Ord a) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
connect e (AM x) (AM y)
| e == mempty = overlay (AM x) (AM y)
| otherwise = AM $ Map.unionsWith nonZeroUnion $ x : y :
connect :: (Semigroup e, Ord a) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
connect e (AM x) (AM y) = AM $ Map.unionsWith (Map.unionWith (<>)) $ x : y :
[ Map.fromSet (const targets) (Map.keysSet x) ]
where
targets = Map.fromSet (const e) (Map.keysSet y)
Expand Down Expand Up @@ -295,7 +291,7 @@ vertices = AM . Map.fromList . map (, Map.empty)
-- edges [(e,x,y)] == 'edge' e x y
-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y)
-- @
edges :: (Eq e, Monoid e, Ord a) => [(e, a, a)] -> AdjacencyMap e a
edges :: (Semigroup e, Ord a) => [(e, a, a)] -> AdjacencyMap e a
edges es = fromAdjacencyMaps [ (x, Map.singleton y e) | (e, x, y) <- es ]

-- | Overlay a given list of graphs.
Expand All @@ -308,8 +304,8 @@ edges es = fromAdjacencyMaps [ (x, Map.singleton y e) | (e, x, y) <- es ]
-- overlays == 'foldr' 'overlay' 'empty'
-- 'isEmpty' . overlays == 'all' 'isEmpty'
-- @
overlays :: (Eq e, Monoid e, Ord a) => [AdjacencyMap e a] -> AdjacencyMap e a
overlays = AM . Map.unionsWith nonZeroUnion . map adjacencyMap
overlays :: (Semigroup e, Ord a) => [AdjacencyMap e a] -> AdjacencyMap e a
overlays = AM . Map.unionsWith (Map.unionWith (<>)) . map adjacencyMap

-- | Construct a graph from a list of adjacency sets.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
Expand All @@ -320,11 +316,11 @@ overlays = AM . Map.unionsWith nonZeroUnion . map adjacencyMap
-- fromAdjacencyMaps [(x, Map.'Map.singleton' y e)] == if e == 'zero' then 'vertices' [x,y] else 'edge' e x y
-- 'overlay' (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs '++' ys)
-- @
fromAdjacencyMaps :: (Eq e, Monoid e, Ord a) => [(a, Map a e)] -> AdjacencyMap e a
fromAdjacencyMaps xs = AM $ trimZeroes $ Map.unionWith mappend vs es
fromAdjacencyMaps :: (Semigroup e, Ord a) => [(a, Map a e)] -> AdjacencyMap e a
fromAdjacencyMaps xs = AM $ Map.unionWith mappend vs es
where
vs = Map.fromSet (const Map.empty) . Set.unions $ map (Map.keysSet . snd) xs
es = Map.fromListWith (Map.unionWith mappend) xs
es = Map.fromListWith (Map.unionWith (<>)) xs

-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the
-- first graph is a /subgraph/ of the second.
Expand All @@ -336,10 +332,10 @@ fromAdjacencyMaps xs = AM $ trimZeroes $ Map.unionWith mappend vs es
-- isSubgraphOf ('vertex' x) 'empty' == False
-- isSubgraphOf x y ==> x <= y
-- @
isSubgraphOf :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> Bool
isSubgraphOf :: (Semigroup e, Eq e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> Bool
isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy (Map.isSubmapOfBy le) x y
where
le x y = mappend x y == y
le x y = x <> y == y

-- | Check if a graph is empty.
-- Complexity: /O(1)/ time.
Expand Down Expand Up @@ -531,7 +527,7 @@ removeEdge x y = AM . Map.adjust (Map.delete y) x . adjacencyMap
-- replaceVertex x y ('vertex' x) == 'vertex' y
-- replaceVertex x y == 'gmap' (\\v -> if v == x then y else v)
-- @
replaceVertex :: (Eq e, Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> AdjacencyMap e a
replaceVertex :: (Semigroup e, Ord a) => a -> a -> AdjacencyMap e a -> AdjacencyMap e a
replaceVertex u v = gmap $ \w -> if w == u then v else w

-- | Replace an edge from a given graph. If it doesn't exist, it will be created.
Expand All @@ -542,10 +538,8 @@ replaceVertex u v = gmap $ \w -> if w == u then v else w
-- 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 -> AdjacencyMap e a -> AdjacencyMap e a
replaceEdge e x y
| e == zero = AM . addY . Map.alter (Just . maybe Map.empty (Map.delete y)) x . adjacencyMap
| otherwise = AM . addY . Map.alter replace x . adjacencyMap
replaceEdge :: (Ord a) => e -> a -> a -> AdjacencyMap e a -> AdjacencyMap e a
replaceEdge e x y = AM . addY . Map.alter replace x . adjacencyMap
where
addY = Map.alter (Just . fromMaybe Map.empty) y
replace (Just m) = Just $ Map.insert y e m
Expand All @@ -560,11 +554,11 @@ replaceEdge e x y
-- transpose ('edge' e x y) == 'edge' e y x
-- transpose . transpose == id
-- @
transpose :: (Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a
transpose :: (Semigroup e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a
transpose (AM m) = AM $ Map.foldrWithKey combine vs m
where
-- No need to use @nonZeroUnion@ here, since we do not add any new edges
combine v es = Map.unionWith (Map.unionWith mappend) $
combine v es = Map.unionWith (Map.unionWith (<>)) $
Map.fromAscList [ (u, Map.singleton v e) | (u, e) <- Map.toAscList es ]
vs = Map.fromSet (const Map.empty) (Map.keysSet m)

Expand All @@ -580,9 +574,9 @@ transpose (AM m) = AM $ Map.foldrWithKey combine vs m
-- gmap 'id' == 'id'
-- gmap f . gmap g == gmap (f . g)
-- @
gmap :: (Eq e, Monoid e, Ord a, Ord b) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b
gmap f = AM . trimZeroes . Map.map (Map.mapKeysWith mappend f) .
Map.mapKeysWith (Map.unionWith mappend) f . adjacencyMap
gmap :: (Semigroup e, Ord a, Ord b) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b
gmap f = AM . Map.map (Map.mapKeysWith (<>) f) .
Map.mapKeysWith (Map.unionWith (<>)) f . adjacencyMap

-- | Transform a graph by applying a function @h@ to each of its edge labels.
-- Complexity: /O((n + m) * log(n))/ time.
Expand Down Expand Up @@ -615,8 +609,8 @@ gmap f = AM . trimZeroes . Map.map (Map.mapKeysWith mappend f) .
-- emap 'id' == 'id'
-- emap g . emap h == emap (g . h)
-- @
emap :: (Eq f, Monoid f) => (e -> f) -> AdjacencyMap e a -> AdjacencyMap f a
emap h = AM . trimZeroes . Map.map (Map.map h) . adjacencyMap
emap :: (e -> f) -> AdjacencyMap e a -> AdjacencyMap f a
emap h = AM . Map.map (Map.map h) . adjacencyMap

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that do not satisfy a given predicate.
Expand Down Expand Up @@ -689,7 +683,7 @@ reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Map.insertWith (<+>) k one)
-- symmetricClosure x == 'overlay' x ('transpose' x)
-- symmetricClosure . symmetricClosure == symmetricClosure
-- @
symmetricClosure :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a
symmetricClosure :: (Semigroup e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a
symmetricClosure m = overlay m (transpose m)

-- | Compute the /transitive closure/ of a graph over the underlying star
Expand Down
6 changes: 3 additions & 3 deletions test/Algebra/Graph/Test/Arbitrary.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -182,10 +182,10 @@ instance Arbitrary AIM.AdjacencyIntMap where

-- | Generate an arbitrary labelled 'LAM.AdjacencyMap'. It is guaranteed
-- that the resulting adjacency map is 'consistent'.
arbitraryLabelledAdjacencyMap :: (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Gen (LAM.AdjacencyMap e a)
arbitraryLabelledAdjacencyMap :: (Arbitrary a, Ord a, Semigroup e, Arbitrary e) => Gen (LAM.AdjacencyMap e a)
arbitraryLabelledAdjacencyMap = LAM.fromAdjacencyMaps <$> arbitrary

instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.AdjacencyMap e a) where
instance (Arbitrary a, Ord a, Semigroup e, Arbitrary e) => Arbitrary (LAM.AdjacencyMap e a) where
arbitrary = arbitraryLabelledAdjacencyMap

shrink g = shrinkVertices ++ shrinkEdges
Expand All @@ -198,7 +198,7 @@ instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.Adj
let edges = LAM.edgeList g
in [ LAM.removeEdge v w g | (_, v, w) <- edges ]

-- | Generate an arbitrary labelled 'LAM.Graph' value of a specified size.
-- | Generate an arbitrary labelled 'LG.Graph' value of a specified size.
arbitraryLabelledGraph :: (Arbitrary a, Arbitrary e) => Gen (LG.Graph e a)
arbitraryLabelledGraph = sized expr
where
Expand Down