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

    -- | Please note that this instance is unsafe.
    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

    -- | Please note that this instance is unsafe.
    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')})

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

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

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

    -- | filter list (of successors\/predecessors) through a boolean ST array
    -- representing deleted marks
    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)})