Add induceJust (#209)

See #202.

AUTHORS.md

@@ -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

src/Algebra/Graph.hs

@@ -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,
@@ -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
@@ -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,

src/Algebra/Graph/AdjacencyMap.hs

@@ -38,7 +38,7 @@ module Algebra.Graph.AdjacencyMap (
 
     -- * Graph transformation
     removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,
-    induce,
+    induce, induceJust,
 
     -- * Graph composition
     compose, box,
@@ -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
@@ -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

src/Algebra/Graph/Labelled.hs

@@ -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,
@@ -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.
 --

src/Algebra/Graph/Labelled/AdjacencyMap.hs

@@ -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,
@@ -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.
 --

src/Algebra/Graph/NonEmpty.hs

@@ -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
@@ -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,

src/Algebra/Graph/NonEmpty/AdjacencyMap.hs

@@ -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,
@@ -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.
 --

src/Algebra/Graph/Relation.hs

@@ -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,
@@ -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
 
@@ -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

src/Algebra/Graph/Relation/Symmetric.hs

@@ -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
@@ -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@.

test/Algebra/Graph/Test/API.hs

@@ -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)
@@ -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
@@ -279,6 +281,7 @@ graphAPI = API
     , gmap                       = fmap
     , bind                       = (>>=)
     , induce                     = G.induce
+    , induceJust                 = G.induceJust
     , simplify                   = G.simplify
     , compose                    = G.compose
     , box                        = G.box }
@@ -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
@@ -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'.
@@ -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
@@ -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

test/Algebra/Graph/Test/AdjacencyMap.hs

@@ -55,6 +55,7 @@ testAdjacencyMap = do
     testIsAcyclic         t
     testIsDfsForestOf     t
     testIsTopSortOf       t
+    testInduceJust        tPoly
 
     putStrLn "\n============ AdjacencyMap.scc ============"
     test "scc empty               == empty" $

test/Algebra/Graph/Test/Generic.hs

@@ -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 ()
+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 ============"

test/Algebra/Graph/Test/Graph.hs

@@ -44,6 +44,7 @@ testGraph = do
     testSize            t
     testGraphFamilies   t
     testTransformations t
+    testInduceJust      tPoly
 
     ----------------------------------------------------------------
     -- Generic relational composition tests, plus an additional one

test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs

@@ -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" $

test/Algebra/Graph/Test/Labelled/Graph.hs

@@ -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" $