content: -- | Data.Graph is sorely lacking in several ways, This just tries to fill in
  -- some holes and provide a more convinient interface
  {-# LANGUAGE DoRec #-}
  
  module Util.Graph(
      Graph(),
      fromGraph,
      newGraph,
      newGraph',
      newGraphReachable,
      reachableFrom,
      Util.Graph.reachable,
      fromScc,
      findLoopBreakers,
      sccGroups,
      Util.Graph.scc,
      sccForest,
      Util.Graph.dff,
      Util.Graph.components,
      Util.Graph.topSort,
      cyclicNodes,
      toDag,
      restitchGraph,
      mapGraph,
      transitiveClosure,
      transitiveReduction
      ) where
  
  import Control.Monad
  import Control.Monad.ST
  import Data.Array.IArray
  import Data.Array.ST hiding(unsafeFreeze)
  import Data.Array.Unsafe (unsafeFreeze)
  import Data.Graph hiding(Graph)
  import Data.Maybe
  import GenUtil
  import Data.List(sort,sortBy,group,delete)
  import qualified Data.Graph as G
  import qualified Data.Map as Map
  
  
  data Graph n = Graph G.Graph (Table n)
  
  
  instance Show n => Show (Graph n) where
      showsPrec n g = showsPrec n (Util.Graph.scc g)
  
  fromGraph :: Graph n -> [(n,[n])]
  fromGraph (Graph g lv) = [ (lv!v,map (lv!) vs) | (v,vs) <- assocs g ]
  
  newGraph :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Graph n)
  newGraph ns a b = snd $ newGraph' ns a b
  
  newGraphReachable :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> ([k] -> [n],Graph n)
  newGraphReachable ns fn fd = (rable,ng) where
      (vmap,ng) = newGraph' ns fn fd
      rable ks = Util.Graph.reachable ng [ v | Just v <- map (flip Map.lookup vmap) ks ]
  
  reachableFrom :: Ord k => (n -> k) -> (n -> [k]) -> [n] -> [k] -> [n]
  reachableFrom fn fd ns  = fst $ newGraphReachable ns fn fd
  
  -- | Build a graph from a list of nodes uniquely identified by keys,
  -- with a list of keys of nodes this node should have edges to.
  -- The out-list may contain keys that don't correspond to
  -- nodes of the graph; they are ignored.
  newGraph' :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Map.Map k Vertex,Graph n)
  newGraph' ns fn fd = (kmap,Graph graph nr) where
      nr = listArray bounds0 ns
      max_v      	    = length ns - 1
      bounds0         = (0,max_v) :: (Vertex, Vertex)
      kmap = Map.fromList [ (fn n,i) | (i,n) <- zip [0 ..] ns ]
      graph	    = listArray bounds0 [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- ns]
  
  fromScc (Left n) = [n]
  fromScc (Right n) = n
  
  -- | determine a set of loopbreakers subject to a fitness function
  -- loopbreakers have a minimum of their  incoming edges ignored.
  findLoopBreakers
      :: (n -> Int)  -- ^ fitness function, greater numbers mean more likely to be a loopbreaker
      -> (n -> Bool) -- ^ whether a node is suitable at all for a choice as loopbreaker
      -> Graph n     -- ^ the graph
      ->  ([n],[n])  -- ^ (loop breakers,dependency ordered nodes after loopbreaking)
  findLoopBreakers func ex (Graph g ln) = ans where
      scc = G.scc g
      ans = f g scc [] [] where
          f g (Node v []:sccs) fs lb
              | v `elem` g ! v = let ng = (fmap (delete v) g) in  f ng (G.scc ng) [] (v:lb)
              | otherwise = f g sccs (v:fs) lb
  
          f g (n:_) fs lb = f ng (G.scc ng) [] (mv:lb) where
              mv = case  sortBy (\ a b -> compare (snd b) (snd a)) [ (v,func (ln!v)) | v <- ns, ex (ln!v) ] of
                  ((mv,_):_) -> mv
                  [] -> error "findLoopBreakers: no valid loopbreakers"
              ns = dec n []
              ng = fmap (delete mv) g
  
          f _ [] xs lb = (map ((ln!) . head) (group $ sort lb),reverse $ map (ln!) xs)
      dec (Node v ts) vs = v:foldr dec vs ts
  
  
  reachable :: Graph n -> [Vertex] -> [n]
  reachable (Graph g ln) vs = map (ln!) $ snub $  concatMap (G.reachable g) vs
  
  sccGroups :: Graph n -> [[n]]
  sccGroups g = map fromScc (Util.Graph.scc g)
  
  scc :: Graph n -> [Either n [n]]
  scc (Graph g ln) = map decode forest where
      forest = G.scc g
      decode (Node v [])
          | v `elem` g ! v = Right [ln!v]
          | otherwise = Left (ln!v)
      decode other = Right (dec other [])
      dec (Node v ts) vs = ln!v:foldr dec vs ts
  
  sccForest :: Graph n -> Forest n
  sccForest (Graph g ln) = map (fmap (ln!)) forest where
      forest = G.scc g
  
  dff :: Graph n -> Forest n
  dff (Graph g ln) = map (fmap (ln!)) forest where
      forest = G.dff g
  
  components :: Graph n -> [[n]]
  components (Graph g ln) = map decode forest where
      forest = G.components g
      decode n = dec n []
      dec (Node v ts) vs = ln!v:foldr dec vs ts
  
  
  topSort :: Graph n -> [n]
  topSort (Graph g ln) = map (ln!) $ G.topSort g
  
  cyclicNodes :: Graph n -> [n]
  cyclicNodes g = concat [ xs | Right xs <- Util.Graph.scc g]
  
  toDag :: Graph n -> Graph [n]
  toDag (Graph g lv) = Graph g' ns' where
      ns' = listArray (0,max_v) [ map (lv!) ns |  ns <- nss ]
      g' = listArray (0,max_v) [ snub [ v | n <- ns, v <- g!n ] | ns <- nss ]
      max_v = length nss - 1
      nss = map (flip f []) (G.scc g) where
          f (Node v ts) rs = v:foldr f rs ts
  
  type AdjacencyMatrix s  = STArray s (Vertex,Vertex) Bool
  type IAdjacencyMatrix  = Array (Vertex,Vertex) Bool
  
  transitiveClosureAM :: AdjacencyMatrix s -> ST s ()
  transitiveClosureAM arr = do
      bnds@(_,(max_v,_)) <- getBounds arr
      forM_ [0 .. max_v] $ \k -> do
          forM_ (range bnds) $ \ (i,j) -> do
                  dij <- readArray arr (i,j)
                  dik <- readArray arr (i,k)
                  dkj <- readArray arr (k,j)
                  writeArray arr (i,j) (dij || (dik && dkj))
  
  
  
  transitiveReductionAM :: AdjacencyMatrix s -> ST s ()
  transitiveReductionAM arr = do
      bnds@(_,(max_v,_)) <- getBounds arr
      transitiveClosureAM arr
      (farr :: IAdjacencyMatrix) <- freeze arr
      forM_ [0 .. max_v] $ \k -> do
          forM_ (range bnds) $ \ (i,j) -> do
              if farr!(k,i) && farr!(i,j) then
                  writeArray arr (k,j) False
               else return ()
  
  toAdjacencyMatrix :: G.Graph -> ST s (AdjacencyMatrix s)
  toAdjacencyMatrix g = do
      let (0,max_v) = bounds g
      arr <- newArray ((0,0),(max_v,max_v)) False :: ST s (STArray s (Vertex,Vertex) Bool)
      sequence_ [ writeArray arr (v,u) True | (v,vs) <- assocs g, u <- vs ]
      return arr
  
  fromAdjacencyMatrix :: AdjacencyMatrix s -> ST s G.Graph
  fromAdjacencyMatrix arr = do
      bnds@(_,(max_v,_)) <- getBounds arr
      rs <- getAssocs arr
      let rs' = [ x | (x,True) <- rs ]
      return (listArray (0,max_v) [ [ v | (n',v) <- rs', n == n' ] | n <- [ 0 .. max_v] ])
  
  transitiveClosure :: Graph n -> Graph n
  transitiveClosure (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where
      tc g = do
          a <- toAdjacencyMatrix g
          transitiveClosureAM a
          fromAdjacencyMatrix a
  
  transitiveReduction :: Graph n -> Graph n
  transitiveReduction (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where
      tc g = do
          a <- toAdjacencyMatrix g
          transitiveReductionAM a
          fromAdjacencyMatrix a
  
  
  instance Functor Graph where
      fmap f (Graph g n) = Graph g (fmap f n)
  
  --mapT    :: (Vertex -> a -> b) -> Table a -> Table b
  --mapT f t = listArray (bounds t) [ (f v (t!v)) | v <- indices t ]
  
  restitchGraph :: Ord k => (n -> k) -> (n -> [k]) -> Graph n -> Graph n
  restitchGraph fn fd (Graph g nr) = Graph g' nr where
      kmap = Map.fromList [ (fn n,i) | (i,n) <- assocs nr ]
      g'	 = listArray (bounds g) [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- elems nr]
  
  mapGraph :: forall a b . (a -> [b] -> b) -> Graph a -> Graph b
  mapGraph f (Graph gr nr) = runST $ do
      mnr <- thaw nr  :: ST s (STArray s Vertex a)
      mnr <- mapArray Left mnr
      let g i = readArray mnr i >>= \v -> case v of
              Right m -> return m
              Left l -> mdo
                  writeArray mnr i (Right r)
                  rs <- mapM g (gr!i)
                  let r = f l rs
                  return r
      mapM_ g (range $ bounds nr)
      mnr <- mapArray fromRight mnr
      mnr <- unsafeFreeze mnr
      return (Graph gr mnr)
  
  
  