{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}

-- (c) 2002 by Martin Erwig [see file COPYRIGHT]
-- | Static IOArray-based Graphs
module Data.Graph.Inductive.Monad.IOArray(
    -- * Graph Representation
    SGr(..), GraphRep, Context', USGr,
    defaultGraphSize, emptyN,
    -- * Utilities
    removeDel,
) where

import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Monad

import Control.Monad
import Data.Array
import Data.Array.IO
import System.IO.Unsafe



----------------------------------------------------------------------
-- GRAPH REPRESENTATION
----------------------------------------------------------------------

newtype SGr a b = SGr (GraphRep a b)

type GraphRep a b = (Int,Array Node (Context' a b),IOArray Node Bool)
type Context' a b = Maybe (Adj b,a,Adj b)

type USGr = SGr () ()


----------------------------------------------------------------------
-- CLASS INSTANCES
----------------------------------------------------------------------

-- Show
--
showGraph :: (Show a,Show b) => GraphRep a b -> String
showGraph (_,a,m) = concatMap showAdj (indices a)
    where showAdj v | unsafePerformIO (readArray m v) = ""
                    | otherwise = case a!v of
                        Nothing      -> ""
                        Just (_,l,s) -> '\n':show v++":"++show l++"->"++show s'
                          where s' = unsafePerformIO (removeDel m s)

-- | Please note that this instance is unsafe.
instance (Show a,Show b) => Show (SGr a b) where
  show (SGr g) = showGraph g

-- | Please note that this instance is unsafe.
instance (Show a,Show b) => Show (IO (SGr a b)) where
  show g = unsafePerformIO (do {(SGr g') <- g; return (showGraph g')})

{-
run :: Show (IO a) => IO a -> IO ()
run x = seq x (print x)
-}

-- GraphM
--
instance GraphM IO SGr where
  emptyM = emptyN defaultGraphSize
  isEmptyM g = do {SGr (n,_,_) <- g; return (n==0)}
  matchM v g = do g'@(SGr (n,a,m)) <- g
                  case a!v of
                    Nothing -> return (Nothing,g')
                    Just (pr,l,su) ->
                       do b <- readArray m v
                          if b then return (Nothing,g') else
                             do s  <- removeDel m su
                                p' <- removeDel m pr
                                let p = filter ((/=v).snd) p'
                                writeArray m v True
                                return (Just (p,v,l,s),SGr (n-1,a,m))
  mkGraphM vs es = do m <- newArray (1,n) False
                      return (SGr (n,pr,m))
          where nod  = array bnds (map (\(v,l)->(v,Just ([],l,[]))) vs)
                su   = accum addSuc nod (map (\(v,w,l)->(v,(l,w))) es)
                pr   = accum addPre su (map (\(v,w,l)->(w,(l,v))) es)
                bnds = (minimum vs',maximum vs')
                vs'  = map fst vs
                n    = length vs
                addSuc (Just (p,l',s)) (l,w) = Just (p,l',(l,w):s)
                addSuc Nothing _ = error "mkGraphM (SGr): addSuc Nothing"
                addPre (Just (p,l',s)) (l,w) = Just ((l,w):p,l',s)
                addPre Nothing _ = error "mkGraphM (SGr): addPre Nothing"
  labNodesM g = do (SGr (_,a,m)) <- g
                   let getLNode vs (_,Nothing)      = return vs
                       getLNode vs (v,Just (_,l,_)) =
                           do b <- readArray m v
                              return (if b then vs else (v,l):vs)
                   foldM getLNode [] (assocs a)

defaultGraphSize :: Int
defaultGraphSize = 100

emptyN :: Int -> IO (SGr a b)
emptyN n = do m <- newArray (1,n) False
              return (SGr (0,array (1,n) [(i,Nothing) | i <- [1..n]],m))

----------------------------------------------------------------------
-- UTILITIES
----------------------------------------------------------------------



-- | filter list (of successors\/predecessors) through a boolean ST array
-- representing deleted marks
removeDel :: IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel m = filterM (\(_,v)->do {b<-readArray m v;return (not b)})