0N/A{- |

2203N/AModule : $Header$

1008N/ADescription : Tree-based implementation of 'Graph' and 'DynGraph' using Data.Map

1008N/ACopyright : (c) Martin Erwig, Christian Maeder and Uni Bremen 1999-2006

1008N/ALicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

1008N/A

1008N/AMaintainer : Christian.Maeder@dfki.de

1008N/AStability : provisional

1008N/APortability : portable

1008N/A

1008N/ATree-based implementation of 'Graph' and 'DynGraph' using Data.IntMap

1008N/Ainstead of Data.Graph.Inductive.Internal.FiniteMap

1008N/A-}

1008N/A

1008N/Amodule Common.Lib.Graph

1008N/A ( Gr

1008N/A , GrContext(..)

1008N/A , convertToMap

1008N/A , unsafeConstructGr

1008N/A , getPaths

1008N/A , getPathsTo

1008N/A , Common.Lib.Graph.delLEdge

1008N/A , insLEdge

1008N/A , delLNode

1008N/A , labelNode

1008N/A , getNewNode

1008N/A , rmIsolated

0N/A ) where

0N/A

1821N/Aimport Data.Graph.Inductive.Graph as Graph

1821N/Aimport qualified Data.IntMap as Map

1821N/Aimport Data.List

1821N/A

1821N/A-- | the graph type constructor

1821N/Anewtype Gr a b = Gr { convertToMap :: Map.IntMap (GrContext a b) }

1821N/A

1821N/Adata GrContext a b = GrContext

1821N/A { nodeLabel :: a

1821N/A , nodeSuccs :: Map.IntMap [b]

1821N/A , loops :: [b]

1821N/A , nodePreds :: Map.IntMap [b] }

1821N/A

1821N/AunsafeConstructGr :: Map.IntMap (GrContext a b) -> Gr a b

1821N/AunsafeConstructGr = Gr

1821N/A

1821N/Ainstance (Show a,Show b) => Show (Gr a b) where

1821N/A show (Gr g) = showGraph g

1821N/A

1821N/Ainstance Graph Gr where

1821N/A empty = Gr Map.empty

1821N/A isEmpty (Gr g) = Map.null g

1821N/A match = matchGr

1821N/A mkGraph vs es = (insEdges es . insNodes vs) empty

1821N/A labNodes = map (\ (v, c) -> (v, nodeLabel c)) . Map.toList . convertToMap

1821N/A -- more efficient versions of derived class members

1821N/A --

1008N/A matchAny g = case Map.keys $ convertToMap g of

1008N/A [] -> error "Match Exception, Empty Graph"

1821N/A h : _ -> let (Just c, g') = matchGr h g in (c, g')

1008N/A noNodes (Gr g) = Map.size g

1008N/A nodeRange (Gr g) = case Map.keys g of

1008N/A [] -> (0, -1)

1008N/A ks@(h : _) -> (h, last ks)

1008N/A labEdges =

1821N/A concatMap (\ (v, cw) -> map (\ (l, w) -> (v, w, l))

1821N/A $ mkLoops v (loops cw) ++ mkAdj (nodeSuccs cw))

1821N/A . Map.toList . convertToMap

1821N/A

1821N/Ainstance DynGraph Gr where

1821N/A (p, v, l, s) & gr = let

1821N/A mkMap = foldr (\ (e, w) -> Map.insertWith (++) w [e]) Map.empty

1821N/A pm = mkMap p

1821N/A sm = mkMap s

0N/A in composeGr v GrContext

1821N/A { nodeLabel = l

1821N/A , nodeSuccs = Map.delete v sm

1821N/A , loops = Map.findWithDefault [] v pm ++ Map.findWithDefault [] v sm

1821N/A , nodePreds = Map.delete v pm } gr

1821N/A

1821N/AshowGraph :: (Show a, Show b) => Map.IntMap (GrContext a b) -> String

1821N/AshowGraph gr = unlines $ map

1821N/A (\ (v, c) ->

1821N/A shows v ": " ++ show (nodeLabel c)

1821N/A ++ showLinks

1821N/A ((case loops c of

1821N/A [] -> []

1821N/A l -> [(v, l)]) ++ Map.toList (nodeSuccs c)))

1821N/A $ Map.toList gr

1821N/A

0N/AshowLinks :: Show b => [(Node, [b])] -> String

0N/AshowLinks = concatMap $ \ (v, l) -> " - " ++

1008N/A concat (intersperse ", " $ map show l) ++ " -> " ++ shows v ";"

1821N/A

1821N/AmkLoops :: Node -> [b] -> Adj b

1821N/AmkLoops v = map (\ e -> (e, v))

1821N/A

