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