Graph.hs revision ff388e0ef7318a4126edf29cc8c977296de2cc48
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterModule : $Header$
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterDescription : Tree-based implementation of 'Graph' and 'DynGraph' using Data.Map
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterCopyright : (c) Martin Erwig, Christian Maeder and Uni Bremen 1999-2006
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterMaintainer : Christian.Maeder@dfki.de
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterStability : provisional
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterPortability : portable
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterTree-based implementation of 'Graph' and 'DynGraph' using Data.IntMap
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterinstead of Data.Graph.Inductive.Internal.FiniteMap
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , GrContext(..)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , convertToMap
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , unsafeConstructGr
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , getPathsTo
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , rmIsolated
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterimport qualified Data.IntMap as Map
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | the graph type constructor
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosternewtype Gr a b = Gr { convertToMap :: Map.IntMap (GrContext a b) }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterdata GrContext a b = GrContext
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster { nodeLabel :: a
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , nodeSuccs :: Map.IntMap [b]
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , loops :: [b]
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , nodePreds :: Map.IntMap [b] }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterunsafeConstructGr :: Map.IntMap (GrContext a b) -> Gr a b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterunsafeConstructGr = Gr
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterinstance (Show a,Show b) => Show (Gr a b) where
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster show (Gr g) = showGraph g
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterinstance Graph Gr where
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster isEmpty (Gr g) = Map.null g
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster match = matchGr
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster mkGraph vs es = (insEdges es . insNodes vs) empty
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster labNodes = map (\ (v, c) -> (v, nodeLabel c)) . Map.toList . convertToMap
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster -- more efficient versions of derived class members
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster matchAny g = case Map.keys $ convertToMap g of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster [] -> error "Match Exception, Empty Graph"
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster h : _ -> let (Just c, g') = matchGr h g in (c, g')
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster noNodes (Gr g) = Map.size g
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster nodeRange (Gr g) = case Map.keys g of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster [] -> (0, -1)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster ks@(h : _) -> (h, last ks)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster concatMap (\ (v, cw) -> map (\ (l, w) -> (v, w, l))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster $ mkLoops v (loops cw) ++ mkAdj (nodeSuccs cw))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster . Map.toList . convertToMap
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosterinstance DynGraph Gr where
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster (p, v, l, s) & Gr g = let
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster mkMap = Map.fromListWith (++) . map (\ (e, w) -> (w, [e]))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster pm = mkMap p
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster sm = mkMap s
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster g1 = updAdj g rpm $ addSuccs v
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster g2 = updAdj g1 rsm $ addPreds v
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster g3 = Map.insert v GrContext
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster { nodeLabel = l
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , nodeSuccs = rsm
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , loops = Map.findWithDefault [] v pm ++ Map.findWithDefault [] v sm
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster , nodePreds = rpm } g2
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster in if Map.member v g then error $ "Node Exception, Node: " ++ show v
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostershowGraph :: (Show a, Show b) => Map.IntMap (GrContext a b) -> String
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostershowGraph gr = unlines $ map
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster (\ (v, c) ->
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster shows v ": " ++ show (nodeLabel c)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster ++ showLinks
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster ((case loops c of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster l -> [(v, l)]) ++ Map.toList (nodeSuccs c)))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostershowLinks :: Show b => [(Node, [b])] -> String
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostershowLinks = concatMap $ \ (v, l) -> " - " ++
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster concat (intersperse ", " $ map show l) ++ " -> " ++ shows v ";"
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermkLoops :: Node -> [b] -> Adj b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermkLoops v = map (\ e -> (e, v))
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermkAdj :: Map.IntMap [b] -> Adj b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermkAdj = concatMap (\ (w, l) -> map (\ e -> (e, w)) l) . Map.toList
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster{- here cyclic edges are omitted as predecessors, thus they only count
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fosteras outgoing and not as ingoing! Therefore it is enough that only
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Fostersuccessors are filtered during deletions. -}
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermatchGr :: Node -> Gr a b -> Decomp Gr a b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostermatchGr v (Gr g) = case Map.lookup v g of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Nothing -> (Nothing, Gr g)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster Just c -> let
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster sm = nodeSuccs c
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster pm = nodePreds c
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster g2 = updAdj g1 sm $ clearPred v
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster g3 = updAdj g2 pm $ clearSucc v
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster in ( Just (mkAdj pm, v, nodeLabel c, mkLoops v (loops c) ++ mkAdj sm)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosteraddSuccs :: Node -> [b] -> GrContext a b -> GrContext a b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosteraddSuccs v ls c = c { nodeSuccs = Map.insert v ls $ nodeSuccs c }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosteraddPreds :: Node -> [b] -> GrContext a b -> GrContext a b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosteraddPreds v ls c = c { nodePreds = Map.insert v ls $ nodePreds c }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterclearSucc :: Node -> [b] -> GrContext a b -> GrContext a b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterclearSucc v _ c = c { nodeSuccs = Map.delete v $ nodeSuccs c }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterclearPred :: Node -> [b] -> GrContext a b -> GrContext a b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterclearPred v _ c = c { nodePreds = Map.delete v $ nodePreds c }
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterupdAdj :: Map.IntMap (GrContext a b) -> Map.IntMap [b]
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster -> ([b] -> GrContext a b -> GrContext a b) -> Map.IntMap (GrContext a b)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterupdAdj g m f = Map.foldWithKey (\ v ls ->
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster{- | compute the possible cycle free paths from a start node.
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster The result paths are given in reverse order! -}
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostergetPaths :: [LEdge b] -> Node -> Gr a b -> [[LEdge b]]
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostergetPaths path src gr = case matchGr src gr of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster (Just (_, _, _, s), ng) -> let
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster in concatMap (\ (lbl, tgt) -> let np = (src, tgt, lbl) : path in
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster np : getPaths np tgt ng) $ filter ((/= src) . snd) s
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster _ -> error "getPaths"
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | compute the possible cycle free paths from a start node to a target node.
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostergetPathsTo :: [LEdge b] -> Node -> Node -> Gr a b -> [[LEdge b]]
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FostergetPathsTo path src tgt gr = case matchGr tgt gr of
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster (Just (p, _, _, _), ng) -> let
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster (srcEdges, nxtEdges) = partition ((== src) . snd) p
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster in map (\ (lbl, nxt) -> (nxt, tgt, lbl) : path) srcEdges
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster ++ concatMap (\ (lbl, nxt) -> getPathsTo ((nxt, tgt, lbl) : path)
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster src nxt ng) nxtEdges
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster _ -> error "getPathsTo"
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster-- | remove isolated nodes without edges
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterrmIsolated :: Gr a b -> Gr a b
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan FosterrmIsolated (Gr m) = Gr $ Map.filter
a688bcbb4bcff5398fdd29b86f83450257dc0df4Allan Foster (\ c -> not $ Map.null (nodeSuccs c) && Map.null (nodePreds c)) m