1821N/AmkAdj :: Map.IntMap [b] -> Adj b

1821N/AmkAdj = concatMap (\ (w, l) -> map (\ e -> (e, w)) l) . Map.toList

1821N/A

1821N/A{- here cyclic edges are omitted as predecessors, thus they only count

1821N/Aas outgoing and not as ingoing! Therefore it is enough that only

1821N/Asuccessors are filtered during deletions. -}

1821N/AmatchGr :: Node -> Gr a b -> Decomp Gr a b

1821N/AmatchGr v gr = case decomposeGr v gr of

1821N/A Nothing -> (Nothing, gr)

1821N/A Just (c, rg) -> (Just ( mkAdj $ nodePreds c , v , nodeLabel c

1821N/A , mkLoops v (loops c) ++ mkAdj (nodeSuccs c)), rg)

1821N/A

1821N/AdecomposeGr :: Node -> Gr a b -> Maybe (GrContext a b, Gr a b)

1821N/AdecomposeGr v (Gr g) = case Map.lookup v g of

1821N/A Nothing -> Nothing

1821N/A Just c -> let

1821N/A g1 = Map.delete v g

1821N/A g2 = updAdj g1 (nodeSuccs c) $ clearPred v

1821N/A g3 = updAdj g2 (nodePreds c) $ clearSucc v

1821N/A in Just (c, Gr g3)

1821N/A

1821N/AaddSuccs :: Node -> [b] -> GrContext a b -> GrContext a b

1821N/AaddSuccs v ls c = c { nodeSuccs = Map.insert v ls $ nodeSuccs c }

1821N/A

1821N/AaddPreds :: Node -> [b] -> GrContext a b -> GrContext a b

1821N/AaddPreds v ls c = c { nodePreds = Map.insert v ls $ nodePreds c }

1821N/A

1821N/AclearSucc :: Node -> [b] -> GrContext a b -> GrContext a b

1821N/AclearSucc v _ c = c { nodeSuccs = Map.delete v $ nodeSuccs c }

1821N/A

1821N/AclearPred :: Node -> [b] -> GrContext a b -> GrContext a b

1821N/AclearPred v _ c = c { nodePreds = Map.delete v $ nodePreds c }

1821N/A

1821N/AupdAdj :: Map.IntMap (GrContext a b) -> Map.IntMap [b]

1821N/A -> ([b] -> GrContext a b -> GrContext a b) -> Map.IntMap (GrContext a b)

1821N/AupdAdj g m f = Map.foldWithKey (\ v -> updGrContext v . f) g m

1821N/A

1821N/AupdGrContext :: Node -> (GrContext a b -> GrContext a b)

1821N/A -> Map.IntMap (GrContext a b) -> Map.IntMap (GrContext a b)

1821N/AupdGrContext v f r = case Map.lookup v r of

1821N/A Nothing -> error $ "Common.Lib.Graph.updGrContext no node: " ++ show v

1821N/A Just c -> Map.insert v (f c) r

1821N/A

1821N/AcomposeGr :: Node -> GrContext a b -> Gr a b -> Gr a b

1821N/AcomposeGr v c (Gr g) = let

1821N/A g1 = updAdj g (nodePreds c) $ addSuccs v

0N/A g2 = updAdj g1 (nodeSuccs c) $ addPreds v

1821N/A g3 = Map.insert v c g2

1008N/A in if Map.member v g

0N/A then error $ "Common.Lib.Graph.composeGr no node: " ++ show v

0N/A else Gr g3

0N/A

1821N/A{- | compute the possible cycle free paths from a start node -}

0N/AgetPaths :: Node -> Gr a b -> [[LEdge b]]

1008N/AgetPaths src gr = case decomposeGr src gr of

1008N/A Just (c, ng) ->

1008N/A Map.foldWithKey (\ nxt lbls l ->

1008N/A l ++ map (\ b -> [(src, nxt, b)]) lbls

1821N/A ++ concatMap (\ p -> map (\ b -> (src, nxt, b) : p) lbls)

1008N/A (getPaths nxt ng)) [] $ nodeSuccs c

1008N/A Nothing -> error $ "Common.Lib.Graph.getPaths no node: " ++ show src

1821N/A

0N/A-- | compute the possible cycle free paths from a start node to a target node.

1008N/AgetPathsTo :: Node -> Node -> Gr a b -> [[LEdge b]]

1008N/AgetPathsTo src tgt gr = case decomposeGr src gr of

1008N/A Just (c, ng) -> let

1008N/A s = nodeSuccs c

1008N/A in Map.foldWithKey (\ nxt lbls ->

1008N/A (++ concatMap (\ p -> map (\ b -> (src, nxt, b) : p) lbls)

1008N/A (getPathsTo nxt tgt ng)))

