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

-- (c) 2002 by Martin Erwig [see file COPYRIGHT]
-- | Static IOArray-based Graphs
module Data.Graph.Inductive.Monad.STArray(
    -- * 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 Control.Monad.ST
import Data.Array
import Data.Array.ST
import System.IO.Unsafe



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

newtype SGr s a b = SGr (GraphRep s a b)

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

type USGr s = SGr s () ()


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

-- Show
--
showGraph :: (Show a,Show b) => GraphRep RealWorld a b -> String
showGraph :: GraphRep RealWorld a b -> String
showGraph (Int
_,Array Int (Context' a b)
a,STArray RealWorld Int Bool
m) = (Int -> String) -> [Int] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> String
showAdj (Array Int (Context' a b) -> [Int]
forall i e. Ix i => Array i e -> [i]
indices Array Int (Context' a b)
a)
    where showAdj :: Int -> String
showAdj Int
v | ST RealWorld Bool -> Bool
forall a. ST RealWorld a -> a
unsafeST (STArray RealWorld Int Bool -> Int -> ST RealWorld Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray RealWorld Int Bool
m Int
v) = String
""
                    | Bool
otherwise = case Array Int (Context' a b)
aArray Int (Context' a b) -> Int -> Context' a b
forall i e. Ix i => Array i e -> i -> e
!Int
v of
                        Context' a b
Nothing      -> String
""
                        Just (Adj b
_,a
l,Adj b
s) -> Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
vString -> String -> String
forall a. [a] -> [a] -> [a]
++String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
lString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"->"String -> String -> String
forall a. [a] -> [a] -> [a]
++Adj b -> String
forall a. Show a => a -> String
show Adj b
s'
                          where s' :: Adj b
s' = ST RealWorld (Adj b) -> Adj b
forall a. ST RealWorld a -> a
unsafeST (STArray RealWorld Int Bool -> Adj b -> ST RealWorld (Adj b)
forall s b. STArray s Int Bool -> Adj b -> ST s (Adj b)
removeDel STArray RealWorld Int Bool
m Adj b
s)

unsafeST :: ST RealWorld a -> a
unsafeST :: ST RealWorld a -> a
unsafeST = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (ST RealWorld a -> IO a) -> ST RealWorld a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST RealWorld a -> IO a
forall a. ST RealWorld a -> IO a
stToIO

-- | Please not that this instance is unsafe.
instance (Show a,Show b) => Show (SGr RealWorld a b) where
  show :: SGr RealWorld a b -> String
show (SGr GraphRep RealWorld a b
g) = GraphRep RealWorld a b -> String
forall a b. (Show a, Show b) => GraphRep RealWorld a b -> String
showGraph GraphRep RealWorld a b
g

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

-- GraphM
--
instance GraphM (ST s) (SGr s) where
  emptyM :: ST s (SGr s a b)
emptyM = Int -> ST s (SGr s a b)
forall s a b. Int -> ST s (SGr s a b)
emptyN Int
defaultGraphSize
  isEmptyM :: ST s (SGr s a b) -> ST s Bool
isEmptyM ST s (SGr s a b)
g = do {SGr (Int
n,Array Int (Context' a b)
_,STArray s Int Bool
_) <- ST s (SGr s a b)
g; Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0)}
  matchM :: Int -> ST s (SGr s a b) -> ST s (Decomp (SGr s) a b)
matchM Int
v ST s (SGr s a b)
g = do g' :: SGr s a b
g'@(SGr (Int
n,Array Int (Context' a b)
a,STArray s Int Bool
m)) <- ST s (SGr s a b)
g
                  case Array Int (Context' a b)
aArray Int (Context' a b) -> Int -> Context' a b
forall i e. Ix i => Array i e -> i -> e
!Int
v of
                    Context' a b
Nothing -> Decomp (SGr s) a b -> ST s (Decomp (SGr s) a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context a b)
forall a. Maybe a
Nothing,SGr s a b
g')
                    Just (Adj b
pr,a
l,Adj b
su) ->
                       do Bool
b <- STArray s Int Bool -> Int -> ST s Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Int Bool
m Int
v
                          if Bool
b then Decomp (SGr s) a b -> ST s (Decomp (SGr s) a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context a b)
forall a. Maybe a
Nothing,SGr s a b
g') else
                             do Adj b
s  <- STArray s Int Bool -> Adj b -> ST s (Adj b)
forall s b. STArray s Int Bool -> Adj b -> ST s (Adj b)
removeDel STArray s Int Bool
m Adj b
su
                                Adj b
p' <- STArray s Int Bool -> Adj b -> ST s (Adj b)
forall s b. STArray s Int Bool -> Adj b -> ST s (Adj b)
removeDel STArray s Int Bool
m Adj b
pr
                                let p :: Adj b
p = ((b, Int) -> Bool) -> Adj b -> Adj b
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
v)(Int -> Bool) -> ((b, Int) -> Int) -> (b, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(b, Int) -> Int
forall a b. (a, b) -> b
snd) Adj b
p'
                                STArray s Int Bool -> Int -> Bool -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Bool
m Int
v Bool
True
                                Decomp (SGr s) a b -> ST s (Decomp (SGr s) a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context a b -> Maybe (Context a b)
forall a. a -> Maybe a
Just (Adj b
p,Int
v,a
l,Adj b
s),(Int, Array Int (Context' a b), STArray s Int Bool) -> SGr s a b
forall s a b. GraphRep s a b -> SGr s a b
SGr (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Array Int (Context' a b)
a,STArray s Int Bool
m))
  mkGraphM :: [LNode a] -> [LEdge b] -> ST s (SGr s a b)
mkGraphM [LNode a]
vs [LEdge b]
es = do STArray s Int Bool
m <- (Int, Int) -> Bool -> ST s (STArray s Int Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
1,Int
n) Bool
False
                      SGr s a b -> ST s (SGr s a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (GraphRep s a b -> SGr s a b
forall s a b. GraphRep s a b -> SGr s a b
SGr (Int
n,Array Int (Maybe ([(b, Int)], a, [(b, Int)]))
pr,STArray s Int Bool
m))
          where nod :: Array Int (Maybe ([a], a, [a]))
nod  = (Int, Int)
-> [(Int, Maybe ([a], a, [a]))] -> Array Int (Maybe ([a], a, [a]))
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int, Int)
bnds ((LNode a -> (Int, Maybe ([a], a, [a])))
-> [LNode a] -> [(Int, Maybe ([a], a, [a]))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
v,a
l)->(Int
v,([a], a, [a]) -> Maybe ([a], a, [a])
forall a. a -> Maybe a
Just ([],a
l,[]))) [LNode a]
vs)
                su :: Array Int (Maybe ([a], a, [(b, Int)]))
su   = (Maybe ([a], a, [(b, Int)])
 -> (b, Int) -> Maybe ([a], a, [(b, Int)]))
-> Array Int (Maybe ([a], a, [(b, Int)]))
-> [(Int, (b, Int))]
-> Array Int (Maybe ([a], a, [(b, Int)]))
forall i e a.
Ix i =>
(e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
accum Maybe ([a], a, [(b, Int)])
-> (b, Int) -> Maybe ([a], a, [(b, Int)])
forall a b a b.
Maybe (a, b, [(a, b)]) -> (a, b) -> Maybe (a, b, [(a, b)])
addSuc Array Int (Maybe ([a], a, [(b, Int)]))
forall a a. Array Int (Maybe ([a], a, [a]))
nod ((LEdge b -> (Int, (b, Int))) -> [LEdge b] -> [(Int, (b, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
v,Int
w,b
l)->(Int
v,(b
l,Int
w))) [LEdge b]
es)
                pr :: Array Int (Maybe ([(b, Int)], a, [(b, Int)]))
pr   = (Maybe ([(b, Int)], a, [(b, Int)])
 -> (b, Int) -> Maybe ([(b, Int)], a, [(b, Int)]))
-> Array Int (Maybe ([(b, Int)], a, [(b, Int)]))
-> [(Int, (b, Int))]
-> Array Int (Maybe ([(b, Int)], a, [(b, Int)]))
forall i e a.
Ix i =>
(e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
accum Maybe ([(b, Int)], a, [(b, Int)])
-> (b, Int) -> Maybe ([(b, Int)], a, [(b, Int)])
forall a b b c.
Maybe ([(a, b)], b, c) -> (a, b) -> Maybe ([(a, b)], b, c)
addPre Array Int (Maybe ([(b, Int)], a, [(b, Int)]))
forall a. Array Int (Maybe ([a], a, [(b, Int)]))
su ((LEdge b -> (Int, (b, Int))) -> [LEdge b] -> [(Int, (b, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
v,Int
w,b
l)->(Int
w,(b
l,Int
v))) [LEdge b]
es)
                bnds :: (Int, Int)
bnds = ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
vs',[Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
vs')
                vs' :: [Int]
vs'  = (LNode a -> Int) -> [LNode a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LNode a -> Int
forall a b. (a, b) -> a
fst [LNode a]
vs
                n :: Int
n    = [LNode a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LNode a]
vs
                addSuc :: Maybe (a, b, [(a, b)]) -> (a, b) -> Maybe (a, b, [(a, b)])
addSuc (Just (a
p,b
l',[(a, b)]
s)) (a
l,b
w) = (a, b, [(a, b)]) -> Maybe (a, b, [(a, b)])
forall a. a -> Maybe a
Just (a
p,b
l',(a
l,b
w)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
s)
                addSuc Maybe (a, b, [(a, b)])
Nothing (a, b)
_ = String -> Maybe (a, b, [(a, b)])
forall a. HasCallStack => String -> a
error String
"mkGraphM (SGr): addSuc Nothing"
                addPre :: Maybe ([(a, b)], b, c) -> (a, b) -> Maybe ([(a, b)], b, c)
addPre (Just ([(a, b)]
p,b
l',c
s)) (a
l,b
w) = ([(a, b)], b, c) -> Maybe ([(a, b)], b, c)
forall a. a -> Maybe a
Just ((a
l,b
w)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
p,b
l',c
s)
                addPre Maybe ([(a, b)], b, c)
Nothing (a, b)
_ = String -> Maybe ([(a, b)], b, c)
forall a. HasCallStack => String -> a
error String
"mkGraphM (SGr): addPre Nothing"
  labNodesM :: ST s (SGr s a b) -> ST s [LNode a]
labNodesM ST s (SGr s a b)
g = do (SGr (Int
_,Array Int (Context' a b)
a,STArray s Int Bool
m)) <- ST s (SGr s a b)
g
                   let getLNode :: [(Int, b)] -> (Int, Maybe (a, b, c)) -> m [(Int, b)]
getLNode [(Int, b)]
vs (Int
_,Maybe (a, b, c)
Nothing)      = [(Int, b)] -> m [(Int, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int, b)]
vs
                       getLNode [(Int, b)]
vs (Int
v,Just (a
_,b
l,c
_)) =
                           do Bool
b <- STArray s Int Bool -> Int -> m Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Int Bool
m Int
v
                              [(Int, b)] -> m [(Int, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
b then [(Int, b)]
vs else (Int
v,b
l)(Int, b) -> [(Int, b)] -> [(Int, b)]
forall a. a -> [a] -> [a]
:[(Int, b)]
vs)
                   ([LNode a] -> (Int, Context' a b) -> ST s [LNode a])
-> [LNode a] -> [(Int, Context' a b)] -> ST s [LNode a]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [LNode a] -> (Int, Context' a b) -> ST s [LNode a]
forall (m :: * -> *) b a c.
MArray (STArray s) Bool m =>
[(Int, b)] -> (Int, Maybe (a, b, c)) -> m [(Int, b)]
getLNode [] (Array Int (Context' a b) -> [(Int, Context' a b)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Int (Context' a b)
a)

defaultGraphSize :: Int
defaultGraphSize :: Int
defaultGraphSize = Int
100

emptyN :: Int -> ST s (SGr s a b)
emptyN :: Int -> ST s (SGr s a b)
emptyN Int
n = do STArray s Int Bool
m <- (Int, Int) -> Bool -> ST s (STArray s Int Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
1,Int
n) Bool
False
              SGr s a b -> ST s (SGr s a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (GraphRep s a b -> SGr s a b
forall s a b. GraphRep s a b -> SGr s a b
SGr (Int
0,(Int, Int)
-> [(Int, Maybe (Adj b, a, Adj b))]
-> Array Int (Maybe (Adj b, a, Adj b))
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
1,Int
n) [(Int
i,Maybe (Adj b, a, Adj b)
forall a. Maybe a
Nothing) | Int
i <- [Int
1..Int
n]],STArray s Int Bool
m))

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



-- | filter list (of successors\/predecessors) through a boolean ST array
-- representing deleted marks
removeDel :: STArray s Node Bool -> Adj b -> ST s (Adj b)
removeDel :: STArray s Int Bool -> Adj b -> ST s (Adj b)
removeDel STArray s Int Bool
m = ((b, Int) -> ST s Bool) -> Adj b -> ST s (Adj b)
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\(b
_,Int
v)->do {Bool
b<-STArray s Int Bool -> Int -> ST s Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Int Bool
m Int
v;Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
b)})