{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
module Data.Graph.Inductive.Monad.IOArray(
SGr(..), GraphRep, Context', USGr,
defaultGraphSize, emptyN,
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
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 () ()
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')})
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))
removeDel :: IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel m = filterM (\(_,v)->do {b<-readArray m v;return (not b)})