{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, BangPatterns, ScopedTypeVariables,
    FlexibleInstances, PatternGuards, MultiParamTypeClasses #-}

module BoxAnim(initFont, renderBoxAnim, initBoxAnim, FontInfo(..)) where

import Box
import Animation
import Control.Monad.State  hiding (forM, forM_)
import Control.Monad.Writer hiding (forM, forM_)
import Ptr
import Data.Traversable as Traversable
import Data.Foldable as Foldable
import Graphics.Rendering.FTGL as FTGL
import Graphics.UI.GLUT as GLUT hiding (get)

import Poem   -- FIXME: move to app
-- import Data.List
import Image
import Curves
import Control.Applicative
import Control.Monad.Reader   (runReaderT, ReaderT(..))
-- import Control.Monad.State    ()
-- import Control.Monad.Identity ()
import Data.IORef

import Prelude hiding (concat, sum)

import GLtools
import Number

import Data.List.Split

import GHC.Exts (sortWith)

-- Datastructures.

-- An extra data structure passed to the render function of BoxAnim,
-- computed from context/state.
-- boxAnimFade  = boxAnimFPFade  . boxAnimFP

data BoxAnimParams = BoxAnimParams {
  boxAnimTime  :: (Maybe Number), {- Reltime of primbox, Nothing == not alive yet -}
  boxAnimFrame :: Int,            {- Transition frames (backwards, 0 = current) -}
  boxAnimTDelta :: Number         {- Time into current frame (for transition) -}
} deriving Show

data TextBoxSpec = TextBoxSpec {
  textBoxFont   :: FontInfo, 
  textBoxString :: String, 
  textBoxBBox   :: (Maybe (Number, Number)), 
  textBoxAttrs  :: [Attrib]
  }
                   
data ImageBoxSpec = ImageBoxSpec {                   
  imageBoxImg   :: BGImage,
  imageBoxAttrs :: [Attrib]
}

-- Multiple all scaling attributes
textBoxScale tb = execState (forM (textBoxAttrs tb) scal) (1,1) where
  scal (Scale (sx, sy)) = modify (\(x,y) -> (sx * x, sy * y))
  scal _ = return ()
  
-- Meter: take last  
defaultMeterTime = 1.3
defaultMeterIntensity = 1
textBoxMeter tb = execState (forM (textBoxAttrs tb) metr) 
                  [(defaultMeterTime,defaultMeterIntensity)] where  
  metr (Meter m) = put m
  metr _ = return ()

-- Meter is a pair of (Duration, Intensity)
type Duration = Number
type Intensity = Number
type TextBoxMeter = [(Duration,Intensity)]

data BoxAnim = DebugBox BoxDim
             | EmptyBox
             | TextBox  TextBoxSpec 
             | ImageBox ImageBoxSpec

defaultMeter = [(1,1)]
               
instance BoxPrim BoxAnim where
  dimBox = DebugBox
  boxDim (TextBox tb) = BoxVec [sw*w,sh*h] where
    (sw, sh) = textBoxScale tb
    (Just (w, h)) = textBoxBBox tb
  boxDim _ = BoxVec [0,0]


-- More abstract font handling (abstract texture resolution)
data FontInfo = FontInfo (Either (String, Int)               -- not initialized
                                 (Ptr Font_Opaque, Number))   -- initialized

advance (FontInfo (Right (ft, sc))) str = do
  adv <- getFontAdvance ft str
  return $ sc * adv

-- lineHeight (FontInfo ft sc) = sc * getFontAscender ft
lineHeight (FontInfo (Right (ft,sc))) = sc * getFontLineHeight ft

render (FontInfo (Right (ft,sc))) str =
  GLUT.preservingMatrix $ do
    -- color $ Color4 0 0 0 (1 :: Number)
    scale1 $ sc
    renderFont ft str FTGL.All

compileFontInfo (FontInfo (Left (ttf,size))) = do
  putStrLn $ concat [ttf, ": ", show size]
  -- font <- createTextureFont ttf
  font <- createPolygonFont ttf
  setFontFaceSize font size size
  return $ FontInfo $ Right (font, (1 / realToFrac size))

initFont ttf = FontInfo $ Left (ttf, 1000)



-- Scale, fixing corner.  This is  translate . scale . translate-1
-- So basic problem is to make the translate pair.and 20 hours as a tree-planter, or t

-- This seems to be correct, but to make it look pretty it's probably
-- best to use the real bounding box of the text, or some other font
-- metric to avoid the downward zoom to look too much like a
-- translation..

boxScale loc@(BoxVec (x:y:_)) box@(BoxVec (w:h:_)) (cx,cy) scale = loc' where
  loc' = boxVecSum tr $ boxVecScales scale $ boxVecDiff loc tr
  tr = BoxVec [x + cx * w,
               y + cy * h]

-- Map past to t = 0
freezeTime Nothing = 0
freezeTime (Just t) = t

meterTotal = sum . fst . unzip . textBoxMeter


-- scaleCurve t = 1 + t

-- 1st order relaxed step curve is much more natural than linear.
scaleCurve tau s0 s t = s0 + (s - s0) * (1 - exp (- t/tau))

-- Render text box from data produced by layout algo.
renderBoxAnimPrim ((BoxPlaced loc@(BoxVec (x:y:_))
                              dim@(BoxVec (w:h:_))  -- parent-provided box size
                              box@(TextBox tb)),
                   params) = let
  
  -- corner = 2
  -- scale = 2
  
  fontFG = execState (forM attribs scan) 0 where
    scan White = put $ 1
    scan _ = return ()
  
  font = textBoxFont tb
  string = textBoxString tb
  attribs = textBoxAttrs tb
  
  mt    = boxAnimTime  params
  fadeT = boxAnimTDelta params
  t = freezeTime mt
  
  fr = boxAnimFrame params
  (begin, end, fadeSpeed) = lifeTime attribs
  
  -- If last frame then do fade, otherwise not (= timeCo infinite).
  globalTransp = 0.75 -- looks better than solid
  fade = ifte (fr < end)
         globalTransp
         (globalTransp * (exp (-fadeT * fadeSpeed)))

  
  ((scalex,scaley), corner) = parseExpand attribs
  
  -- For convenience attributes are stored in a flat list.  It seems
  -- simplest to just overwrite if there are any duplicates.
  parseExpand as = execState (forM as p) s0 where
    -- Default is expand from centerpoint, baseline
    s0 = ((s,s), (0.5, 0)) where s = scaleCurve 2 0.5 1 t
    p (Expand tc c (ex, ey)) = let
      sx = scaleCurve tc 0.5 ex t
      sy = scaleCurve tc 0.5 ey t
      in do
        put $ ((sx, sy), c)
    p _ = return ()
  

  -- Rate spans the whole text over the meter total.
  mtot = meterTotal tb
  rate = (fromIntegral $ length $ textBoxString tb) / (mtot + 0.1)
  
  -- Bullet chars + duration, mapped to piecewize linear curve:
  --  nB_______/
  --   /  dtB
  -- nB:  Number of chars to show in initial pass == bullet
  -- dtB :Number of seconds to wait after initial pass
  (nB,dtB,rateRest) = parseBullet attribs
  parseBullet as = execState (forM as p) s0 where
    s0 = (0,0,rate)
    p (Bullet nB dtB rateRest) = put $ (nB,dtB,rateRest)
    p _ = return ()


  tB0 = nB / rate  -- Time corresponding to nB
  tInf  = 100  -- Large enough to be infinite wrt. dtB
  curve = [(0,                 0),
           (tB0,               nB),
           (tB0 + dtB,         nB),
           (tB0 + dtB + tInf,  nB + tInf * rateRest)]
  nbChars = floor $ pwlEval curve t 
  
  (sx, sy) = textBoxScale tb
  -- (sx, sy) = (t, t)

  BoxVec (x':y':_) =
    boxScale loc (boxDim box) corner [scalex, scaley]
  sx' = sx * scalex
  sy' = sy * scaley
  c = fontFG
  in do
    GLUT.preservingMatrix $ do
      trans2 x' y'
      scale2 sx' sy'
      GLUT.color $ GLUT.Color4 c c c fade
      withBlend $
        render font $ take nbChars string  

  
renderBoxAnimPrim ((BoxPlaced loc dim' (DebugBox dim)), _) = do
  debugRender loc dim
  debugRender loc dim'
  return ()

-- FIXME: fit to box, keeping aspect ratio
renderBoxAnimPrim ((BoxPlaced loc (BoxVec (w:h:_)) (ImageBox (ImageBoxSpec img attrs))), params) = let
  -- fade = 0.6 -- FIXME! boxAnimFade params  
  aspect = bgImageAspect img 
  -- Center image, max zoom, depending on aspect.
  (w',h',dx,dy) = ifte (aspect > w/h) keepWidth keepHeight where
    w' = h * aspect
    h' = w / aspect
    keepWidth  = (w,  h', 0, (h - h')/2)
    keepHeight = (w', h,  (w - w')/2 , 0)

  box' = BoxVec [w',h']
  loc' = boxVecSum loc $ BoxVec [dx,dy]
  
  scale0 = 1.5 -- Centered scale: FIXME: from attribs
  scale1 = 0  -- Zoomout scale
  scaleTime _ Nothing  = scale0
  scaleTime tc (Just t) = scale0 + (scale1 - scale0) * (exp (-(t / tc)))

  s = case doZoom of
    Nothing -> scale0
    Just tc -> scaleTime tc mt
  doZoom = execState (forM attrs scan) Nothing where
    scan (Zoom tc) = put $ Just tc
    scan _ = return ()



  s2 = [s,s]
  loc'' = boxScale loc' box' (0.5, 0.5) s2
  box'' = boxVecScales s2 box'
  
  
  
  -- Step curve for interpolation.
  flashCurve t dt  = [(0,0),(t,0),(t,1),(t + dt,1),(t + dt,0)]
  effect = pwlEval $ flashCurve 1 0.1
  
  effectI a b t = a + (b - a) * (effect t)
  
  imageFlash = execState (forM attrs scan) False where
    scan Flash = put $ True
    scan _ = return ()
  
  
  zeroAlpha = 0.0 :: Number
  fullAlpha = 1.0 :: Number
  halfAlpha = 0.5 :: Number
  transAlpha begin end t = end + ((begin - end) * exp (-t))
  
  
{-  
  HACK:
  nbTiles > 5       : draws all tiles and doesn't perform alpha blending
         == 5       : fades all tiles from 1/2 -> 1
         == 1,2,3,4 : fades tile from 0 -> 1/2
-}
  
  colori c a = GLUT.color $ GLUT.Color4 c c c a 
  imgColor n t = ifte imageFlash 
                 (colori (effectI 0 1 t) (effectI 1.0 fullAlpha t))
                 (ifte (nbTiles > 5)
                  (colori 1 fullAlpha)
                  (ifte (5 == nbTiles)
                   (colori 1 $ transAlpha halfAlpha fullAlpha t)
                   (ifte (n == nbTiles)
                    (colori 1 $ transAlpha zeroAlpha halfAlpha t)
                    (colori 1 halfAlpha))))
                  
               
      
  drawTile n t bl tr = do
    imgColor n t
    drawBGImageTile bl tr  loc'' box'' img
    

  nbTiles = execState (forM attrs scan) 100 where
    scan (NbTiles n) = put n
    scan _ = return ()
  
  render (Just t) = do
    when (nbTiles >= 1) $ drawTile 1 t (1/2, 1/2) (1,1)
    when (nbTiles >= 2) $ drawTile 2 t (0,0)      (1/2,1/2) 
    when (nbTiles >= 3) $ drawTile 3 t (1/2, 0)   (1,1/2)   
    when (nbTiles >= 4) $ drawTile 4 t (0,1/2)    (1/2,1)   
  render Nothing = return ()
    
  mt = boxAnimTime params  
  
  in do (render mt)

renderBoxAnimPrim _ = return ()


debugRender (BoxVec (x:y:_)) (BoxVec (w:h:_)) =
  GLUT.preservingMatrix $ do
    color $ Color4 0 0 0 (1 :: Number)
    trans2 x y
    GLUT.renderPrimitive GLUT.LineStrip $ do
      vert2 0 0
      vert2 w 0
      vert2 w h
      vert2 0 h
      --
      vert2 0 0
      vert2 w h

  
-- The animation context consists of a mutable part (state) and an
-- immutable part (i.e. the box datastructure).  This function updates
-- the mutable part.  It also contains a part only used by the
-- renderer.  In short, the generic state update s->s is actuall
-- (s,i)->(s,o) and the input of rendering is (s,i,o)
 

type TypingCurve = Number -> Number
-- type Duration = Number
data FrameParams = FrameParams Duration
defaultFrameParams = FrameParams 5.0

data Frame    = Frame Int Number -- Frame number and time offset
data BoxState = BoxState [Frame] -- Current and previous frames
initBoxAnimState box = (box, BoxState [(Frame 0 0)], undefined)
 
ifte True x _ = x
ifte False _ x = x

-- Compiling an animation needs state for counting characters and
-- environment for local context.
data BoxAnimEnv = BoxAnimEnv [String]
type CharacterCount = Int
type BAM = ReaderT BoxAnimEnv (State CharacterCount)

runBAM :: BAM (Box BoxAnim) -> Box BoxAnim
runBAM m = evalState (runReaderT m initBoxAnimEnv) initCharacterCount where
  initBoxAnimEnv = BoxAnimEnv []
  initCharacterCount = 0


-- Given a piecewize linear curve and a current time, a list of placed
-- boxes, construct a list of integers that represents the number of
-- letters to typeset.
  
-- n-th order discontinuities
step0 x x0 = ifte (x >= x0) 1 0
step1 x x0 = ifte (x >= x0) (x-x0) 0
  


-- Distribute time evolution over TextBoxes: each TextBox has a local
-- timeframe that is activated after the read pointer reaches the box.
-- Note that Maybe is used here to allow for causal systems.

-- In addition to distributing time, this also decides whether to
-- render a box or not.  When time is Nothing, it won't be rendered.
  
lifeTime attrs = execState (forM attrs p) (0,0,0) where
  p (LifeTime begin end speed) = put $ (begin, end, speed)
  p _ = return ()

boxParams pastFrame tTrans tFrame boxAnims = (boxTimes, totalTime) where
  retMtime mtime = return $ BoxAnimParams mtime pastFrame tTrans
  (boxTimes, totalTime) = runState (forM boxAnims distrib) 0
  distrib (TextBox tb) = do
    tBox <- get
    let meter = textBoxMeter tb 
        (dts, _) = unzip meter
        dt = sum dts
        (begin,end,_) = lifeTime $ textBoxAttrs tb
        
        mtime = ifte ((tFrame >= tBox) && (begin <= pastFrame) && (pastFrame <= end))
                (Just $ tFrame - tBox) 
                Nothing      

      in do
      modify (+ dt)
      retMtime mtime
  distrib (ImageBox ib) = let
    (begin,end,_) = lifeTime $ imageBoxAttrs ib
    drawIt = (begin <= pastFrame) && (pastFrame <= end)
    -- Render only current ImageBox
    in retMtime $ ifte drawIt (Just tFrame) Nothing
    
  distrib _ = retMtime $ Nothing


processEvents evts = i where
  next = modify $ (1 +)
  prev = modify $ (-1 +) 
  scan ((SpecialKey KeyUp),   Down, _, _) = prev
  scan ((SpecialKey KeyDown), Down, _, _) = next
  scan ((Char ' '), Down, _, _) = next
  scan _ = return ()
  i = execState (forM_ evts scan) 0

  

updateBoxAnim (context, (BoxState frames'@(current'@(Frame i' t0'):past')), _) = do
  evts <- aEvents  -- keyboard events
  (Time t _) <- aTime  
  let -- Compute next content frame (!= animation frame)
      (box', FrameParams tFrame) = context !! i'
      
      -- Foreground's time duration
      tTotal = tFrame + tText
      tText = execState (forM box' scanTime) 0 where
        scanTime (TextBox tb) = modify (+ (meterTotal tb))
        scanTime _ = return ()
      
      -- Compute frame for transition
      iE = processEvents evts           -- nb to fwd/rev due to keyboard
      iT = ifte (t-t0' > tTotal) 1 0    -- advance if time tFrame expired
      i = mod (i' + iE + iT)     
              (length context)          -- at end, start from beginning
      
  
  
      -- Perform transition
      frames@(Frame i0 t0 : _) = ifte (i /= i')
                                 (ifte (iT >= 0)   -- only transition if no back key
                                       (Frame i t : frames') 
                                       [Frame i t])
                                 frames'
      
      -- Foreground's time frame.
      tDelta = t-t0
      

      -- Produce flat renderscript from frame's Box.
      renderFrame pastFrame (Frame i tf) = renderScript where
        -- Get the current frame + perform layout.
        (box, _) = context !! i
        (w,h) = (38,20)
        layout = boxLayoutTop (BoxVec [-w/2,-h/2]) (BoxVec [w,h]) box
        -- FIXME: no param-dependent layout
  
        -- Create local time frame for each primitive box.
        prims = map boxPlacedPrim layout   -- list of primitives
        (params, totalTime) = boxParams pastFrame tDelta (t-tf) prims
      
        -- wrap all in params struct      
        renderScript = zip layout params      


      scripts = zipWith renderFrame [0..] frames
      
      -- Always render older frames first, and render images before
      -- textboxes to get proper alpha blending: it uses "glass
      -- layers" instead of "light accum".
      
      rankBox (BoxPlaced _ _ (ImageBox _), _) = 0
      rankBox _ = 1
      
      renderScript = sortWith rankBox $ concat $ (reverse scripts)
      
      
    in do
    return (context, (BoxState $ take 6 frames), renderScript)

  
{-
words box = concat $ forM getWords box where
  getWords (TextBox tb) = return $ splitWords $ textBoxString tb
  splitWords = undefined
-}

  

-- The renderer.  The idea is to put all the logic in the update method

renderBoxAnim (context, state, script) = do
  scale1 (1 / 22)  -- Screen width is 20
  forM_ script $
    \params -> GLUT.preservingMatrix $ renderBoxAnimPrim params



boxAlignFracs n f  = take n $ repeat $ BoxAlignFrac f
boxAlignInherits n = take n $ repeat $ BoxAlignInherit
                          
boxImage attrs file = BoxPrim $ ImageBox $ ImageBoxSpec (BGImage file Nothing) attrs

type BT = Box BoxAnim
type BTM = StateT (BT) (Writer [(BT, FrameParams)])


instance (Poem.Layout BTM BT FontInfo BoxAlign) where

  empty = BoxPrim $ EmptyBox
  
  font ttf = return $ initFont ttf
  
  rows    align lines = BoxMatrix
                        [align]
                        (boxAlignInherits $ length lines)
                        (map (:[]) $ reverse lines)
                        
  columns align lines = BoxMatrix 
                        (boxAlignInherits $ length lines)
                        [align]
                        [reverse lines]
                        
  matrix aligns mtx = BoxMatrix 
                      aligns
                      (boxAlignInherits $ length mtx)
                      (reverse mtx)

  grouping = BoxAlignInherit
  
  left     = BoxAlignFrac 0.0
  center   = BoxAlignFrac 0.5
  right    = BoxAlignFrac 1.0

  texta attrs = textScale attrs 2 2
  
  imagea attrs (Just fileName) = put $ boxImage attrs fileName
  imagea _ Nothing = put $ BoxPrim EmptyBox
  
  framea tTime el = do
    img <- get
    tell [(BoxLayers [el, img],  FrameParams tTime)]

instance Show (BoxAnim) where
  show (TextBox tb) = 
    concat ["(TextBox ",show $ textBoxString tb, ")"]

textScale attrs x y font str = 
  BoxPrim $ TextBox (TextBoxSpec font str Nothing (Scale (x,y):attrs))
texts1 s = textScale [] s s 

testTB = texts1 1 (FontInfo $ Left ("foo", -1))
  

{-
allWords box = s where
  (_, s) = runWriter $ forM_ box (tell . (:[]) . textBoxString)
           
testwords = allWords $ testBox4 undefined
-}



-- Some ops need to happen in the IO monad.  I tried unsafePerformIO
-- before but that caused all kinds of weirdness, so we cache results
-- here.

-- FIXME: bound to IORef: later also other kinds of references?
cacheCompile :: IORef [(String, a)] -> (a -> IO a) -> String -> a -> IO a
cacheCompile cache compile name val = mv where
  c (Just val) = return val
  c Nothing = do
    val' <- compile val
    modifyIORef cache ((name, val'):)
    return val'
  mv = readIORef cache >>= (c . (lookup name))
  
compileBoxAnimPrim (_, fonts) (TextBox (TextBoxSpec font@(FontInfo (Left (fontFile, _))) text _ attrs)) = do
  font' <- cacheCompile fonts compileFontInfo fontFile font
  w <- advance font' text
  h <- return $ lineHeight font'
  return $ TextBox (TextBoxSpec font' text (Just (w,h)) attrs)

compileBoxAnimPrim (texs, _) (ImageBox (ImageBoxSpec img@(BGImage fileName _) attrs)) =
  imageBox <$> cacheCompile texs uploadTextureRGB fileName img where
    imageBox i = ImageBox (ImageBoxSpec i attrs)
  
   

compileBoxAnimPrim _ p = return p

compileBoxAnim caches box = forM box $ compileBoxAnimPrim caches


-- Script animation: bundles state update + renderer
initBoxAnim = do
  -- Since we're already in IO, no need to add other monad to keep track of state..
  fonts    <- newIORef []
  textures <- newIORef []  

  frames <- forM (execWriter (evalStateT poem $ BoxPrim EmptyBox))
            (\(box, frameParams) -> do
                box' <- compileBoxAnim (textures, fonts) box
                return $ (box', frameParams))
                     
  return $ PrimAnim updateBoxAnim renderBoxAnim (initBoxAnimState frames)