    {-# 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)

    instance (Show a,Show b) => Show (SGr a b) where
      show (SGr g) = showGraph g

    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)})