{-# 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 :: GraphRep a b -> String
showGraph (_,a :: Array Node (Context' a b)
a,m :: IOArray Node Bool
m) = (Node -> String) -> [Node] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node -> String
showAdj (Array Node (Context' a b) -> [Node]
forall i e. Ix i => Array i e -> [i]
indices Array Node (Context' a b)
a)
where showAdj :: Node -> String
showAdj v :: Node
v | IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IOArray Node Bool -> Node -> IO Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Node Bool
m Node
v) = ""
| Bool
otherwise = case Array Node (Context' a b)
aArray Node (Context' a b) -> Node -> Context' a b
forall i e. Ix i => Array i e -> i -> e
!Node
v of
Nothing -> ""
Just (_,l :: a
l,s :: Adj b
s) -> '\n'Char -> String -> String
forall a. a -> [a] -> [a]
:Node -> String
forall a. Show a => a -> String
show Node
vString -> String -> String
forall a. [a] -> [a] -> [a]
++":"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
forall a. [a] -> [a] -> [a]
++Adj b -> String
forall a. Show a => a -> String
show Adj b
s'
where s' :: Adj b
s' = IO (Adj b) -> Adj b
forall a. IO a -> a
unsafePerformIO (IOArray Node Bool -> Adj b -> IO (Adj b)
forall b. IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel IOArray Node Bool
m Adj b
s)
instance (Show a,Show b) => Show (SGr a b) where
show :: SGr a b -> String
show (SGr g :: GraphRep a b
g) = GraphRep a b -> String
forall a b. (Show a, Show b) => GraphRep a b -> String
showGraph GraphRep a b
g
instance (Show a,Show b) => Show (IO (SGr a b)) where
show :: IO (SGr a b) -> String
show g :: IO (SGr a b)
g = IO String -> String
forall a. IO a -> a
unsafePerformIO (do {(SGr g' :: GraphRep a b
g') <- IO (SGr a b)
g; String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (GraphRep a b -> String
forall a b. (Show a, Show b) => GraphRep a b -> String
showGraph GraphRep a b
g')})
instance GraphM IO SGr where
emptyM :: IO (SGr a b)
emptyM = Node -> IO (SGr a b)
forall a b. Node -> IO (SGr a b)
emptyN Node
defaultGraphSize
isEmptyM :: IO (SGr a b) -> IO Bool
isEmptyM g :: IO (SGr a b)
g = do {SGr (n :: Node
n,_,_) <- IO (SGr a b)
g; Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Node
nNode -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==0)}
matchM :: Node -> IO (SGr a b) -> IO (Decomp SGr a b)
matchM v :: Node
v g :: IO (SGr a b)
g = do g' :: SGr a b
g'@(SGr (n :: Node
n,a :: Array Node (Context' a b)
a,m :: IOArray Node Bool
m)) <- IO (SGr a b)
g
case Array Node (Context' a b)
aArray Node (Context' a b) -> Node -> Context' a b
forall i e. Ix i => Array i e -> i -> e
!Node
v of
Nothing -> Decomp SGr a b -> IO (Decomp SGr a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context a b)
forall a. Maybe a
Nothing,SGr a b
g')
Just (pr :: Adj b
pr,l :: a
l,su :: Adj b
su) ->
do Bool
b <- IOArray Node Bool -> Node -> IO Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Node Bool
m Node
v
if Bool
b then Decomp SGr a b -> IO (Decomp SGr a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context a b)
forall a. Maybe a
Nothing,SGr a b
g') else
do Adj b
s <- IOArray Node Bool -> Adj b -> IO (Adj b)
forall b. IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel IOArray Node Bool
m Adj b
su
Adj b
p' <- IOArray Node Bool -> Adj b -> IO (Adj b)
forall b. IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel IOArray Node Bool
m Adj b
pr
let p :: Adj b
p = ((b, Node) -> Bool) -> Adj b -> Adj b
forall a. (a -> Bool) -> [a] -> [a]
filter ((Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/=Node
v)(Node -> Bool) -> ((b, Node) -> Node) -> (b, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(b, Node) -> Node
forall a b. (a, b) -> b
snd) Adj b
p'
IOArray Node Bool -> Node -> Bool -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Node Bool
m Node
v Bool
True
Decomp SGr a b -> IO (Decomp SGr 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,Node
v,a
l,Adj b
s),GraphRep a b -> SGr a b
forall a b. GraphRep a b -> SGr a b
SGr (Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
-1,Array Node (Context' a b)
a,IOArray Node Bool
m))
mkGraphM :: [LNode a] -> [LEdge b] -> IO (SGr a b)
mkGraphM vs :: [LNode a]
vs es :: [LEdge b]
es = do IOArray Node Bool
m <- (Node, Node) -> Bool -> IO (IOArray Node Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (1,Node
n) Bool
False
SGr a b -> IO (SGr a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (GraphRep a b -> SGr a b
forall a b. GraphRep a b -> SGr a b
SGr (Node
n,Array Node (Maybe ([(b, Node)], a, [(b, Node)]))
pr,IOArray Node Bool
m))
where nod :: Array Node (Maybe ([a], a, [a]))
nod = (Node, Node)
-> [(Node, Maybe ([a], a, [a]))]
-> Array Node (Maybe ([a], a, [a]))
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node, Node)
bnds ((LNode a -> (Node, Maybe ([a], a, [a])))
-> [LNode a] -> [(Node, Maybe ([a], a, [a]))]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: Node
v,l :: a
l)->(Node
v,([a], a, [a]) -> Maybe ([a], a, [a])
forall a. a -> Maybe a
Just ([],a
l,[]))) [LNode a]
vs)
su :: Array Node (Maybe ([a], a, [(b, Node)]))
su = (Maybe ([a], a, [(b, Node)])
-> (b, Node) -> Maybe ([a], a, [(b, Node)]))
-> Array Node (Maybe ([a], a, [(b, Node)]))
-> [(Node, (b, Node))]
-> Array Node (Maybe ([a], a, [(b, Node)]))
forall i e a.
Ix i =>
(e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
accum Maybe ([a], a, [(b, Node)])
-> (b, Node) -> Maybe ([a], a, [(b, Node)])
forall a b a b.
Maybe (a, b, [(a, b)]) -> (a, b) -> Maybe (a, b, [(a, b)])
addSuc Array Node (Maybe ([a], a, [(b, Node)]))
forall a a. Array Node (Maybe ([a], a, [a]))
nod ((LEdge b -> (Node, (b, Node))) -> [LEdge b] -> [(Node, (b, Node))]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: Node
v,w :: Node
w,l :: b
l)->(Node
v,(b
l,Node
w))) [LEdge b]
es)
pr :: Array Node (Maybe ([(b, Node)], a, [(b, Node)]))
pr = (Maybe ([(b, Node)], a, [(b, Node)])
-> (b, Node) -> Maybe ([(b, Node)], a, [(b, Node)]))
-> Array Node (Maybe ([(b, Node)], a, [(b, Node)]))
-> [(Node, (b, Node))]
-> Array Node (Maybe ([(b, Node)], a, [(b, Node)]))
forall i e a.
Ix i =>
(e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
accum Maybe ([(b, Node)], a, [(b, Node)])
-> (b, Node) -> Maybe ([(b, Node)], a, [(b, Node)])
forall a b b c.
Maybe ([(a, b)], b, c) -> (a, b) -> Maybe ([(a, b)], b, c)
addPre Array Node (Maybe ([(b, Node)], a, [(b, Node)]))
forall a. Array Node (Maybe ([a], a, [(b, Node)]))
su ((LEdge b -> (Node, (b, Node))) -> [LEdge b] -> [(Node, (b, Node))]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: Node
v,w :: Node
w,l :: b
l)->(Node
w,(b
l,Node
v))) [LEdge b]
es)
bnds :: (Node, Node)
bnds = ([Node] -> Node
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Node]
vs',[Node] -> Node
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Node]
vs')
vs' :: [Node]
vs' = (LNode a -> Node) -> [LNode a] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode a -> Node
forall a b. (a, b) -> a
fst [LNode a]
vs
n :: Node
n = [LNode a] -> Node
forall (t :: * -> *) a. Foldable t => t a -> Node
length [LNode a]
vs
addSuc :: Maybe (a, b, [(a, b)]) -> (a, b) -> Maybe (a, b, [(a, b)])
addSuc (Just (p :: a
p,l' :: b
l',s :: [(a, b)]
s)) (l :: a
l,w :: 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 Nothing _ = String -> Maybe (a, b, [(a, b)])
forall a. HasCallStack => String -> a
error "mkGraphM (SGr): addSuc Nothing"
addPre :: Maybe ([(a, b)], b, c) -> (a, b) -> Maybe ([(a, b)], b, c)
addPre (Just (p :: [(a, b)]
p,l' :: b
l',s :: c
s)) (l :: a
l,w :: 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 Nothing _ = String -> Maybe ([(a, b)], b, c)
forall a. HasCallStack => String -> a
error "mkGraphM (SGr): addPre Nothing"
labNodesM :: IO (SGr a b) -> IO [LNode a]
labNodesM g :: IO (SGr a b)
g = do (SGr (_,a :: Array Node (Context' a b)
a,m :: IOArray Node Bool
m)) <- IO (SGr a b)
g
let getLNode :: [(Node, b)] -> (Node, Maybe (a, b, c)) -> m [(Node, b)]
getLNode vs :: [(Node, b)]
vs (_,Nothing) = [(Node, b)] -> m [(Node, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Node, b)]
vs
getLNode vs :: [(Node, b)]
vs (v :: Node
v,Just (_,l :: b
l,_)) =
do Bool
b <- IOArray Node Bool -> Node -> m Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Node Bool
m Node
v
[(Node, b)] -> m [(Node, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
b then [(Node, b)]
vs else (Node
v,b
l)(Node, b) -> [(Node, b)] -> [(Node, b)]
forall a. a -> [a] -> [a]
:[(Node, b)]
vs)
([LNode a] -> (Node, Context' a b) -> IO [LNode a])
-> [LNode a] -> [(Node, Context' a b)] -> IO [LNode a]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [LNode a] -> (Node, Context' a b) -> IO [LNode a]
forall (m :: * -> *) b a c.
MArray IOArray Bool m =>
[(Node, b)] -> (Node, Maybe (a, b, c)) -> m [(Node, b)]
getLNode [] (Array Node (Context' a b) -> [(Node, Context' a b)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Node (Context' a b)
a)
defaultGraphSize :: Int
defaultGraphSize :: Node
defaultGraphSize = 100
emptyN :: Int -> IO (SGr a b)
emptyN :: Node -> IO (SGr a b)
emptyN n :: Node
n = do IOArray Node Bool
m <- (Node, Node) -> Bool -> IO (IOArray Node Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (1,Node
n) Bool
False
SGr a b -> IO (SGr a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (GraphRep a b -> SGr a b
forall a b. GraphRep a b -> SGr a b
SGr (0,(Node, Node)
-> [(Node, Maybe (Adj b, a, Adj b))]
-> Array Node (Maybe (Adj b, a, Adj b))
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (1,Node
n) [(Node
i,Maybe (Adj b, a, Adj b)
forall a. Maybe a
Nothing) | Node
i <- [1..Node
n]],IOArray Node Bool
m))
removeDel :: IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel :: IOArray Node Bool -> Adj b -> IO (Adj b)
removeDel m :: IOArray Node Bool
m = ((b, Node) -> IO Bool) -> Adj b -> IO (Adj b)
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\(_,v :: Node
v)->do {Bool
b<-IOArray Node Bool -> Node -> IO Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Node Bool
m Node
v;Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
b)})