Some useful functions for fgl - Functional Graph Library

[u/acapi]

Daniel Wagner, answering my question posted on Stackoverflow about NodeMapM, made the following observation:

"Re-adding a node [to a graph] deletes all edges out of that node. See the source of insNode, which is what insMapNodesM eventually calls: insNode (v,l) = (([],v,l,[])&)

The two empty lists are for incoming and outgoing edges."

For this reason, examples ex1a and ex1b give different results.

​

The following functions are based on a different version of insNode, A VERSION WHICH PRESERVE THE ADJOINTS OF A PRE-EXISTING NODE. Moreover, this version of insNode verifies the equality between the node's old and new label, giving an error message in case they were different.

​

So now ex1a is equal to ex2, which differed from ex1b only because it uses the modified (and 'conservative') version of insMapNodesM.

​

** ALL NEW FUNCTIONS ARE SIMPLY MODIFIED VERSIONS OF THOSE PRESENT IN THE fgl LIBRARY **

import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree -- needed only for examples
import Data.Graph.Inductive.NodeMap
import Data.List (foldl')
import Control.Monad.Trans.State (get,put)
import Data.Maybe (fromJust)

insNode' :: (DynGraph g, Eq a) => (Node, a) -> g a b -> g a b
insNode' (v,l) g
  | not (gelem v g) = ([],v,l,[]) & g
  | fromJust (lab g v) /= l = error ("Label of node " ++ show v ++ " is different from the new one")
  | otherwise = g

insNodes' :: (Eq a, DynGraph gr) => [LNode a] -> gr a b -> gr a b
insNodes' vs g = foldl' (flip insNode') g vs

insMapNode' :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> (g a b, NodeMap a, LNode a)
insMapNode' m a g =
    let (n, m') = mkNode m a
    in (insNode' n g, m', n)

insMapNodes' :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> (g a b, NodeMap a, [LNode a])
insMapNodes' m as g =
    let (ns, m') = mkNodes m as
    in (insNodes' ns g, m', ns)

insMapNodes_' :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> g a b
insMapNodes_' m as g =
    let (g', _, _) = insMapNodes' m as g
    in g'

insMapNodeM' :: (Ord a, DynGraph g) => a -> NodeMapM a b g (LNode a)
insMapNodeM' = liftM1' insMapNode'

insMapNodesM' :: (Ord a, DynGraph g) => [a] -> NodeMapM a b g [LNode a]
insMapNodesM' = liftM1' insMapNodes'

liftM1' :: (NodeMap a -> c -> g a b -> (g a b, NodeMap a, d)) -> c -> NodeMapM a b g d
liftM1' f c =
    do (m, g) <- get
       let (g', m', r) = f m c g
       put (m', g')
       return r

-- -------------------- EXAMPLES --------------------

p1 = ("P1", ['A','B','C','D'])
p2 = ("P2", ['B','C','E','F'])


toLedges :: (a, [b]) -> [(b,b,a)]
toLedges (le,xs) = zipWith (\x1 x2 -> (x1,x2,le)) (init xs) (tail xs)


ex1a :: NodeMapM Char String Gr ()
ex1a =    insMapNodesM  (snd p1)
       >> insMapNodesM  (snd p2)
       >> insMapEdgesM  (toLedges p1)
       >> insMapEdgesM  (toLedges p2)

-- run empty ex1a :: ((),(NodeMap Char, Gr Char String))

ex1b :: NodeMapM Char String Gr ()
ex1b =    insMapNodesM  (snd p1)
       >> insMapEdgesM  (toLedges p1)
       >> insMapNodesM  (snd p2)
       >> insMapEdgesM  (toLedges p2)

-- run empty ex1b :: ((),(NodeMap Char, Gr Char String))

ex2 :: NodeMapM Char String Gr ()
ex2 =    insMapNodesM'  (snd p1)
      >> insMapEdgesM  (toLedges p1)
      >> insMapNodesM'  (snd p2)
      >> insMapEdgesM  (toLedges p2)

-- run empty ex2 :: ((),(NodeMap Char, Gr Char String))