Graph.hs revision e9458b1a7a19a63aa4c179f9ab20f4d50681c168
{-# LANGUAGE DeriveDataTypeable #-}
{- |
Module : ./Common/Lib/Graph.hs
Description : Tree-based implementation of 'Graph' and 'DynGraph'
using Data.Map
Copyright : (c) Martin Erwig, Christian Maeder and Uni Bremen 1999-2006
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Christian.Maeder@dfki.de
Stability : provisional
Portability : portable
Tree-based implementation of 'Graph' and 'DynGraph' using Data.IntMap
instead of Data.Graph.Inductive.Internal.FiniteMap
-}
module Common.Lib.Graph
( Gr (..)
, GrContext (..)
, unsafeConstructGr
, decomposeGr
, getPaths
, getAllPathsTo
, getPathsTo
, getLEdges
, insLEdge
, delLNode
, labelNode
, getNewNode
, rmIsolated
) where
import Data.Graph.Inductive.Graph as Graph
import Data.Data
import Data.List
import qualified Data.IntMap as Map
-- | the graph type constructor
newtype Gr a b = Gr { convertToMap :: Map.IntMap (GrContext a b) }
deriving (Typeable, Data)
data GrContext a b = GrContext
{ nodeLabel :: a
, nodeSuccs :: Map.IntMap [b]
, loops :: [b]
, nodePreds :: Map.IntMap [b] }
deriving (Typeable, Data)
unsafeConstructGr :: Map.IntMap (GrContext a b) -> Gr a b
unsafeConstructGr = Gr
instance (Show a, Show b) => Show (Gr a b) where
show (Gr g) = showGraph g
instance Graph Gr where
empty = Gr Map.empty
isEmpty (Gr g) = Map.null g
match = matchGr
mkGraph vs es = (insEdges es . insNodes vs) empty
labNodes = map (\ (v, c) -> (v, nodeLabel c)) . Map.toList . convertToMap
-- more efficient versions of derived class members
matchAny g = case Map.keys $ convertToMap g of
[] -> error "Match Exception, Empty Graph"
h : _ -> let (Just c, g') = matchGr h g in (c, g')
noNodes (Gr g) = Map.size g
nodeRange (Gr g) = case Map.keys g of
[] -> (0, -1)
ks@(h : _) -> (h, last ks)
labEdges =
concatMap (\ (v, cw) -> map (\ (l, w) -> (v, w, l))
$ mkLoops v (loops cw) ++ mkAdj (nodeSuccs cw))
. Map.toList . convertToMap
instance DynGraph Gr where
(p, v, l, s) & gr = let
mkMap = foldr (\ (e, w) -> Map.insertWith (++) w [e]) Map.empty
pm = mkMap p
sm = mkMap s
in composeGr v GrContext
{ nodeLabel = l
, nodeSuccs = Map.delete v sm
, loops = Map.findWithDefault [] v pm ++ Map.findWithDefault [] v sm
, nodePreds = Map.delete v pm } gr
showGraph :: (Show a, Show b) => Map.IntMap (GrContext a b) -> String
showGraph = unlines . map
(\ (v, c) ->
shows v ": " ++ show (nodeLabel c)
++ showLinks
((case loops c of
[] -> []
l -> [(v, l)]) ++ Map.toList (nodeSuccs c)))
showLinks :: Show b => [(Node, [b])] -> String
showLinks = concatMap $ \ (v, l) -> " - " ++
intercalate ", " (map show l) ++ " -> " ++ shows v ";"
mkLoops :: Node -> [b] -> Adj b
mkLoops v = map (\ e -> (e, v))
mkAdj :: Map.IntMap [b] -> Adj b
mkAdj = concatMap (\ (w, l) -> map (\ e -> (e, w)) l) . Map.toList
{- here cyclic edges are omitted as predecessors, thus they only count
as outgoing and not as ingoing! Therefore it is enough that only
successors are filtered during deletions. -}
matchGr :: Node -> Gr a b -> Decomp Gr a b
matchGr v gr = case decomposeGr v gr of
Nothing -> (Nothing, gr)
Just (c, rg) -> (Just ( mkAdj $ nodePreds c , v , nodeLabel c
, mkLoops v (loops c) ++ mkAdj (nodeSuccs c)), rg)
decomposeGr :: Node -> Gr a b -> Maybe (GrContext a b, Gr a b)
decomposeGr v (Gr g) = case Map.lookup v g of
Nothing -> Nothing
Just c -> let
g1 = Map.delete v g
g2 = updAdj g1 (nodeSuccs c) $ clearPred v
g3 = updAdj g2 (nodePreds c) $ clearSucc v
in Just (c, Gr g3)
addSuccs :: Node -> [b] -> GrContext a b -> GrContext a b
addSuccs v ls c = c { nodeSuccs = Map.insert v ls $ nodeSuccs c }
addPreds :: Node -> [b] -> GrContext a b -> GrContext a b
addPreds v ls c = c { nodePreds = Map.insert v ls $ nodePreds c }
clearSucc :: Node -> [b] -> GrContext a b -> GrContext a b
clearSucc v _ c = c { nodeSuccs = Map.delete v $ nodeSuccs c }
clearPred :: Node -> [b] -> GrContext a b -> GrContext a b
clearPred v _ c = c { nodePreds = Map.delete v $ nodePreds c }
updAdj :: Map.IntMap (GrContext a b) -> Map.IntMap [b]
-> ([b] -> GrContext a b -> GrContext a b)
-> Map.IntMap (GrContext a b)
updAdj g m f = Map.foldWithKey (\ v -> updGrContext v . f) g m
updGrContext :: Node -> (GrContext a b -> GrContext a b)
-> Map.IntMap (GrContext a b) -> Map.IntMap (GrContext a b)
updGrContext v f r = case Map.lookup v r of
Nothing -> error $ "Common.Lib.Graph.updGrContext no node: " ++ show v
Just c -> Map.insert v (f c) r
composeGr :: Node -> GrContext a b -> Gr a b -> Gr a b
composeGr v c (Gr g) = let
g1 = updAdj g (nodePreds c) $ addSuccs v
g2 = updAdj g1 (nodeSuccs c) $ addPreds v
g3 = Map.insert v c g2
in if Map.member v g
then error $ "Common.Lib.Graph.composeGr no node: " ++ show v
else Gr g3
-- | compute the possible cycle free paths from a start node
getPaths :: Node -> Gr a b -> [[LEdge b]]
getPaths src gr = case decomposeGr src gr of
Just (c, ng) ->
Map.foldWithKey (\ nxt lbls l ->
l ++ map (\ b -> [(src, nxt, b)]) lbls
++ concatMap (\ p -> map (\ b -> (src, nxt, b) : p) lbls)
(getPaths nxt ng)) [] $ nodeSuccs c
Nothing -> error $ "Common.Lib.Graph.getPaths no node: " ++ show src
-- | compute the possible cycle free reversed paths from a start node
getAllPathsTo :: Node -> Gr a b -> [[LEdge b]]
getAllPathsTo tgt gr = case decomposeGr tgt gr of
Just (c, ng) ->
Map.foldWithKey (\ nxt lbls l ->
l ++ map (\ b -> [(nxt, tgt, b)]) lbls
++ concatMap (\ p -> map (\ b -> (nxt, tgt, b) : p) lbls)
(getAllPathsTo nxt ng)) [] $ nodePreds c
Nothing -> error $ "Common.Lib.Graph.getAllPathsTo no node: " ++ show tgt
-- | compute the possible cycle free paths from a start node to a target node.
getPathsTo :: Node -> Node -> Gr a b -> [[LEdge b]]
getPathsTo src tgt gr = case decomposeGr src gr of
Just (c, ng) -> let
s = nodeSuccs c
in Map.foldWithKey (\ nxt lbls ->
(++ concatMap (\ p -> map (\ b -> (src, nxt, b) : p) lbls)
(getPathsTo nxt tgt ng)))
(map (\ lbl -> [(src, tgt, lbl)]) $ Map.findWithDefault [] tgt s)
(Map.delete tgt s)
Nothing -> error $ "Common.Lib.Graph.getPathsTo no node: " ++ show src
-- | get all the edge labels between two nodes
getLEdges :: Node -> Node -> Gr a b -> [b]
getLEdges v w (Gr m) = let err = "Common.Lib.Graph.getLEdges: no node " in
case Map.lookup v m of
Just c -> if v == w then loops c else
(if Map.member w m then [] else error $ err ++ show w)
w $ nodeSuccs c
Nothing -> error $ err ++ show v
showEdge :: Node -> Node -> String
showEdge v w = show v ++ " -> " ++ show w
-- | delete a labeled edge from a graph
delLEdge :: (b -> b -> Ordering) -> LEdge b -> Gr a b -> Gr a b
delLEdge cmp (v, w, l) (Gr m) =
let e = showEdge v w
err = "Common.Lib.Graph.delLEdge "
in case Map.lookup v m of
Just c -> let
sm = nodeSuccs c
b = v == w
ls = if b then loops c else Map.findWithDefault [] w sm
in case partition (\ k -> cmp k l == EQ) ls of
([], _) -> error $ err ++ "no edge: " ++ e
([_], rs) -> Gr $ if b then Map.insert v c { loops = rs } m else
updGrContext w
((if null rs then clearPred else addPreds) v rs)
$ Map.insert v c
{ nodeSuccs = if null rs then Map.delete w sm else
Map.insert w rs sm } m
_ -> error $ err ++ "multiple edges: " ++ e
Nothing -> error $ err ++ "no node: " ++ show v ++ " for edge: " ++ e
-- | insert a labeled edge into a graph, returns False if edge exists
insLEdge :: Bool -> (b -> b -> Ordering) -> LEdge b -> Gr a b
-> (Gr a b, Bool)
insLEdge failIfExist cmp (v, w, l) gr@(Gr m) =
let e = showEdge v w
err = "Common.Lib.Graph.insLEdge "
in case Map.lookup v m of
Just c -> let
sm = nodeSuccs c
b = v == w
ls = if b then loops c else Map.findWithDefault [] w sm
ns = insertBy cmp l ls
in if any (\ k -> cmp k l == EQ) ls then
if failIfExist then error $ err ++ "multiple edges: " ++ e
else (gr, False)
else (Gr $ if b then Map.insert v c { loops = ns } m else
updGrContext w (addPreds v ns)
$ Map.insert v c { nodeSuccs = Map.insert w ns sm } m, True)
Nothing -> error $ err ++ "no node: " ++ show v ++ " for edge: " ++ e
isIsolated :: GrContext a b -> Bool
-- | delete a labeled node
delLNode :: (a -> a -> Bool) -> LNode a -> Gr a b -> Gr a b
delLNode eq (v, l) (Gr m) =
let err = "Common.Lib.Graph.delLNode: node " ++ show v in
case Map.lookup v m of
Just c -> if isIsolated c && null (loops c) then
if eq l $ nodeLabel c then Gr (Map.delete v m)
else error $ err ++ " has a different label"
else error $ err ++ " has remaining edges"
Nothing -> error $ err ++ " is missing"
-- | sets the node with new label and returns the new graph and the old label
labelNode :: LNode a -> Gr a b -> (Gr a b, a)
labelNode (v, l) (Gr m) = case Map.lookup v m of
Just c -> (Gr $ Map.insert v (c { nodeLabel = l }) m, nodeLabel c)
Nothing -> error $ "Common.Lib.Graph.labelNode no node: " ++ show v
-- | returns one new node id for the given graph
getNewNode :: Gr a b -> Node
getNewNode g = case newNodes 1 g of
[n] -> n
_ -> error "Common.Lib.Graph.getNewNode"
-- | remove isolated nodes without edges
rmIsolated :: Gr a b -> Gr a b
rmIsolated (Gr m) = Gr $ Map.filter (not . isIsolated) m