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