1{-# LANGUAGE CPP #-} 2 3-- | Utility methods to automatically generate and keep track of a mapping 4-- between node labels and 'Node's. 5module Data.Graph.Inductive.NodeMap( 6 -- * Functional Construction 7 NodeMap, 8 -- ** Map Construction 9 new, fromGraph, mkNode, mkNode_, mkNodes, mkNodes_, mkEdge, mkEdges, 10 -- ** Graph Construction 11 -- | These functions mirror the construction and destruction functions in 12 -- 'Data.Graph.Inductive.Graph', but use the given 'NodeMap' to look up 13 -- the appropriate 'Node's. Note that the 'insMapNode' family of functions 14 -- will create new nodes as needed, but the other functions will not. 15 insMapNode, insMapNode_, insMapEdge, delMapNode, delMapEdge, insMapNodes, 16 insMapNodes_, insMapEdges, delMapNodes, delMapEdges, mkMapGraph, 17 -- * Monadic Construction 18 NodeMapM, 19 -- | The following mirror the functional construction functions, but handle passing 20 -- 'NodeMap's and 'Graph's behind the scenes. 21 22 -- ** Map Construction 23 run, run_, mkNodeM, mkNodesM, mkEdgeM, mkEdgesM, 24 -- ** Graph Construction 25 insMapNodeM, insMapEdgeM, delMapNodeM, delMapEdgeM, insMapNodesM, 26 insMapEdgesM, delMapNodesM, delMapEdgesM 27) where 28 29import Control.Monad.Trans.State 30import Data.Graph.Inductive.Graph 31import Prelude hiding (map) 32import qualified Prelude as P (map) 33 34import Data.Map (Map) 35import qualified Data.Map as M 36 37#if MIN_VERSION_containers (0,4,2) 38import Control.DeepSeq (NFData (..)) 39#endif 40 41data NodeMap a = 42 NodeMap { map :: Map a Node, 43 key :: Int } 44 deriving (Eq, Show, Read) 45 46#if MIN_VERSION_containers (0,4,2) 47instance (NFData a) => NFData (NodeMap a) where 48 rnf (NodeMap mp k) = rnf mp `seq` rnf k 49#endif 50 51-- | Create a new, empty mapping. 52new :: NodeMap a 53new = NodeMap { map = M.empty, key = 0 } 54 55-- LNode = (Node, a) 56 57-- | Generate a mapping containing the nodes in the given graph. 58fromGraph :: (Ord a, Graph g) => g a b -> NodeMap a 59fromGraph g = 60 let ns = labNodes g 61 aux (n, a) (m', k') = (M.insert a n m', max n k') 62 (m, k) = foldr aux (M.empty, 0) ns 63 in NodeMap { map = m, key = k+1 } 64 65-- | Generate a labelled node from the given label. Will return the same node 66-- for the same label. 67mkNode :: (Ord a) => NodeMap a -> a -> (LNode a, NodeMap a) 68mkNode m@(NodeMap mp k) a = 69 case M.lookup a mp of 70 Just i -> ((i, a), m) 71 Nothing -> 72 let m' = NodeMap { map = M.insert a k mp, key = k+1 } 73 in ((k, a), m') 74 75-- | Generate a labelled node and throw away the modified 'NodeMap'. 76mkNode_ :: (Ord a) => NodeMap a -> a -> LNode a 77mkNode_ m a = fst $ mkNode m a 78 79-- | Generate a 'LEdge' from the node labels. 80mkEdge :: (Ord a) => NodeMap a -> (a, a, b) -> Maybe (LEdge b) 81mkEdge (NodeMap m _) (a1, a2, b) = 82 do n1 <- M.lookup a1 m 83 n2 <- M.lookup a2 m 84 return (n1, n2, b) 85 86-- | Generates a list of 'LEdge's. 87mkEdges :: (Ord a) => NodeMap a -> [(a, a, b)] -> Maybe [LEdge b] 88mkEdges m = mapM (mkEdge m) 89 90-- | Construct a list of nodes. 91mkNodes :: (Ord a) => NodeMap a -> [a] -> ([LNode a], NodeMap a) 92mkNodes = map' mkNode 93 94map' :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a) 95map' _ a [] = ([], a) 96map' f a (b:bs) = 97 let (c, a') = f a b 98 (cs, a'') = map' f a' bs 99 in (c:cs, a'') 100 101-- | Construct a list of nodes and throw away the modified 'NodeMap'. 102mkNodes_ :: (Ord a) => NodeMap a -> [a] -> [LNode a] 103mkNodes_ m as = fst $ mkNodes m as 104 105insMapNode :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> (g a b, NodeMap a, LNode a) 106insMapNode m a g = 107 let (n, m') = mkNode m a 108 in (insNode n g, m', n) 109 110insMapNode_ :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> g a b 111insMapNode_ m a g = 112 let (g', _, _) = insMapNode m a g 113 in g' 114 115insMapEdge :: (Ord a, DynGraph g) => NodeMap a -> (a, a, b) -> g a b -> g a b 116insMapEdge m e g = 117 let (Just e') = mkEdge m e 118 in insEdge e' g 119 120delMapNode :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> g a b 121delMapNode m a g = 122 let (n, _) = mkNode_ m a 123 in delNode n g 124 125delMapEdge :: (Ord a, DynGraph g) => NodeMap a -> (a, a) -> g a b -> g a b 126delMapEdge m (n1, n2) g = 127 let Just (n1', n2', _) = mkEdge m (n1, n2, ()) 128 in delEdge (n1', n2') g 129 130insMapNodes :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> (g a b, NodeMap a, [LNode a]) 131insMapNodes m as g = 132 let (ns, m') = mkNodes m as 133 in (insNodes ns g, m', ns) 134 135insMapNodes_ :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> g a b 136insMapNodes_ m as g = 137 let (g', _, _) = insMapNodes m as g 138 in g' 139 140insMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a, b)] -> g a b -> g a b 141insMapEdges m es g = 142 let Just es' = mkEdges m es 143 in insEdges es' g 144 145delMapNodes :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> g a b 146delMapNodes m as g = 147 let ns = P.map fst $ mkNodes_ m as 148 in delNodes ns g 149 150delMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a)] -> g a b -> g a b 151delMapEdges m ns g = 152 let Just ns' = mkEdges m $ P.map (\(a, b) -> (a, b, ())) ns 153 ns'' = P.map (\(a, b, _) -> (a, b)) ns' 154 in delEdges ns'' g 155 156mkMapGraph :: (Ord a, DynGraph g) => [a] -> [(a, a, b)] -> (g a b, NodeMap a) 157mkMapGraph ns es = 158 let (ns', m') = mkNodes new ns 159 Just es' = mkEdges m' es 160 in (mkGraph ns' es', m') 161 162-- | Graph construction monad; handles passing both the 'NodeMap' and the 163-- 'Graph'. 164type NodeMapM a b g r = State (NodeMap a, g a b) r 165 166-- | Run a construction; return the value of the computation, the modified 167-- 'NodeMap', and the modified 'Graph'. 168run :: (DynGraph g, Ord a) => g a b -> NodeMapM a b g r -> (r, (NodeMap a, g a b)) 169run g m = runState m (fromGraph g, g) 170 171-- | Run a construction and only return the 'Graph'. 172run_ :: (DynGraph g, Ord a) => g a b -> NodeMapM a b g r -> g a b 173run_ g m = snd . snd $ run g m 174 175{- not used 176liftN1 :: (Ord a, DynGraph g) => (NodeMap a -> (c, NodeMap a)) -> NodeMapM a b g c 177liftN1 f = 178 do (m, g) <- get 179 let (r, m') = f m 180 put (m', g) 181 return r 182 183liftN1' :: (Ord a, DynGraph g) => (NodeMap a -> c) -> NodeMapM a b g c 184liftN1' f = 185 do (m, g) <- get 186 return $ f m 187-} 188liftN2 :: (NodeMap a -> c -> (d, NodeMap a)) -> c -> NodeMapM a b g d 189liftN2 f c = 190 do (m, g) <- get 191 let (r, m') = f m c 192 put (m', g) 193 return r 194 195liftN2' :: (NodeMap a -> c -> d) -> c -> NodeMapM a b g d 196liftN2' f c = 197 do (m, _) <- get 198 return $ f m c 199{- not used 200liftN3 :: (Ord a, DynGraph g) => (NodeMap a -> c -> d -> (e, NodeMap a)) -> c -> d -> NodeMapM a b g e 201liftN3 f c d = 202 do (m, g) <- get 203 let (r, m') = f m c d 204 put (m', g) 205 return r 206 207liftN3' :: (Ord a, DynGraph g) => (NodeMap a -> c -> d -> e) -> c -> d -> NodeMapM a b g e 208liftN3' f c d = 209 do (m, g) <- get 210 return $ f m c d 211-} 212liftM1 :: (NodeMap a -> c -> g a b -> g a b) -> c -> NodeMapM a b g () 213liftM1 f c = 214 do (m, g) <- get 215 let g' = f m c g 216 put (m, g') 217 218liftM1' :: (NodeMap a -> c -> g a b -> (g a b, NodeMap a, d)) -> c -> NodeMapM a b g d 219liftM1' f c = 220 do (m, g) <- get 221 let (g', m', r) = f m c g 222 put (m', g') 223 return r 224 225-- | Monadic node construction. 226mkNodeM :: (Ord a) => a -> NodeMapM a b g (LNode a) 227mkNodeM = liftN2 mkNode 228 229mkNodesM :: (Ord a) => [a] -> NodeMapM a b g [LNode a] 230mkNodesM = liftN2 mkNodes 231 232mkEdgeM :: (Ord a) => (a, a, b) -> NodeMapM a b g (Maybe (LEdge b)) 233mkEdgeM = liftN2' mkEdge 234 235mkEdgesM :: (Ord a) => [(a, a, b)] -> NodeMapM a b g (Maybe [LEdge b]) 236mkEdgesM = liftN2' mkEdges 237 238insMapNodeM :: (Ord a, DynGraph g) => a -> NodeMapM a b g (LNode a) 239insMapNodeM = liftM1' insMapNode 240 241insMapEdgeM :: (Ord a, DynGraph g) => (a, a, b) -> NodeMapM a b g () 242insMapEdgeM = liftM1 insMapEdge 243 244delMapNodeM :: (Ord a, DynGraph g) => a -> NodeMapM a b g () 245delMapNodeM = liftM1 delMapNode 246 247delMapEdgeM :: (Ord a, DynGraph g) => (a, a) -> NodeMapM a b g () 248delMapEdgeM = liftM1 delMapEdge 249 250insMapNodesM :: (Ord a, DynGraph g) => [a] -> NodeMapM a b g [LNode a] 251insMapNodesM = liftM1' insMapNodes 252 253insMapEdgesM :: (Ord a, DynGraph g) => [(a, a, b)] -> NodeMapM a b g () 254insMapEdgesM = liftM1 insMapEdges 255 256delMapNodesM :: (Ord a, DynGraph g) => [a] -> NodeMapM a b g () 257delMapNodesM = liftM1 delMapNodes 258 259delMapEdgesM :: (Ord a, DynGraph g) => [(a, a)] -> NodeMapM a b g () 260delMapEdgesM = liftM1 delMapEdges 261