    {-# 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 :: forall a b. (Show a, Show b) => GraphRep RealWorld a b -> String
    showGraph (Node
    _,Array Node (Context' a b)
    a,STArray RealWorld 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 Node
    v | ST RealWorld Bool -> Bool
    forall a. ST RealWorld a -> a
    unsafeST (STArray RealWorld Node Bool -> Node -> ST RealWorld Bool
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STArray RealWorld Node Bool
    m Node
    v) = String
    ""
                        | 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
                            Context' a b
    Nothing      -> String
    ""
                            Just (Adj b
    _,a
    l,Adj b
    s) -> Char
    '\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 -> 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 Node Bool -> Adj b -> ST RealWorld (Adj b)
    forall s b. STArray s Node Bool -> Adj b -> ST s (Adj b)
    removeDel STArray RealWorld Node Bool
    m Adj b
    s)

    unsafeST :: ST RealWorld a -> a
    unsafeST :: forall a. 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 :: forall a b. ST s (SGr s a b)
    emptyM = Node -> ST s (SGr s a b)
    forall s a b. Node -> ST s (SGr s a b)
    emptyN Node
    defaultGraphSize
      isEmptyM :: forall a b. ST s (SGr s a b) -> ST s Bool
    isEmptyM ST s (SGr s a b)
    g = do {SGr (n,_,_) <- ST s (SGr s a b)
    g; return (n==0)}
      matchM :: forall a b. Node -> ST s (SGr s a b) -> ST s (Decomp (SGr s) a b)
    matchM Node
    v ST s (SGr s a b)
    g = do g'@(SGr (n,a,m)) <- ST s (SGr s a b)
    g
                      case a!v of
                        Context' a b
    Nothing -> Decomp (SGr s) a b -> ST s (Decomp (SGr s) a b)
    forall a. a -> ST s a
    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 b <- STArray s Node Bool -> Node -> ST s Bool
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STArray s Node Bool
    m Node
    v
                              if b then return (Nothing,g') else
                                 do s  <- removeDel m su
                                    p' <- removeDel m pr
                                    let 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'
                                    writeArray m v True
                                    return (Just (p,v,l,s),SGr (n-1,a,m))
      mkGraphM :: forall a b. [LNode a] -> [LEdge b] -> ST s (SGr s a b)
    mkGraphM [LNode a]
    vs [LEdge b]
    es = do m <- (Node, Node) -> Bool -> ST s (STArray s Node Bool)
    forall i. Ix i => (i, i) -> Bool -> ST s (STArray s i Bool)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> e -> m (a i e)
    newArray (Node
    1,Node
    n) Bool
    False
                          return (SGr (n,pr,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 (\(Node
    v,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 (\(Node
    v,Node
    w,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 (\(Node
    v,Node
    w,b
    l)->(Node
    w,(b
    l,Node
    v))) [LEdge b]
    es)
                    bnds :: (Node, Node)
    bnds = ([Node] -> Node
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    minimum [Node]
    vs',[Node] -> Node
    forall a. Ord a => [a] -> a
    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 a. [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 (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 :: forall a b. ST s (SGr s a b) -> ST s [LNode a]
    labNodesM ST s (SGr s a b)
    g = do (SGr (_,a,m)) <- ST s (SGr s a b)
    g
                       let getLNode [(Node, b)]
    vs (Node
    _,Maybe (a, b, c)
    Nothing)      = [(Node, b)] -> m [(Node, b)]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(Node, b)]
    vs
                           getLNode [(Node, b)]
    vs (Node
    v,Just (a
    _,b
    l,c
    _)) =
                               do b <- STArray s Node Bool -> Node -> m Bool
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STArray s Node Bool
    m Node
    v
                                  return (if b then vs else (v,l):vs)
                       foldM getLNode [] (assocs a)

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

    emptyN :: Int -> ST s (SGr s a b)
    emptyN :: forall s a b. Node -> ST s (SGr s a b)
    emptyN Node
    n = do m <- (Node, Node) -> Bool -> ST s (STArray s Node Bool)
    forall i. Ix i => (i, i) -> Bool -> ST s (STArray s i Bool)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> e -> m (a i e)
    newArray (Node
    1,Node
    n) Bool
    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 :: STArray s Node Bool -> Adj b -> ST s (Adj b)
    removeDel :: forall s b. STArray s Node Bool -> Adj b -> ST s (Adj b)
    removeDel STArray s Node Bool
    m = ((b, Node) -> ST s Bool) -> [(b, Node)] -> ST s [(b, Node)]
    forall (m :: * -> *) a.
    Applicative m =>
    (a -> m Bool) -> [a] -> m [a]
    filterM (\(b
    _,Node
    v)->do {b<-STArray s Node Bool -> Node -> ST s Bool
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STArray s Node Bool
    m Node
    v;return (not b)})