--------------------------------------------------------------------------------
{-| Module      :  Scc
    Copyright   :  (c) Daan Leijen 2002
    License     :  BSD-style

    Maintainer  :  daan@cs.uu.nl
    Stability   :  provisional
    Portability :  portable

  Compute the /strongly connected components/ of a directed graph.
  The implementation is based on the following article:

  * David King and John Launchbury, /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,
    ACM Principles of Programming Languages, San Francisco, 1995.

  In contrast to their description, this module doesn't use lazy state
  threads but is instead purely functional -- using the "Map" and "Set" module.
  This means that the complexity of 'scc' is /O(n*log n)/ instead of /O(n)/ but
  due to the hidden constant factor, this implementation performs very well in practice.
-}
---------------------------------------------------------------------------------}
module UU.DData.Scc ( scc ) where

import qualified UU.DData.Map as Map
import qualified UU.DData.Set as Set 

{-
-- just for testing
import Debug.QuickCheck       
import List(nub,sort)    
-}

{--------------------------------------------------------------------
  Graph
--------------------------------------------------------------------}
-- | A @Graph v@ is a directed graph with nodes @v@.
newtype Graph v = Graph (Map.Map v [v])

-- | An @Edge v@ is a pair @(x,y)@ that represents an arrow from
-- node @x@ to node @y@.
type Edge v     = (v,v)
type Node v     = (v,[v])

{--------------------------------------------------------------------
  Conversion
--------------------------------------------------------------------}
nodes :: Graph v -> [Node v]
nodes (Graph g)
  = Map.toList g

graph :: Ord v => [Node v] -> Graph v
graph es
  = Graph (Map.fromListWith (++) es)

{--------------------------------------------------------------------
  Graph functions
--------------------------------------------------------------------}
edges :: Graph v -> [Edge v]
edges g
  = [(v,w) | (v,vs) <- nodes g, w <- vs]

vertices :: Graph v -> [v]
vertices g
  = [v | (v,vs) <- nodes g]

successors :: Ord v => v -> Graph v -> [v]
successors v (Graph g)
  = Map.findWithDefault [] v g

transpose :: Ord v => Graph v -> Graph v
transpose g@(Graph m)
  = Graph (foldr add empty (edges g))
  where
    empty       = Map.map (const []) m
    add (v,w) m = Map.adjust (v:) w m


{--------------------------------------------------------------------
  Depth first search and forests
--------------------------------------------------------------------}
data Tree v   = Node v (Forest v) 
type Forest v = [Tree v]

dff :: Ord v => Graph v -> Forest v
dff g
  = dfs g (vertices g)

dfs :: Ord v => Graph v -> [v] -> Forest v
dfs g vs      
  = prune (map (tree g) vs)

tree :: Ord v => Graph v -> v -> Tree v
tree g v  
  = Node v (map (tree g) (successors v g))

