content: 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;
    import Data.Maybe;
     
    data 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)})}
  