------------------------------------------------------------------------------
-- A version of the graph algorithms described in:
-- 
-- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
--   by David King and John Launchbury
-- 
-- Also included is some additional code for printing tree structures ...
--
-- Suitable for use with Hugs 98.
--
-- Modified for use with FiniteMap and Set by Kevin Backhouse.
------------------------------------------------------------------------------

module Ldfs( Graph, vertices, edges, outdegree, buildG, successors,
             predecessors, deref, transposeG, reverseE, indegree,

             back, bcc, components, cross, forward, path,
             preOrd, scc, scc',showForest, topSort, tree )

where

import FiniteMap
import Set
import List
import Maybe (fromJust)

-- Representing graphs:
type Graph v  = FiniteMap v [v]

vertices :: Graph v -> [v]
vertices  = keysFM

type Edge v = (v, v)

edges    :: Graph v -> [Edge v]
edges g   = [ (v, w) | (v,vs) <- fmToList g, w <- vs ]

outdegree :: Graph v -> FiniteMap v Int
outdegree  = mapFM numEdges
             where numEdges _ ws = length ws

buildG :: (Ord a, Ord b) => [(a,b)] -> FiniteMap a [b]
buildG = addListToFM_C (++) emptyFM . map wrap
         where wrap (a,b) = (a,[b])

successors :: Ord v => Graph v -> v -> [v]
successors g v = lookupWithDefaultFM g [] v

predecessors :: Ord v => Graph v -> v -> [v]
predecessors = successors . transposeG

deref :: Ord v => FiniteMap v a -> v -> a
deref fm x = fromJust (lookupFM fm x)

transposeG  :: Ord v => Graph v -> Graph v
transposeG g = buildG (reverseE g)

reverseE    :: Graph v -> [Edge v]
reverseE g   = [ (w, v) | (v, w) <- edges g ]

indegree :: Ord v => Graph v -> FiniteMap v Int
indegree  = outdegree . transposeG


-- Depth-first search

-- Specification and implementation of depth-first search:

data Tree a   = Node a (Forest a) deriving Show
type Forest a = [Tree a]

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 (generate g) vs)

generate     :: Ord v => Graph v -> v -> Tree v
generate g v  = Node v (map (generate g)
                       (lookupWithDefaultFM g [] v))

prune        :: Ord v => Forest v -> Forest v
prune ts      = fst (chop emptySet ts)

chop         :: Ord v => Set v -> Forest v -> (Forest v, Set v)
chop m []     = ([], m)
chop m (Node v ts : us)
              = if elementOf v m then
                  chop m us
                else
                  let (as, m') = chop (addToSet m v) ts in
                  let (bs, m'') = chop m' us in
                  (Node v as : bs, m'')


-- Depth-first search algorithms

-- Algorithm 1: depth first search numbering

preorder            :: Tree a -> [a]
preorder (Node a ts) = [a] ++ preorderF ts

preorderF           :: Forest a -> [a]
preorderF ts         = concat (map preorder ts)

preOrd :: Ord v => Graph v -> [v]
preOrd  = preorderF . dff

tabulate   :: Ord v => [v] -> FiniteMap v Int
tabulate vs = listToFM (zip vs [1..])

preArr :: Ord v => Forest v -> FiniteMap v Int
preArr  = tabulate . preorderF

-- Algorithm 2: topological sorting

postorder :: Tree a -> [a]
postorder (Node a ts) = postorderF ts ++ [a]

postorderF   :: Forest a -> [a]
postorderF ts = concat (map postorder ts)

postOrd      :: Ord v => Graph v -> [v]
postOrd       = postorderF . dff

topSort      :: Ord v => Graph v -> [v]
topSort       = reverse . postOrd

-- Algorithm 3: connected components

components   :: Ord v => Graph v -> Forest v
components    = dff . undirected

undirected   :: Ord v => Graph v -> Graph v
undirected g  = buildG (edges g ++ reverseE g)

-- Algorithm 4: strongly connected components

scc          :: Ord v => Graph v -> Forest v
scc g         = dfs (transposeG g) (reverse (postOrd g))

scc'         :: Ord v => Graph v -> Forest v
scc' g        = dfs g (reverse (postOrd (transposeG g)))

-- Algorithm 5: Classifying edges

tree :: Ord v => Forest v -> Graph v
tree ts  = buildG (concat (map flat ts))
 where flat (Node v rs) = [ (v, w) | Node w _ <- rs ] ++
                          concat (map flat rs)

back              :: Ord v => Graph v -> FiniteMap v Int -> Graph v
back g post        = mapFM select g
 where select v ws = [ w | w <- ws, deref post v < deref post w ]

cross             :: Ord v => Graph v -> FiniteMap v Int ->
                     FiniteMap v Int -> Graph v
cross g pre post   = mapFM select g
 where select v ws = [ w | w <- ws, deref post v > deref post w,
                           deref pre v > deref pre w ]

forward :: Ord v => Graph v -> Graph v -> FiniteMap v Int -> Graph v
forward g treeG pre = mapFM select g
 where select v ws = [ w | w <- ws, deref pre v < deref pre w ] \\
                     deref treeG v

-- Algorithm 6: Finding reachable vertices

reachable    :: Ord v => Graph v -> v -> [v]
reachable g v = preorderF (dfs g [v])

path         :: Ord v => Graph v -> v -> v -> Bool
path g v w    = w `elem` (reachable g v)

-- Algorithm 7: Biconnected components

bcc :: Ord v => Graph v -> Forest [v]
bcc g = (concat . map bicomps . map (label g dnum)) forest
 where forest = dff g
       dnum   = preArr forest

label :: Ord v => Graph v -> FiniteMap v Int -> Tree v -> Tree (v,Int,Int)
label g dnum (Node v ts) = Node (v,deref dnum v,lv) us
 where us = map (label g dnum) ts
       lv = minimum ([deref dnum v] ++ [deref dnum w | w <- deref g v]
                     ++ [lu | Node (u,du,lu) xs <- us])

bicomps :: Tree (v,Int,Int) -> Forest [v]
bicomps (Node (v,_,_) ts)
      = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]

collect :: Tree (v,Int,Int) -> (Int, Tree [v])
collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
 where collected = map collect ts
       vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
       cs = concat [ if lw<dv then us else [Node (v:ws) us]
                        | (lw, Node ws us) <- collected ]

-- Utility functions for drawing trees and forests:

showTree :: Show a => Tree a -> String
showTree  = drawTree . mapTree show

showForest :: Show a => Forest a -> String
showForest  = unlines . map showTree

mapTree              :: (a -> b) -> (Tree a -> Tree b)
mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)

drawTree        :: Tree String -> String
drawTree         = unlines . draw

draw :: Tree String -> [String]
draw (Node x vs) = grp this (space (length this)) (stLoop vs)
 where this          = s1 ++ x ++ " "

       space n       = take n (repeat ' ')

       stLoop []     = [""]
       stLoop [t]    = grp s2 "  " (draw t)
       stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts

       rsLoop [t]    = grp s5 "  " (draw t)
       rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
       rsLoop []     = error "draw, rsLoop (Ldfs.hs)"

       grp first rst   = zipWith (++) (first:repeat rst)

       [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]

------------------------------------------------------------------------------