{-# LANGUAGE RankNTypes   #-}
module Reanimate.Scene where

import           Control.Monad.ST
import           Control.Monad.ST.Unsafe
import           Data.IORef
import           Data.Map                (Map)
import qualified Data.Map                as Map
import           Data.STRef
import           Debug.Trace
import           Data.Ord
import           Data.List
import           System.IO.Unsafe
import           System.Mem.StableName

import           Reanimate.Monad

data World
type ZIndex = Int

-- (seq duration, par duration)
-- [(Time, Animation, ZIndex)]
-- Map Time [(Animation, ZIndex)]
type Timeline = [(Time, Animation, ZIndex)]
newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, Timeline) }

unionTimeline :: Timeline -> Timeline -> Timeline
unionTimeline = (++)

emptyTimeline :: Timeline
emptyTimeline = []

instance Functor (Scene s) where
  fmap f action = M $ \t -> do
    (a, d1, d2, tl) <- unM action t
    return (f a, d1, d2, tl)

instance Applicative (Scene s) where
  pure a = M $ \_ -> return (a, 0, 0, emptyTimeline)
  f <*> g = M $ \t -> do
    (f', s1, p1, tl1) <- unM f t
    (g', s2, p2, tl2) <- unM g (t+s1)
    return (f' g', s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2)

instance Monad (Scene s) where
  return = pure
  f >>= g = M $ \t -> do
    (a, s1, p1, tl1) <- unM f t
    (b, s2, p2, tl2) <- unM (g a) (t+s1)
    return (b, s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2)

--data Frame a = Frame {unFrame :: Duration -> Time -> State ([Tree] -> [Tree]) a}
sceneAnimation :: (forall s. Scene s a) -> Animation
sceneAnimation action = Animation (max s p) $ Frame $ \d t ->
  sequence_ $ map snd $ sortBy (comparing fst)
    [ (z, unFrame frameGen dur (t-startT))
    | (startT, Animation dur frameGen, z) <- tl
    , startT < t
    , startT+dur > t
    ]
  where
    (_, s, p, tl) = runST (unM action 0)

debug :: String -> Scene s ()
debug msg = M $ \t -> trace msg (return ((), 0, 0, emptyTimeline))

someaction :: Scene s ()
someaction = debug "someaction"

fork :: Scene s a -> Scene s a
fork (M action) = M $ \t -> do
  (a, s, p, tl) <- action t
  return (a, 0, max s p, tl)

play :: Animation -> Scene s ()
play = playZ 0

playZ :: ZIndex -> Animation -> Scene s ()
playZ z ani = M $ \t -> do
  let d = duration ani
  return ((), d, 0, [(t, ani, z)])

queryNow :: Scene s Time
queryNow = M $ \t -> return (t, 0, 0, emptyTimeline)

-- Wait until all forked and sequential animations have finished.
waitAll :: Scene s a -> Scene s a
waitAll (M action) = M $ \t -> do
  (a, s, p, tl) <- action t
  return (a, max s p, 0, tl)

waitUntil :: Time -> Scene s ()
waitUntil tNew = do
  now <- queryNow
  wait (max 0 (tNew - now))

wait :: Duration -> Scene s ()
wait d = M $ \t ->
  return ((), d, 0, emptyTimeline)

adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
adjustZ fn (M action) = M $ \t -> do
  (a, s, p, tl) <- action t
  return (a, s, p, [ (startT, ani, fn z) | (startT, ani, z) <- tl ])

withSceneDuration :: Scene s a -> Scene s Duration
withSceneDuration s = do
  t1 <- queryNow
  s
  t2 <- queryNow
  return (t2-t1)

{-
blackness
show numbers
fade in colormap
slide to middle

do fork $ play $ setDuration 5 showNumbers
      # fadeOut 1 # fadeIn 1
   wait 3

   fork $ do
    playZ (-1) $ setDuration 5 $ revealImage 0 0.5
      # pauseAround 1 1
    playZ (-1) $ setDuration 5 $ revealImage 0.5 1
      # pauseAtEnd 1

   play $ setDuration 5 $ colormap 0 0.5
     # fadeIn 1 # pauseAround 1 1
   play $ setDuration 5 $ colormap 0.5 1
     # fadeOut 1 # pauseAtEnd 1

-}