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.

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

Add induceJust #209

Merged
merged 7 commits into from
Jun 7, 2019
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
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
1 change: 1 addition & 0 deletions AUTHORS.md
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@ The Alga library was originally developed by
but over time many contributors helped make it much better, including (among others):

* [Alexandre Moine](mailto:[email protected]) [@nobrakal](https://github.com/nobrakal)
* [Piotr Gawryś](mailto:[email protected]) [@Avasil](https://github.com/Avasil)

If you are not on this list, it's not because your contributions are not appreciated, but
because I didn't want to add your name and contact details without your consent. Please fix this
Expand Down
20 changes: 18 additions & 2 deletions src/Algebra/Graph.hs
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,7 @@ module Algebra.Graph (

-- * Graph transformation
removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex,
transpose, induce, simplify, sparsify, sparsifyKL,
transpose, induce, induceJust, simplify, sparsify, sparsifyKL,

-- * Graph composition
compose, box,
Expand All @@ -55,7 +55,7 @@ import Control.DeepSeq
import Control.Monad (MonadPlus (..))
import Control.Monad.State (runState, get, put)
import Data.Foldable (toList)
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, maybe)
import Data.Semigroup ((<>))
import Data.Tree
import GHC.Generics
Expand Down Expand Up @@ -1010,6 +1010,22 @@ induce p = foldg Empty (\x -> if p x then Vertex x else Empty) (k Overlay) (k Co
k f x y = f x y
{-# INLINE [1] induce #-}

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that are 'Nothing'.
-- Complexity: /O(s)/ time, memory and size.
-- @
-- induceJust ('vertex' 'Nothing') == 'empty'
-- induceJust (gmap Just x) == x
-- induceJust ('connect' (gmap Just x) ('vertex' 'Nothing')) == x
-- @
induceJust :: Graph (Maybe a) -> Graph a
induceJust = foldg Empty (maybe Empty Vertex) (k Overlay) (k Connect)
where
k _ x Empty = x -- Constant folding to get rid of Empty leaves
k _ Empty y = y
k f x y = f x y
{-# INLINE [1] induceJust #-}

-- | Simplify a graph expression. Semantically, this is the identity function,
-- but it simplifies a given expression according to the laws of the algebra.
-- The function does not compute the simplest possible expression,
Expand Down
17 changes: 16 additions & 1 deletion src/Algebra/Graph/AdjacencyMap.hs
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@ module Algebra.Graph.AdjacencyMap (

-- * Graph transformation
removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,
induce,
induce, induceJust,

-- * Graph composition
compose, box,
Expand All @@ -59,6 +59,7 @@ import Data.Tree
import GHC.Generics

import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set

{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to
Expand Down Expand Up @@ -754,6 +755,20 @@ gmap f = AM . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap
induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a
induce p = AM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that are 'Nothing'.
-- Complexity: /O(n)/ time.
-- @
-- induceJust ('vertex' 'Nothing') == 'empty'
-- induceJust (gmap Just x) == x
-- induceJust ('connect' (gmap Just x) ('vertex' 'Nothing')) == x
-- @
induceJust :: Ord a => AdjacencyMap (Maybe a) -> AdjacencyMap a
induceJust = AM . Map.map catMaybesSet . catMaybesMap . adjacencyMap
where
catMaybesSet = Set.mapMonotonic Maybe.fromJust . Set.delete Nothing
catMaybesMap = Map.mapKeysMonotonic Maybe.fromJust . Map.delete Nothing

-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are
-- connected in the resulting graph if there is a vertex @y@, such that @x@ is
-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the
Expand Down
17 changes: 16 additions & 1 deletion src/Algebra/Graph/Labelled.hs
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,7 @@ module Algebra.Graph.Labelled (

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

-- * Relational operations
closure, reflexiveClosure, symmetricClosure, transitiveClosure,
Expand Down Expand Up @@ -511,6 +511,21 @@ induce p = foldg Empty (\x -> if p x then Vertex x else Empty) c
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 (gmap Just x) == x
-- induceJust ('connect' (gmap Just x) ('vertex' 'Nothing')) == x
-- @
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.
--
Expand Down
15 changes: 14 additions & 1 deletion src/Algebra/Graph/Labelled/AdjacencyMap.hs
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,7 @@ module Algebra.Graph.Labelled.AdjacencyMap (

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

-- * Relational operations
closure, reflexiveClosure, symmetricClosure, transitiveClosure,
Expand Down Expand Up @@ -599,6 +599,19 @@ induce :: (a -> Bool) -> AdjacencyMap e a -> AdjacencyMap e a
induce p = AM . Map.map (Map.filterWithKey (\k _ -> p k)) .
Map.filterWithKey (\k _ -> p k) . adjacencyMap

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that are 'Nothing'.
-- Complexity: /O(n)/ time.
-- @
-- induceJust ('vertex' 'Nothing') == 'empty'
-- induceJust (gmap Just x) == x
-- induceJust ('connect' (gmap Just x) ('vertex' 'Nothing')) == x
-- @
induceJust :: Ord a => AdjacencyMap e (Maybe a) -> AdjacencyMap e a
induceJust = AM . Map.map catMaybesMap . catMaybesMap . adjacencyMap
where
catMaybesMap = Map.mapKeysMonotonic fromJust . Map.delete Nothing

-- | Compute the /reflexive and transitive closure/ of a graph over the
-- underlying star semiring using the Warshall-Floyd-Kleene algorithm.
--
Expand Down
19 changes: 18 additions & 1 deletion src/Algebra/Graph/NonEmpty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -47,7 +47,7 @@ module Algebra.Graph.NonEmpty (

-- * Graph transformation
removeVertex1, removeEdge, replaceVertex, mergeVertices, splitVertex1,
transpose, induce1, simplify, sparsify, sparsifyKL,
transpose, induce1, induceJust1, simplify, sparsify, sparsifyKL,

-- * Graph composition
box
Expand Down Expand Up @@ -847,6 +847,23 @@ induce1 p = foldg1
k _ a Nothing = a
k f (Just a) (Just b) = Just $ f a b


-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that are 'Nothing'. Returns 'Nothing' if the
-- resulting graph is empty.
-- Complexity: /O(s)/ time, memory and size.
-- @
-- induceJust1 ('vertex' 'Nothing') == `Nothing`
-- induceJust1 (fmap Just x) == Just x
-- induceJust1 ('connect' (fmap Just x) ('vertex' 'Nothing')) == Just x
-- @
induceJust1 :: Graph (Maybe a) -> Maybe (Graph a)
induceJust1 = foldg1 (fmap Vertex) (k Overlay) (k Connect)
where
k _ Nothing a = a
k _ a Nothing = a
k f (Just a) (Just b) = Just $ f a b

-- | Simplify a graph expression. Semantically, this is the identity function,
-- but it simplifies a given expression according to the laws of the algebra.
-- The function does not compute the simplest possible expression,
Expand Down
14 changes: 13 additions & 1 deletion src/Algebra/Graph/NonEmpty/AdjacencyMap.hs
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@ module Algebra.Graph.NonEmpty.AdjacencyMap (

-- * Graph transformation
removeVertex1, removeEdge, replaceVertex, mergeVertices, transpose, gmap,
induce1,
induce1, induceJust1,

-- * Graph closure
closure, reflexiveClosure, symmetricClosure, transitiveClosure,
Expand Down Expand Up @@ -629,6 +629,18 @@ gmap = coerce AM.gmap
induce1 :: (a -> Bool) -> AdjacencyMap a -> Maybe (AdjacencyMap a)
induce1 = fmap toNonEmpty . coerce AM.induce

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that are 'Nothing'. Returns 'Nothing' if the
-- resulting graph is empty.
-- Complexity: /O(n)/ time.
-- @
-- induceJust1 ('vertex' 'Nothing') == 'Nothing'
-- induceJust1 (gmap Just x) == Just x
-- induceJust1 ('connect' (gmap Just x) ('vertex' 'Nothing')) == Just x
-- @
induceJust1 :: Ord a => AdjacencyMap (Maybe a) -> Maybe (AdjacencyMap a)
induceJust1 m = toNonEmpty (AM.induceJust (coerce m))

-- | Compute the /reflexive and transitive closure/ of a graph.
-- Complexity: /O(n * m * log(n)^2)/ time.
--
Expand Down
25 changes: 22 additions & 3 deletions src/Algebra/Graph/Relation.hs
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,8 @@ module Algebra.Graph.Relation (
path, circuit, clique, biclique, star, stars, tree, forest,

-- * Graph transformation
removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce,
removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,
induce, induceJust,

-- * Relational operations
compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure,
Expand All @@ -46,8 +47,9 @@ import Data.Set (Set, union)
import Data.Tree
import Data.Tuple

import qualified Data.Set as Set
import qualified Data.Tree as Tree
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Tree as Tree

import Algebra.Graph.Internal

Expand Down Expand Up @@ -706,6 +708,23 @@ induce p (Relation d r) = Relation (Set.filter p d) (Set.filter pp r)
where
pp (x, y) = p x && p y

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that are 'Nothing'.
-- Complexity: /O(n)/ time.
-- @
-- induceJust ('vertex' 'Nothing') == 'empty'
-- induceJust (gmap Just x) == x
-- induceJust ('connect' (gmap Just x) ('vertex' 'Nothing')) == x
-- @
induceJust :: Ord a => Relation (Maybe a) -> Relation a
induceJust (Relation d r) = Relation (catMaybesSet d) (catMaybesSet' r)
where
catMaybesSet = Set.mapMonotonic Maybe.fromJust . Set.delete Nothing
catMaybesSet' = Set.mapMonotonic (\(x, y) -> (Maybe.fromJust x, Maybe.fromJust y)) . Set.filter p
p (Nothing, _) = False
p (_, Nothing) = False
p (_, _) = True

-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are
-- connected in the resulting graph if there is a vertex @y@, such that @x@ is
-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the
Expand Down
14 changes: 13 additions & 1 deletion src/Algebra/Graph/Relation/Symmetric.hs
Original file line number Diff line number Diff line change
Expand Up @@ -34,10 +34,11 @@ module Algebra.Graph.Relation.Symmetric (
path, circuit, clique, biclique, star, stars, tree, forest,

-- * Graph transformation
removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce,
removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, induceJust,

-- * Miscellaneous
consistent

) where

import Control.DeepSeq
Expand Down Expand Up @@ -607,6 +608,17 @@ gmap = coerce R.gmap
induce :: (a -> Bool) -> Relation a -> Relation a
induce = coerce R.induce

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that are 'Nothing'.
-- Complexity: /O(n)/ time.
-- @
-- induceJust ('vertex' 'Nothing') == 'empty'
-- induceJust (gmap Just x) == x
-- induceJust ('connect' (gmap Just x) ('vertex' 'Nothing')) == x
-- @
induceJust :: Ord a => Relation (Maybe a) -> Relation a
induceJust = coerce R.induceJust

-- | The set of /neighbours/ of an element @x@ is the set of elements that are
-- related to it, i.e. @neighbours x == { a | aRx }@. In the context of undirected
-- graphs, this corresponds to the set of /adjacent/ vertices of vertex @x@.
Expand Down
7 changes: 7 additions & 0 deletions test/Algebra/Graph/Test/API.hs
Original file line number Diff line number Diff line change
Expand Up @@ -129,6 +129,7 @@ data API g c where
, gmap :: forall a b. (c a, c b) => (a -> b) -> g a -> g b
, bind :: forall a b. (c a, c b) => g a -> (a -> g b) -> g b
, induce :: forall a. c a => (a -> Bool) -> g a -> g a
, induceJust :: forall a. c a => g (Maybe a) -> g a
, simplify :: forall a. c a => g a -> g a
, compose :: forall a. c a => g a -> g a -> g a
, box :: forall a b. (c a, c b) => g a -> g b -> g (a, b)
Expand Down Expand Up @@ -202,6 +203,7 @@ adjacencyMapAPI = API
, transpose = AM.transpose
, gmap = AM.gmap
, induce = AM.induce
, induceJust = AM.induceJust
, compose = AM.compose
, box = AM.box
, closure = AM.closure
Expand Down Expand Up @@ -279,6 +281,7 @@ graphAPI = API
, gmap = fmap
, bind = (>>=)
, induce = G.induce
, induceJust = G.induceJust
, simplify = G.simplify
, compose = G.compose
, box = G.box }
Expand Down Expand Up @@ -415,6 +418,7 @@ relationAPI = API
, transpose = R.transpose
, gmap = R.gmap
, induce = R.induce
, induceJust = R.induceJust
, compose = R.compose
, closure = R.closure
, reflexiveClosure = R.reflexiveClosure
Expand Down Expand Up @@ -485,6 +489,7 @@ symmetricRelationAPI = API
, transpose = id
, gmap = SR.gmap
, induce = SR.induce
, induceJust = SR.induceJust
, consistent = SR.consistent }

-- | The API of 'LG.Graph'.
Expand Down Expand Up @@ -539,6 +544,7 @@ labelledGraphAPI = API
, transpose = LG.transpose
, gmap = fmap
, induce = LG.induce
, induceJust = LG.induceJust
, closure = LG.closure
, reflexiveClosure = LG.reflexiveClosure
, symmetricClosure = LG.symmetricClosure
Expand Down Expand Up @@ -596,6 +602,7 @@ labelledAdjacencyMapAPI = API
, transpose = LAM.transpose
, gmap = LAM.gmap
, induce = LAM.induce
, induceJust = LAM.induceJust
, closure = LAM.closure
, reflexiveClosure = LAM.reflexiveClosure
, symmetricClosure = LAM.symmetricClosure
Expand Down
1 change: 1 addition & 0 deletions test/Algebra/Graph/Test/AdjacencyMap.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,6 +55,7 @@ testAdjacencyMap = do
testIsAcyclic t
testIsDfsForestOf t
testIsTopSortOf t
testInduceJust tPoly

putStrLn "\n============ AdjacencyMap.scc ============"
test "scc empty == empty" $
Expand Down
10 changes: 10 additions & 0 deletions test/Algebra/Graph/Test/Generic.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1515,6 +1515,16 @@ testInduce (prefix, API{..}) = do
test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x ->
isSubgraphOf (induce p x) x == True

testInduceJust :: Testsuite g Ord -> IO ()
snowleopard marked this conversation as resolved.
Show resolved Hide resolved
testInduceJust (prefix, API{..}) = do
putStrLn $ "\n============ " ++ prefix ++ "induceJust ============"
test "induceJust (vertex Nothing) == empty" $
induceJust (vertex (Nothing :: Maybe Int)) == empty
test "induceJust (gmap Just x) == x" $ \(x :: g Int) ->
induceJust (gmap Just x) == x
test "induceJust (gmap Just x) == x" $ \(x :: g Int) ->
induceJust (connect (gmap Just x) (vertex Nothing)) == x

testCompose :: TestsuiteInt g -> IO ()
testCompose (prefix, API{..}) = do
putStrLn $ "\n============ " ++ prefix ++ "compose ============"
Expand Down
1 change: 1 addition & 0 deletions test/Algebra/Graph/Test/Graph.hs
Original file line number Diff line number Diff line change
Expand Up @@ -44,6 +44,7 @@ testGraph = do
testSize t
testGraphFamilies t
testTransformations t
testInduceJust tPoly

----------------------------------------------------------------
-- Generic relational composition tests, plus an additional one
Expand Down
1 change: 1 addition & 0 deletions test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs
Original file line number Diff line number Diff line change
Expand Up @@ -406,6 +406,7 @@ testLabelledAdjacencyMap = do
in (emap g . emap h) x == (emap (g . h) x :: LAS)

testInduce t
testInduceJust tPoly

putStrLn "\n============ Labelled.AdjacencyMap.closure ============"
test "closure empty == empty" $
Expand Down
3 changes: 2 additions & 1 deletion test/Algebra/Graph/Test/Labelled/Graph.hs
Original file line number Diff line number Diff line change
Expand Up @@ -380,7 +380,8 @@ testLabelledGraph = do
g = (l*)
in (emap g . emap h) x == (emap (g . h) x :: LAS)

testInduce t
testInduce t
testInduceJust tPoly

putStrLn "\n============ Labelled.Graph.closure ============"
test "closure empty == empty" $
Expand Down
Loading