prune :: Ord v => Forest v -> Forest v
prune fs
  = snd (chop Set.empty  fs)
  where
    chop ms []  = (ms,[])
    chop ms (Node v vs:fs)
      | visited   = chop ms fs
      | otherwise = let ms0       = Set.insert v ms
                        (ms1,vs') = chop ms0 vs
                        (ms2,fs') = chop ms1 fs
                    in (ms2,Node v vs':fs')
      where
        visited   = Set.member v ms

{--------------------------------------------------------------------
  Orderings
--------------------------------------------------------------------}
preorder :: Ord v => Graph v -> [v]
preorder g
  = preorderF (dff g)

preorderF fs
  = concatMap preorderT fs

preorderT (Node v fs)
  = v:preorderF fs

postorder :: Ord v => Graph v -> [v]
postorder g
  = postorderF (dff g) 

postorderT t
  = postorderF [t]

postorderF ts
  = postorderF' ts []
  where
    -- efficient concatenation by passing the tail around.
    postorderF' [] tl          = tl
    postorderF' (t:ts) tl      = postorderT' t (postorderF' ts tl)
    postorderT' (Node v fs) tl = postorderF' fs (v:tl)


{--------------------------------------------------------------------
  Strongly connected components 
--------------------------------------------------------------------}

{- | 
 Compute the strongly connected components of a graph. The algorithm
 is tailored toward the needs of compiler writers that need to compute
 recursive binding groups (for example, the original order is preserved
 as much as possible). 
 
 The expression (@scc xs@) computes the strongly connectected components
 of graph @xs@. A graph is a list of nodes @(v,ws)@ where @v@ is the node 
 label and @ws@ a list of nodes where @v@ points to, ie. there is an 
 arrow\/dependency from @v@ to each node in @ws@. Here is an example
 of @scc@:

>  Scc\> scc [(0,[1]),(1,[1,2,3]),(2,[1]),(3,[]),(4,[])]
>  [[3],[1,2],[0],[4]]

 In an expression @(scc xs)@, the graph @xs@ should contain an entry for 
 every node in the graph, ie:

>  all (`elem` nodes) targets
>  where nodes   = map fst xs
>        targets = concat (map snd xs)

 Furthermore, the returned components consist exactly of the original nodes:

>  sort (concat (scc xs)) == sort (map fst xs)

 The connected components are sorted by dependency, ie. there are
 no arrows\/dependencies from left-to-right. Furthermore, the original order
 is preserved as much as possible. 
-}
scc :: Ord v => [(v,[v])] -> [[v]]
scc nodes
  = sccG (graph nodes)

sccG :: Ord v => Graph v -> [[v]]
sccG g
  = map preorderT (sccF g)

sccF :: Ord v => Graph v -> Forest v
sccF g         
  = reverse (dfs (transpose g) (topsort g))

topsort g
  = reverse (postorder g)

{--------------------------------------------------------------------
  Reachable and path
--------------------------------------------------------------------}
reachable v g
  = preorderF (dfs g [v])

path v w g
  = elem w (reachable v g)


{--------------------------------------------------------------------
  Show
--------------------------------------------------------------------}
instance Show v => Show (Graph v) where
  showsPrec d (Graph m) = shows m
  
instance Show v => Show (Tree v) where
  showsPrec d (Node v []) = shows v 
  showsPrec d (Node v fs) = shows v . showList fs


{--------------------------------------------------------------------
  Quick Test
--------------------------------------------------------------------}
tgraph0 :: Graph Int
tgraph0 = graph 
          [(0,[1])
          ,(1,[2,1,3])
          ,(2,[1])
          ,(3,[])
          ]

tgraph1 = graph
          [  ('a',"jg") 
          ,  ('b',"ia")
          ,  ('c',"he")
          ,  ('d',"")
          ,  ('e',"jhd")
          ,  ('f',"i")
          ,  ('g',"fb")
          ,  ('h',"")
          ]

{-
{--------------------------------------------------------------------
  Quickcheck
--------------------------------------------------------------------}
qcheck prop
  = check config prop
  where
    config = Config
      { configMaxTest = 500
      , configMaxFail = 5000
      , configSize    = \n -> (div n 2 + 3)
      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
      }


{--------------------------------------------------------------------
  Arbitrary Graph's
--------------------------------------------------------------------}
instance (Ord v,Arbitrary v) => Arbitrary (Graph v) where
  arbitrary   = sized arbgraph


arbgraph :: (Ord v,Arbitrary v) => Int -> Gen (Graph v)
arbgraph n
  = do nodes <- arbitrary
       g     <- mapM (targets nodes) nodes
       return (graph g)
  where
    targets nodes v
      = do sz <- choose (0,length nodes-1)
           ts <- mapM (target nodes) [1..sz]
           return (v,ts)
        
    target nodes _
      = do idx <- choose (0,length nodes-1)
           return (nodes!!idx)

{--------------------------------------------------------------------
  Properties
--------------------------------------------------------------------}
prop_ValidGraph :: Graph Int -> Bool
prop_ValidGraph g
  = all (`elem` srcs) targets
  where
    srcs    = map fst (nodes g)
    targets = concatMap snd (nodes g)

-- all scc nodes are in the original graph and the other way around
prop_SccComplete :: Graph Int -> Bool
prop_SccComplete g
  = sort (concat (sccG g)) == sort (vertices g)

-- all scc nodes have only backward dependencies
prop_SccForward :: Graph Int -> Bool
prop_SccForward g
  = all noforwards (zip prevs ss) 
  where
    ss      = sccG g
    prevs   = scanl1 (++) ss

    noforwards (prev,xs)
      = all (noforward prev) xs
  
    noforward prev x
      = all (`elem` prev) (successors x g)

-- all strongly connected components refer to each other
prop_SccConnected :: Graph Int -> Bool
prop_SccConnected g
  = all connected (sccG g)
  where
    connected xs
      = all (paths xs) xs

    paths xs x
      = all (\y -> path x y g) xs

-}