content: {-# 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
    , Common.Lib.Graph.delLEdge
    , 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)))
    . Map.toList
  
  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.foldrWithKey (\ 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.foldrWithKey (\ 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.foldrWithKey (\ 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.foldrWithKey (\ 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
        Map.findWithDefault
          (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
  isIsolated c = Map.null (nodeSuccs c) && Map.null (nodePreds c)
  
  -- | 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
  