{-# LANGUAGE GADTs, RankNTypes, DataKinds, KindSignatures #-}

module Graphics.Rendering.Ombra.Layer.Internal where

import Data.Word (Word8)
import Control.Monad (when)
import Graphics.Rendering.Ombra.Color
import Graphics.Rendering.Ombra.Internal.GL hiding (Buffer, Texture)
import qualified Graphics.Rendering.Ombra.Internal.GL as GL
import Graphics.Rendering.Ombra.Internal.TList
import Graphics.Rendering.Ombra.Internal.Resource
import Graphics.Rendering.Ombra.Layer.Types
import Graphics.Rendering.Ombra.Object.Internal
import Graphics.Rendering.Ombra.Object.Types
import Graphics.Rendering.Ombra.Screen
import Graphics.Rendering.Ombra.Shader.Program
import Graphics.Rendering.Ombra.Texture.Internal
import Graphics.Rendering.Ombra.Texture.Types

-- TODO: document buffers.
-- | Layer that clear some buffers. For instance, @clear ['ColorBuffer']@ fills
-- the screen with a black rectangle, without affecting the depth buffer.
clear :: [Buffer] -> Layer' s t ()
clear = Clear

-- | Free the temporary resources associated with a NonDrawable layer, before
-- drawing it.
drawable :: (forall t. Layer' NonDrawable t a) -> Layer' s t a
drawable = Free

castDrawable :: Layer' Drawable t a -> Layer' Drawable t' a
castDrawable = Cast

-- | Make the type of a simple 'Layer' more generic.
castLayer :: Layer -> Layer' Drawable t ()
castLayer = castDrawable

-- | Make a 'TTexture' permanent. Its lifetime is still bound to the 'Texture'
-- returned.
permanent :: TTexture t -> Layer' NonDrawable t Texture
permanent = Permanent

-- | Draw a Layer using a temporary texture.
withTTexture :: TTexture t -> (Texture -> Layer) -> Layer' NonDrawable t ()
withTTexture pt f = WithTTextures [pt] $ \[t] -> f t

-- | Draw a Layer using a list of temporary textures.
withTTextures :: [TTexture t] -> ([Texture] -> Layer) -> Layer' NonDrawable t ()
withTTextures = WithTTextures

castTTexture :: TTexture t -> TTexture t'
castTTexture (TTexture lt) = TTexture lt

-- | Draw a 'Layer' to a depth 'Texture'.
depthToTexture :: Int           -- ^ Textures width.
               -> Int           -- ^ Textures height.
               -> Layer' s t a  -- ^ Layer to draw.
               -> Layer' NonDrawable t (a, TTexture t)
depthToTexture w h l =
        fmap (\(x, [t], _, _) -> (x, t)) $
                TextureLayer False [DepthLayer] (w, h) (0, 0, 0, 0)
                             False False l

-- | Draw a 'Layer' to a color 'Texture' and a depth 'Texture'.
colorDepthToTexture :: Int              -- ^ Textures width.
                    -> Int              -- ^ Textures height.
                    -> Layer' s t a     -- ^ Layer to draw.
                    -> Layer' NonDrawable t (a, TTexture t, TTexture t)
colorDepthToTexture w h l =
        fmap (\(x, [ct, dt], _, _) -> (x, ct, dt)) $
                TextureLayer False [ColorLayer, DepthLayer] (w, h) (0, 0, 0, 0)
                             False False l

-- | Draw a 'Layer' to a color 'Texture' with an additional stencil buffer.
colorStencilToTexture :: Int -- ^ Texture width.
                      -> Int -- ^ Texture height.
                      -> Layer' s t a
                      -> Layer' NonDrawable t (a, TTexture t)
colorStencilToTexture w h l =
        fmap (\(x, [ct, _], _, _) -> (x, ct)) $
                TextureLayer False [ColorLayer, DepthStencilLayer] (w, h)
                             (0, 0, 0, 0) False False l

-- | Draw a 'Layer' to a 'Texture', reading the content of the texture.
colorToTexture' :: Int          -- ^ Texture width.
                -> Int          -- ^ Texture height.
                -> Int          -- ^ First pixel to read X.
                -> Int          -- ^ First pixel to read Y.
                -> Int          -- ^ Width of the rectangle to read.
                -> Int          -- ^ Height of the rectangle to read.
                -> Layer' s t a -- ^ Layer to draw.
                -> Layer' NonDrawable t (a, TTexture t, [Color])
colorToTexture' w h rx ry rw rh l =
        fmap (\(x, [t, _], Just c, _) -> (x, t, c)) $
                TextureLayer False [ColorLayer, DepthLayer] (w, h)
                             (rx, ry, rw, rh) True False l

-- | Draw a 'Layer' to a depth 'Texture', reading the content of the texture.
-- Not supported on WebGL.
depthToTexture' :: Int          -- ^ Texture width.
                -> Int          -- ^ Texture height.
                -> Int          -- ^ First pixel to read X.
                -> Int          -- ^ First pixel to read Y.
                -> Int          -- ^ Width of the rectangle to read.
                -> Int          -- ^ Height of the rectangle to read.
                -> Layer' s t a -- ^ Layer to draw.
                -> Layer' NonDrawable t (a, TTexture t, [Word8])
depthToTexture' w h rx ry rw rh l =
        fmap (\(x, [t], _, Just d) -> (x, t, d)) $
                TextureLayer False [DepthLayer] (w, h) (rx, ry, rw, rh)
                             False True l

-- | Combination of 'colorToTexture'' and 'depthToTexture''. Not supported
-- on WebGL.
colorDepthToTexture' :: Int             -- ^ Texture width.
                     -> Int             -- ^ Texture height.
                     -> Int             -- ^ First pixel to read X.
                     -> Int             -- ^ First pixel to read Y.
                     -> Int             -- ^ Width of the rectangle to read.
                     -> Int             -- ^ Height of the rectangle to read.
                     -> Layer' s t a    -- ^ Layer to draw.
                     -> Layer' NonDrawable t
                               (a, TTexture t, TTexture t, [Color], [Word8])
colorDepthToTexture' w h rx ry rw rh l =
        fmap (\(x, [ct, dt], Just c, Just d) -> (x, ct, dt, c, d)) $
                TextureLayer False [ColorLayer, DepthLayer] (w, h)
                             (rx, ry, rw, rh) True True l

-- | 'colorToTexture'' with an additional stencil buffer.
colorStencilToTexture' :: Int           -- ^ Texture width.
                       -> Int           -- ^ Texture height.
                       -> Int           -- ^ First pixel to read X.
                       -> Int           -- ^ First pixel to read Y.
                       -> Int           -- ^ Width of the rectangle to read.
                       -> Int           -- ^ Height of the rectangle to read.
                       -> Layer' s t a  -- ^ Layer to draw.
                       -> Layer' NonDrawable t (a, TTexture t, [Color])
colorStencilToTexture' w h rx ry rw rh l =
        fmap (\(x, [t, _], Just c, _) -> (x, t, c)) $
                TextureLayer False [ColorLayer, DepthStencilLayer] (w, h)
                             (rx, ry, rw, rh) True False l

-- | Draw a 'Layer' with multiple floating point colors
-- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's and to a depth
-- Texture.
buffersDepthToTexture :: Int            -- ^ Texture width.
                      -> Int            -- ^ Texture height.
                      -> Int            -- ^ Number of colors.
                      -> Layer' s t a   -- ^ Layer to draw.
                      -> Layer' NonDrawable t (a, [TTexture t], TTexture t)
buffersDepthToTexture w h n l =
        fmap (\(x, dt : ts, _, _) -> (x, ts, dt)) $
                TextureLayer True (DepthLayer : map BufferLayer [0 .. n - 1])
                             (w, h) (0, 0, 0, 0) False False l

-- | Draw a 'Layer' with multiple floating point colors
-- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's with an additional
-- stencil buffer.
buffersStencilToTexture :: Int          -- ^ Texture width.
                        -> Int          -- ^ Texture height.
                        -> Int          -- ^ Number of colors.
                        -> Layer' s t a -- ^ Layer to draw.
                        -> Layer' NonDrawable t (a, [TTexture t])
buffersStencilToTexture w h n l =
        fmap (\(x, _ : ts, _, _) -> (x, ts)) $
                TextureLayer True
                             (DepthStencilLayer : map BufferLayer [0 .. n - 1])
                             (w, h) (0, 0, 0, 0) False False l

clearBuffers :: (GLES, MonadGL m) => [Buffer] -> m ()
clearBuffers = mapM_ $ gl . GL.clear . buffer
        where buffer ColorBuffer = gl_COLOR_BUFFER_BIT
              buffer DepthBuffer = gl_DEPTH_BUFFER_BIT
              buffer StencilBuffer = gl_STENCIL_BUFFER_BIT

-- | Draw a 'Layer'.
drawLayer :: MonadObject m => Layer' Drawable t a -> m a
drawLayer = fmap fst . flip drawLayer' []

drawLayer' :: MonadObject m
           => Layer' s t a
           -> [TTexture t]
           -> m (a, [TTexture t])
drawLayer' (Layer prg grp) ts = do setProgram prg
                                   drawObject grp
                                   return ((), ts)
drawLayer' (TextureLayer drawBufs stypes (w, h) (rx, ry, rw, rh)
                         inspCol inspDepth layer) tts0 =
        do (x, tts1, ts, mcol, mdepth) <-
                layerToTexture drawBufs stypes w h layer
                               (mayInspect inspCol) (mayInspect inspDepth) tts0
           let tts2 = map (TTexture . LoadedTexture gw gh) ts
           return ((x, tts2, mcol, mdepth), tts1 ++ tts2)
        where (gw, gh) = (fromIntegral w, fromIntegral h)
        
              mayInspect :: Monad m
                         => Bool
                         -> Either (Maybe [r])
                                   ([r] -> m (Maybe [r]), Int, Int, Int, Int)
              mayInspect True = Right (return . Just, rx, ry, rw, rh)
              mayInspect False = Left Nothing
drawLayer' (Permanent tt@(TTexture lt)) tts = 
        do let t = TextureLoaded lt
           gl $ unloader t (Nothing :: Maybe TextureImage) lt
           return (t, filter (/= tt) tts)
drawLayer' (WithTTextures ets f) tts =
        do drawLayer . f $ map (\(TTexture lt) -> TextureLoaded lt) ets
           return ((), tts)
drawLayer' (Free layer) tts =
        do (x, tts') <- drawLayer' layer []
           mapM_ (\(TTexture lt) -> unusedTexture lt) tts'
           return (x, tts)
drawLayer' (Clear bufs) tts = clearBuffers bufs >> return ((), tts)
drawLayer' (Cast layer) tts =
        do (x, tts') <- drawLayer' layer $ map castTTexture tts
           return (x, map castTTexture tts')
drawLayer' (Bind lx f) tts0 = drawLayer' lx tts0 >>=
                                \(x, tts1) -> drawLayer' (f x) tts1
drawLayer' (Return x) tts = return (x, tts)

-- | Draw a 'Layer' on some textures.
layerToTexture :: (GLES, Integral a, MonadObject m)
               => Bool                                  -- ^ Draw buffers
               -> [LayerType]                           -- ^ Textures contents
               -> a                                     -- ^ Width
               -> a                                     -- ^ Height
               -> Layer' s t x                          -- ^ Layer to draw
               -> Either b ( [Color] -> m b
                           , Int, Int, Int, Int)        -- ^ Color inspecting
                                                        -- function, start x,
                                                        -- start y, width,
                                                        -- height
               -> Either c ( [Word8] -> m c
                           , Int, Int, Int, Int)        -- ^ Depth inspecting,
                                                        -- function, etc.
               -> [TTexture t]
               -> m (x, [TTexture t], [GL.Texture], b ,c)
layerToTexture drawBufs stypes wp hp layer einspc einspd tts = do
        (ts, (x, tts', colRes, depthRes)) <-
                renderToTexture drawBufs (map arguments stypes) w h $
                        do (x, tts') <- drawLayer' layer tts
                           colRes <- inspect einspc gl_RGBA wordsToColors 4
                           depthRes <- inspect einspd gl_DEPTH_COMPONENT id 1
                           return (x, tts', colRes, depthRes)

        return (x, tts', ts, colRes, depthRes)

        where (w, h) = (fromIntegral wp, fromIntegral hp)
              arguments stype =
                        case stype of
                              ColorLayer -> ( fromIntegral gl_RGBA
                                            , gl_RGBA
                                            , gl_UNSIGNED_BYTE
                                            , gl_COLOR_ATTACHMENT0
                                            , [ColorBuffer] )
                              DepthLayer -> ( fromIntegral gl_DEPTH_COMPONENT
                                            , gl_DEPTH_COMPONENT
                                            , gl_UNSIGNED_SHORT
                                            , gl_DEPTH_ATTACHMENT
                                            , [DepthBuffer] )
                              DepthStencilLayer -> ( fromIntegral
                                                        gl_DEPTH_STENCIL
                                                   , gl_DEPTH_STENCIL
                                                   , gl_UNSIGNED_INT_24_8
                                                   , gl_DEPTH_STENCIL_ATTACHMENT
                                                   , [ DepthBuffer
                                                     , StencilBuffer]
                                                   )
                              BufferLayer n -> ( fromIntegral gl_RGBA32F
                                               , gl_RGBA
                                               , gl_FLOAT
                                               , gl_COLOR_ATTACHMENT0 + 
                                                 fromIntegral n
                                               , [] )

              inspect (Left r) _ _ _ = return r
              inspect (Right (insp, x, y, rw, rh)) format trans s =
                        do arr <- liftIO . newByteArray $
                                        fromIntegral rw * fromIntegral rh * s
                           gl $ readPixels (fromIntegral x)
                                           (fromIntegral y)
                                           (fromIntegral rw)
                                           (fromIntegral rh)
                                           format gl_UNSIGNED_BYTE arr
                           liftIO (decodeBytes arr) >>= insp . trans
              wordsToColors (r : g : b : a : xs) = Color r g b a :
                                                   wordsToColors xs
              wordsToColors _ = []

renderToTexture :: (GLES, MonadObject m)
                => Bool
                -> [(GLInt, GLEnum, GLEnum, GLEnum, [Buffer])]
                -> GLSize
                -> GLSize
                -> m a
                -> m ([GL.Texture], a)
renderToTexture drawBufs infos w h act = do
        fb <- gl createFramebuffer 
        gl $ bindFramebuffer gl_FRAMEBUFFER fb

        (ts, attchs, buffersToClear) <- fmap unzip3 . flip mapM infos $
                \(internalFormat, format, pixelType, attachment, buffer) ->
                        do LoadedTexture _ _ t <- newTexture (fromIntegral w)
                                                             (fromIntegral h)
                                                             (Nearest, Nothing)
                                                             Nearest
                           gl $ bindTexture gl_TEXTURE_2D t
                           if pixelType == gl_FLOAT
                           then liftIO noFloat32Array >>=
                                        gl . texImage2DFloat gl_TEXTURE_2D 0
                                                             internalFormat w h
                                                             0 format pixelType
                           else liftIO noUInt8Array >>=
                                        gl . texImage2DUInt gl_TEXTURE_2D 0
                                                            internalFormat w h
                                                            0 format pixelType
                           gl $ framebufferTexture2D gl_FRAMEBUFFER attachment
                                                     gl_TEXTURE_2D t 0
                           return (t, fromIntegral attachment, buffer)

        let buffersToDraw = filter (/= fromIntegral gl_DEPTH_ATTACHMENT) attchs
        when drawBufs $ liftIO (encodeInts buffersToDraw) >>= gl . drawBuffers

        (sw, sh) <- currentViewport
        resizeViewport (fromIntegral w) (fromIntegral h)

        clearBuffers $ concat buffersToClear
        ret <- act

        resizeViewport sw sh
        gl $ deleteFramebuffer fb

        return (ts, ret)