1008N/A (map (\ lbl -> [(src, tgt, lbl)]) $ Map.findWithDefault [] tgt s)

1008N/A (Map.delete tgt s)

1821N/A Nothing -> error $ "Common.Lib.Graph.getPathsTo no node: " ++ show src

1008N/A

1008N/A-- | delete a labeled edge from a graph

1008N/AdelLEdge :: (b -> b -> Ordering) -> LEdge b -> Gr a b -> Gr a b

1008N/AdelLEdge cmp (v, w, l) (Gr m) = let e = show (v, w) in case Map.lookup v m of

1008N/A Just c -> let

1008N/A sm = nodeSuccs c

1821N/A b = v == w

1008N/A ls = if b then loops c else Map.findWithDefault [] w sm

1008N/A in case partition (\ k -> cmp k l == EQ) ls of

0N/A ([], _) ->

0N/A error $ "Common.Lib.Graph.delLEdge no edge: " ++ e

1008N/A ([_], rs) -> if b then Gr $ Map.insert v c { loops = rs } m else

1008N/A Gr $ updGrContext w

1008N/A ((if null rs then clearPred else addPreds) v rs)

1008N/A $ Map.insert v c

1008N/A { nodeSuccs = if null rs then Map.delete w sm else

0N/A Map.insert w rs sm } m

1821N/A _ ->

1821N/A error $ "Common.Lib.Graph.delLEdge multiple edges: " ++ e

1821N/A Nothing -> error $ "Common.Lib.Graph.delLEdge no node: "

1821N/A ++ show v ++ " for edge: " ++ e

1821N/A

1821N/A-- | insert a labeled edge into a graph, returns False if edge exists

1821N/AinsLEdge :: Bool -> (b -> b -> Ordering) -> LEdge b -> Gr a b -> (Gr a b, Bool)

1821N/AinsLEdge failIfExist cmp (v, w, l) gr@(Gr m) =

1821N/A let e = show (v, w) in case Map.lookup v m of

1821N/A Just c -> let

1821N/A sm = nodeSuccs c

1821N/A b = v == w

1821N/A ls = if b then loops c else Map.findWithDefault [] w sm

1821N/A ns = insertBy cmp l ls

1821N/A in if any (\ k -> cmp k l == EQ) ls then

1008N/A if failIfExist then

1008N/A error $ "Common.Lib.Graph.insLEdge multiple edges: " ++ e

1008N/A else (gr, False)

1008N/A else (if b then Gr $ Map.insert v c { loops = ns } m else

1008N/A Gr $ updGrContext w (addPreds v ns)

0N/A $ Map.insert v c { nodeSuccs = Map.insert w ns sm } m, True)

1008N/A Nothing -> error $ "Common.Lib.Graph.insLEdge no node: "

1008N/A ++ show v ++ " for edge: " ++ e

1008N/A

1008N/AisIsolated :: GrContext a b -> Bool

1008N/AisIsolated c = Map.null (nodeSuccs c) && Map.null (nodePreds c)

1821N/A

1821N/A-- | delete a labeled node

1821N/AdelLNode :: (a -> a -> Bool) -> LNode a -> Gr a b -> Gr a b

1821N/AdelLNode eq (v, l) (Gr m) =

1821N/A let err = "Common.Lib.Graph.delLNode: node " ++ show v in

1821N/A case Map.lookup v m of

1947N/A Just c -> if isIsolated c && null (loops c) then

1947N/A if eq l $ nodeLabel c then Gr (Map.delete v m)

1947N/A else error $ err ++ " has a different label"

1947N/A else error $ err ++ " has remaining edges"

1947N/A Nothing -> error $ err ++ " is missing"

1947N/A

1947N/A-- | sets the node with new label and returns the new graph and the old label

1947N/AlabelNode :: LNode a -> Gr a b -> (Gr a b, a)

1947N/AlabelNode (v, l) (Gr m) = case Map.lookup v m of

2017N/A Just c -> (Gr $ Map.insert v (c { nodeLabel = l }) m, nodeLabel c)

1947N/A Nothing -> error $ "Common.Lib.Graph.labelNode no node: " ++ show v

1821N/A

1821N/A-- | returns one new node id for the given graph

1947N/AgetNewNode :: Gr a b -> Node

1821N/AgetNewNode g = case newNodes 1 g of

1947N/A [n] -> n

1947N/A _ -> error "Common.Lib.Graph.getNewNode"

1821N/A

2017N/A-- | remove isolated nodes without edges

1821N/ArmIsolated :: Gr a b -> Gr a b

1821N/ArmIsolated (Gr m) = Gr $ Map.filter (not . isIsolated) m

1821N/A