import Ix
import qualified Array
import Data.Array.IO
import Data.Array.MArray
import Data.IORef
import System.IO.Unsafe
import Monad
import Maybe

-- finta 2 -- lina pole
-- pole line jak v prvcich, tak v indexech
-- seznam prvku pole je cten postupne, jen do okamziku, kdy je nalezena hodnota
--   na danem indexu (dalsi hodnoty v danem indexu jsou ignorovany)

type Vertex = Int
type Graph = Array.Array Vertex [Vertex]
type Marks = LazyArray Vertex Vertex -- pro kazdy vrchol si pamatujeme cislo vrcholu,
                                     -- z nejz jsme do nej prisli

data Tree a = Node a [Tree a] deriving (Show)

dfs::Graph->[Vertex]->[Tree Vertex]
dfs g q = forest
  where
    (edges, forest) = pruneForest (l - 1) marks infForest
    (l,h) = bounds g
    marks = lazyArray (l, h) edges
    infForest = map (search g) q

search::Graph->Vertex->Tree Vertex
search g v = Node v $ map (search g) (g Array.! v)

pruneForest::Vertex->Marks->[Tree Vertex]->([(Vertex, Vertex)], [Tree Vertex])
pruneForest _ _ [] = ([], [])
pruneForest from m (Node v s : t) = ((v, from) : es, forr)
  where
    (es, forr) =
       if laGet m v /= from
         then pruneForest from m t
         else let (es1, s') = pruneForest v m s
                  (es2, t') = pruneForest from m t in
                  (es1 ++ es2, Node v s' : t')


tg::Graph
tg = Array.array (1,6) [(1,[2,5]),
                  (2,[3]),
                  (3,[4]),
                  (4,[1,2]),
                  (5,[4]),
                  (6,[1,5])]

type LazyArray i e = IORef (LAShared i e)
data LAShared i e = LA {laRest::[(i,e)], laArray::IOArray i (Maybe e)}

lazyArray b e = unsafePerformIO (lazyArrayIO b e)
lazyArrayIO :: Ix i => (i,i)->[(i,e)]->IO (LazyArray i e)
lazyArrayIO bnds elts = 
  do
    arr <- newArray bnds Nothing
    newIORef LA {laRest = elts, laArray = arr}

laGet a i = unsafePerformIO (laGetIO a i)
laGetIO a i =
  do
    LA {laRest=rest, laArray = arr} <- readIORef a
    elt <- readArray arr i
    case elt of
      Just e -> return e
      Nothing ->
        do
          rest' <- processTill i arr rest
          writeIORef a LA {laRest = rest', laArray = arr}
          Just x <- readArray arr i
          return x

processTill::Ix i => i -> IOArray i (Maybe e) -> [(i,e)]->IO [(i,e)]
processTill i arr [] =
  do
    writeArray arr i (Just undefined)
    return []
processTill i arr ((j,e):t)
  | i == j =
     do
       writeArray arr i (Just e)
       return t
  | otherwise =
     do
       val <- readArray arr j
       when (isNothing val) $ writeArray arr j (Just e)
       processTill i arr t