module Graph (

  Graph, NodeId, Adj, Context,

  match, empty, addNode, addEdge,

  grev, topsort, scc

  ) where

type Graph a b = [(NodeId,Context a b)]

type Context a b = (Adj b,a,Adj b)
type Adj b = [(NodeId,b)]
type NodeId = Int


match :: NodeId -> Graph a b -> Maybe (Context a b, Graph a b)
match n g = do
  ctx <- lookup n g
  return (ctx, map clean (remove g))
 where
  remove = filter ((n/=).fst)
  clean (x, (preds,label,succs)) = (x, (remove preds, label, remove succs))

empty :: Graph a b
empty = []

addNode :: NodeId -> a -> Graph a b -> Graph a b
addNode n a g
  = maybe ((n,([],a,[])):g)
          (error $ "node " ++ show n ++ " already in graph")
      (lookup n g)

addEdge :: NodeId -> b -> NodeId -> Graph a b -> Graph a b
addEdge n b m g
  = maybe (noNode n)
          (\_-> maybe (noNode m)
                      (\_-> map include g)
                  (lookup m g))
      (lookup n g)
 where
  noNode x = error $ "node " ++ show x ++ " not in graph"

  include nctx@(x, (preds,l,succs))
    -- insert in preds and succs if n == m
    | x == n = (x, ((if x == m then ((n,b):) else id) preds,l,(m,b):succs))
    | x == m = (x, ((n,b):preds,l,succs))
    | otherwise = nctx


grev :: Graph a b -> Graph a b
grev = map (\ (n,(preds,label,succs)) -> (n,(succs,label,preds)))


data Tree a = Tree a [Tree a]

preorder :: Tree a -> [a]
preorder (Tree x ts) = x : concatMap preorder ts

postorder :: Tree a -> [a]
postorder (Tree x ts) = concatMap postorder ts ++ [x]


df :: [NodeId] -> Graph a b -> ([Tree NodeId], Graph a b)
df [] g = ([],g)
df (n:ns) g
  = maybe (df ns g)
          (\ ((_,_,succs),g')
            -> let (ts1,g1) = df (map fst succs) g'
                   (ts2,g2) = df ns g1
                in (Tree n ts1 : ts2, g2))
      (match n g)

dff :: [NodeId] -> Graph a b -> [Tree NodeId]
dff = (fst.).df

topsort :: Graph a b -> [NodeId]
topsort g = reverse (concatMap postorder (dff (map fst g) g))

scc :: Graph a b -> [[NodeId]]
scc g = map preorder (dff (topsort g) (grev g))


graph = addEdge 3 'e' 2
      $ addEdge 4 'c' 1
      $ addEdge 2 'b' 4
      $ addEdge 4 'd' 3
      $ addNode 4 4
      $ addNode 3 3
      $ addEdge 2 'a' 1
      $ addNode 2 2
      $ addNode 1 1
      $ empty