{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
# LANGUAGE PartialTypeSignatures #
{-# LANGUAGE ScopedTypeVariables   #-}
module Gelatin.GL.Renderer (
    -- * Renderer
    Renderer2,
    Context(..),
    -- * Loading and using textures
    allocAndActivateTex,
    initializeTexImage2D,
    loadImage,
    maybeLoadTexture,
    loadTexture,
    loadTextureUnit,
    unloadTexture,
    loadImageAsTexture,
    bindTexsAround,
    bindTexAround,
    -- * Line rendering
    colorPolylineRenderer,
    texPolylineRenderer,
    -- * Triangle rendering
    colorRenderer,
    textureRenderer,
  *  rendering
    colorBezRenderer,
    textureBezRenderer,
    -- * Masking
    maskRenderer,
    stencilMask,
    alphaMask,
    -- * Transforming a rendering
    transformRenderer,
    -- * Utils
    toTexture,
    toTextureUnit,
    clipTexture
) where

import           Codec.Picture          (readImage)
import           Codec.Picture.Types
import           Control.Exception      (assert)
import           Control.Monad
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Reader   (ReaderT (..))
import qualified Data.Foldable          as F
import           Data.Proxy             (Proxy (..))
import qualified Data.Vector.Generic    as G
import qualified Data.Vector.Storable   as S
import           Data.Vector.Unboxed    (Unbox, Vector)
import qualified Data.Vector.Unboxed    as V
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           Gelatin
import           Gelatin.GL.Common
import           Gelatin.GL.Shader
import           Gelatin.Shaders
import           Graphics.GL.Core33
import           Graphics.GL.Types
import           System.Exit

--------------------------------------------------------------------------------
-- Uniform updates for the Simple2DShader
--------------------------------------------------------------------------------
updatePrimitive :& updateProjection :& updateModelView :& updateThickness :&
  updateFeather :& updateSumLength :& updateCap :& updateHasUV :& updateSampler :&
  updateMainTex :& updateMaskTex :& updateAlpha :& updateMultiply :&
  updateShouldReplaceColor :& updateReplacementColor :& ()
  = genFunction (Proxy :: Proxy Simple2DUniforms)
--------------------------------------------------------------------------------
-- Attribute toggling
--------------------------------------------------------------------------------
(enablePosition, disablePosition) :& (enableColor, disableColor) :&
  (enableUV, disableUV) :& (enableBez, disableBez) :&
  (enableBezUV, disableBezUV) :& (enablePrev, disablePrev) :&
  (enableNext, disableNext) :& ()
  = genFunction (Proxy :: Proxy Simple2DAttribToggles)

disableAll :: IO ()
disableAll =
  sequence_ [ disablePosition, disableColor, disableUV, disableBez, disableBezUV
            , disablePrev, disableNext
            ]

--enableAll :: IO ()
--enableAll =
--  sequence_ [ enablePosition, enableColor, enableUV, enableBez, enableBezUV
--            , enablePrev, enableNext
--            ]

enableAttribsForLines :: Bool -> IO ()
enableAttribsForLines hasUV = do
  disableAll
  enablePosition
  enableBezUV
  enablePrev
  enableNext
  if hasUV
    then enableUV
    else enableColor

enableAttribsForTris :: Bool -> IO ()
enableAttribsForTris hasUV =
  disableAll >> enablePosition >> if hasUV then enableUV
                                           else enableColor

enableAttribsForBezs :: Bool -> IO ()
enableAttribsForBezs hasUV =
  disableAll >> enablePosition >> enableBez >> if hasUV then enableUV
                                                        else enableColor

enableAttribsForMask :: IO ()
enableAttribsForMask = disableAll >> enablePosition >> enableUV
--------------------------------------------------------------------------------
-- Attribute buffering
--------------------------------------------------------------------------------
bufferPosition :& bufferColor :& bufferUV :& bufferBez :& bufferBezUV :&
  bufferPrev :& bufferNext :& ()
  = genFunction (Proxy :: Proxy Simple2DAttribBuffers)
--------------------------------------------------------------------------------
-- Rendering
--------------------------------------------------------------------------------
  | Creates and returns a renderer that renders a colored , expanded 2d polyline
-- projected in 2d space.
colorPolylineRenderer :: Context -> Simple2DShader -> Float -> Float
                      -> (LineCap,LineCap) -> Vector (V2 Float)
                      -> Vector (V4 Float) -> IO Renderer2
colorPolylineRenderer win sh thickness feather caps verts colors = do
  let empty = putStrLn "could not expand polyline" >> return mempty
      mpoly = expandPolyline verts colors thickness feather
  flip (maybe empty) mpoly $ \(vs_,cs_,us_,ns_,ps_,totalLen) -> do
    let toFrac :: Float -> GLfloat
        toFrac = realToFrac
        vs = V.map (fmap toFrac) vs_
        cs = V.map (fmap toFrac) cs_
        us = V.map (fmap toFrac) us_
        ns = V.map (fmap toFrac) ns_
        ps = V.map (fmap toFrac) ps_

    withVAO $ \vao -> withBuffers 5 $ \bufs@[vbuf, cbuf, buvbuf, nbuf, pbuf] -> do
      enableAttribsForLines False
      bufferPosition 2 vbuf vs
      bufferColor 4 cbuf cs
      bufferBezUV 2 buvbuf us
      bufferNext 2 nbuf ns
      bufferPrev 2 pbuf ps
      glBindVertexArray 0

      let num = fromIntegral $ V.length vs_
          r t = do
            glUseProgram sh
            let (mv, a, m, mr) = unwrapTransforms t
            pj <- orthoContextProjection win
            updatePrimitive sh PrimLine
            updateProjection sh pj
            updateModelView sh mv
            updateHasUV sh False
            updateThickness sh thickness
            updateFeather sh feather
            updateSumLength sh totalLen
            updateCap sh caps
            updateAlpha sh a
            updateMultiply sh m
            case mr of
              Just c -> do updateShouldReplaceColor sh True
                           updateReplacementColor sh c
              _      -> updateShouldReplaceColor sh False
            drawBuffer sh vao GL_TRIANGLE_STRIP num
          free = do withArray bufs $ glDeleteBuffers 5
                    withArray [vao] $ glDeleteVertexArrays 1
      return (free,r)

  | Creates and returns a renderer that renders a textured , expanded 2d
  polyline projected in 2d space .
texPolylineRenderer :: Context -> Simple2DShader -> Float
                    -> Float -> (LineCap,LineCap) -> Vector (V2 Float)
                    -> Vector (V2 Float) -> IO Renderer2
texPolylineRenderer win sh thickness feather caps verts uvs = do
  let empty = putStrLn "could not expand polyline" >> return mempty
      mpoly = expandPolyline verts uvs thickness feather
  flip (maybe empty) mpoly $ \(vs_,cs_,us_,ns_,ps_,totalLen) -> do
    let toFrac :: Float -> GLfloat
        toFrac = realToFrac
        vs = V.map (fmap toFrac) vs_
        cs = V.map (fmap toFrac) cs_
        us = V.map (fmap toFrac) us_
        ns = V.map (fmap toFrac) ns_
        ps = V.map (fmap toFrac) ps_

    withVAO $ \vao -> withBuffers 5 $ \bufs@[vbuf, cbuf, buvbuf, nbuf, pbuf] -> do
      enableAttribsForLines True
      bufferPosition 2 vbuf vs
      bufferUV 2 cbuf cs
      bufferBezUV 2 buvbuf us
      bufferNext 2 nbuf ns
      bufferPrev 2 pbuf ps
      glBindVertexArray 0

      let num = fromIntegral $ V.length vs_
          r t = do
            glUseProgram sh
            let (mv, a, m, mr) = unwrapTransforms t
            pj <- orthoContextProjection win
            updatePrimitive sh PrimLine
            updateProjection sh pj
            updateModelView sh mv
            updateHasUV sh True
            updateThickness sh thickness
            updateFeather sh feather
            updateSumLength sh totalLen
            updateCap sh caps
            updateAlpha sh a
            updateMultiply sh m
            case mr of
              Just c -> do updateShouldReplaceColor sh True
                           updateReplacementColor sh c
              _      -> updateShouldReplaceColor sh False
            drawBuffer sh vao GL_TRIANGLE_STRIP num
          c = do withArray bufs $ glDeleteBuffers 5
                 withArray [vao] $ glDeleteVertexArrays 1
      return (c,r)

-- | Binds the given textures to GL_TEXTURE0, GL_TEXTURE1, ... in ascending
  order of the texture unit , runs the IO action and then unbinds the textures .
bindTexsAround :: MonadIO m => [GLuint] -> m a -> m a
bindTexsAround ts f = do
  liftIO $ mapM_ (uncurry bindTex) (zip ts [GL_TEXTURE0 ..])
  a <- f
  liftIO $ glBindTexture GL_TEXTURE_2D 0
  return a
  where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex

bindTexAround :: MonadIO m => GLuint -> m a -> m a
bindTexAround tx = bindTexsAround [tx]

-- | Creates and returns a renderer that renders the given colored
-- geometry.
colorRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float)
              -> Vector (V4 Float) -> IO Renderer2
colorRenderer window sh mode vs gs =
  withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do
let     $ V.concatMap ( V.fromList .  ) vs : : Vector GLfloat
         $ V.concatMap ( V.fromList . F.toList ) $ V.take ( V.length vs ) gs : : Vector GLfloat

    enableAttribsForTris False
    clearErrors "colorRenderer: enable attribs"
    bufferPosition 2 pbuf vs
    clearErrors "colorRenderer: buffer position"
    bufferColor 4 cbuf $ V.take (V.length vs) gs
    clearErrors "colorRenderer: buffer color"
    let num = fromIntegral $ V.length vs
        renderFunction t = do
          glUseProgram sh
          let (mv,a,m,mr) = unwrapTransforms t
          pj <- orthoContextProjection window
          updatePrimitive sh PrimTri
          updateProjection sh pj
          updateModelView sh mv
          updateHasUV sh False
          updateAlpha sh a
          updateMultiply sh m
          case mr of
            Just c -> do updateShouldReplaceColor sh True
                         updateReplacementColor sh c
            _      -> updateShouldReplaceColor sh False
          drawBuffer sh vao mode num
        cleanupFunction = do
          withArray [pbuf, cbuf] $ glDeleteBuffers 2
          withArray [vao] $ glDeleteVertexArrays 1
    return (cleanupFunction,renderFunction)

-- | Creates and returns a renderer that renders a textured
-- geometry.
textureRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float)
                -> Vector (V2 Float) -> IO Renderer2
textureRenderer win sh mode vs uvs =
  withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do
let f xs = V.map realToFrac $ V.concatMap ( V.fromList . F.toList ) xs : : Vector GLfloat
        vs
     cs = f $ V.take ( V.length vs ) uvs

  enableAttribsForTris True
  bufferPosition 2 pbuf vs
  bufferUV 2 cbuf uvs
  glBindVertexArray 0

  let num = fromIntegral $ V.length vs
      renderFunction t = do
        glUseProgram sh
        let (mv,a,m,mr) = unwrapTransforms t
        pj <- orthoContextProjection win
        updatePrimitive sh PrimTri
        updateProjection sh pj
        updateModelView sh mv
        updateHasUV sh True
        updateSampler sh 0
        updateAlpha sh a
        updateMultiply sh m
        case mr of
          Just c -> do updateShouldReplaceColor sh True
                       updateReplacementColor sh c
          _      -> updateShouldReplaceColor sh False
        drawBuffer sh vao mode num
      cleanupFunction = do
        withArray [pbuf, cbuf] $ glDeleteBuffers 2
        withArray [vao] $ glDeleteVertexArrays 1
  return (cleanupFunction,renderFunction)

--bezAttributes :: (Foldable f, Unbox (f Float))
--              => Vector (V2 Float)
--              -> Vector (f Float)
               - > ( Vector GLfloat ,   ,   )
bezAttributes vs cvs = ( ps , cs , ws )
   where ps = V.map realToFrac $
               ( V.fromList .  ) vs : : Vector GLfloat
--        cs = V.map realToFrac $
                 ( V.fromList .  ) cvs : : Vector GLfloat
--        getWinding i =
           let n = i * 3
--              (a,b,c) = (vs V.! n, vs V.! (n + 1), vs V.! (n + 2))
               w = fromBool $ triangleArea a b c < = 0
           in V.fromList [ 0 , 0 , w
                         , 0.5 , 0 , w
                         , 1 , 1 , w
--                        ]
         numBezs = floor $ realToFrac ( V.length vs ) / ( 3 : : Double )
--        ws :: Vector GLfloat
         ws =   $ V.generate numBezs i d

bezWinding :: Vector (V2 Float) -> Vector (V3 Float)
bezWinding vs = V.concatMap getWinding $ V.generate numBezs id
  where getWinding i =
          let n = i * 3
              (a,b,c) = (vs V.! n, vs V.! (n + 1), vs V.! (n + 2))
              w = fromBool $ triangleArea a b c <= 0
          in V.fromList [ V3 0 0 w
                        , V3 0.5 0 w
                        , V3 1 1 w
                        ]
        numBezs = floor $ realToFrac (V.length vs) / (3 :: Double)

-- | Creates and returns a renderer that renders the given colored beziers.
colorBezRenderer :: Context -> Simple2DShader
                 -> Vector (V2 Float) -> Vector (V4 Float) -> IO Renderer2
colorBezRenderer win sh vs cs = do
  let ws = bezWinding vs
  withVAO $ \vao -> withBuffers 3 $ \[pbuf, tbuf, cbuf] -> do
    enableAttribsForBezs False
    bufferPosition 2 pbuf vs
    bufferBez 3 tbuf ws
    bufferColor 4 cbuf $ V.take (V.length vs) cs
    glBindVertexArray 0

    let cleanupFunction = do
          withArray [pbuf, tbuf, cbuf] $ glDeleteBuffers 3
          withArray [vao] $ glDeleteVertexArrays 1
        num = fromIntegral $ V.length vs
        renderFunction t = do
          glUseProgram sh
          pj <- orthoContextProjection win
          let (mv,a,m,mr) = unwrapTransforms t
          updatePrimitive sh PrimBez
          updateProjection sh pj
          updateModelView sh mv
          updateHasUV sh False
          updateAlpha sh a
          updateMultiply sh m
          case mr of
            Just c -> do updateShouldReplaceColor sh True
                         updateReplacementColor sh c
            _      -> updateShouldReplaceColor sh False
          drawBuffer sh vao GL_TRIANGLES num
    return (cleanupFunction,renderFunction)

-- | Creates and returns a renderer that renders the given textured beziers.
textureBezRenderer :: Context -> Simple2DShader
                   -> Vector (V2 Float) -> Vector (V2 Float) -> IO Renderer2
textureBezRenderer win sh vs cs = do
  let ws = bezWinding vs
  withVAO $ \vao -> withBuffers 3 $ \[pbuf, tbuf, cbuf] -> do
    enableAttribsForBezs True
    bufferPosition 2 pbuf vs
    bufferBez 3 tbuf ws
    bufferUV 2 cbuf cs
    glBindVertexArray 0

    let cleanupFunction = do
            withArray [pbuf, tbuf, cbuf] $ glDeleteBuffers 3
            withArray [vao] $ glDeleteVertexArrays 1
        num = fromIntegral $ V.length vs
        renderFunction t = do
          glUseProgram sh
          pj <- orthoContextProjection win
          let (mv,a,m,mr) = unwrapTransforms t
          updatePrimitive sh PrimBez
          updateProjection sh pj
          updateModelView sh mv
          updateHasUV sh True
          updateSampler sh 0
          updateAlpha sh a
          updateMultiply sh m
          case mr of
            Just c -> do updateShouldReplaceColor sh True
                         updateReplacementColor sh c
            _      -> updateShouldReplaceColor sh False
          drawBuffer sh vao GL_TRIANGLES num
    return (cleanupFunction,renderFunction)

-- | Creates and returns a renderer that masks a textured rectangular area with
-- another texture.
maskRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float)
             -> Vector (V2 Float) -> IO Renderer2
maskRenderer win sh mode vs uvs =
    withVAO $ \vao -> withBuffers 2 $ \[pbuf, uvbuf] -> do
let vs '   = V.map realToFrac $
               ( V.fromList .  ) vs : : Vector GLfloat
     uvs ' = V.map realToFrac $
               ( V.fromList . F.toList ) uvs : : Vector GLfloat

        enableAttribsForMask
        bufferPosition 2 pbuf vs
        bufferUV 2 uvbuf uvs
        glBindVertexArray 0

        let cleanup = do withArray [pbuf, uvbuf] $ glDeleteBuffers 2
                         withArray [vao] $ glDeleteVertexArrays 1
            num = fromIntegral $ V.length vs
            render t = do
                let (mv,a,m,_) = unwrapTransforms t
                pj <- orthoContextProjection win
updateUniformsForMask ( unShader sh )   a m 0 1
                updateProjection sh pj
                updateModelView sh mv
                updateAlpha sh a
                updateMultiply sh m
                updateMainTex sh 0
                updateMaskTex sh 1
                drawBuffer sh vao mode num
        return (cleanup,render)

-- | Creates a rendering that masks an IO () drawing computation with the alpha
-- value of another.
alphaMask :: Context -> Simple2DShader -> IO () -> IO () -> IO Renderer2
alphaMask win mrs r2 r1 = do
    mainTex <- toTextureUnit (Just GL_TEXTURE0) win r2
    maskTex <- toTextureUnit (Just GL_TEXTURE1) win r1
    (w,h)   <- ctxWindowSize win
    let vs = V.fromList $ map (fmap fromIntegral) [V2 0 0, V2 w 0, V2 w h, V2 0 h]
        uvs = V.fromList [V2 0 1, V2 1 1, V2 1 0, V2 0 0]
    (c,f) <- maskRenderer win mrs GL_TRIANGLE_FAN vs uvs
    let f' _ = do glActiveTexture GL_TEXTURE0
                  glBindTexture GL_TEXTURE_2D mainTex
                  glActiveTexture GL_TEXTURE1
                  glBindTexture GL_TEXTURE_2D maskTex
        c'    = withArray [mainTex,maskTex] $ glDeleteTextures 2
        f'' _ = do glActiveTexture GL_TEXTURE0
                   glBindTexture GL_TEXTURE_2D 0
                   glActiveTexture GL_TEXTURE1
                   glBindTexture GL_TEXTURE_2D 0
    return (c >> c', \t -> f' t >> f t >> f'' t)

-- | Creates an IO () drawing computation that masks an IO () drawing
-- computation with another using a stencil test.
stencilMask :: IO () -> IO () -> IO ()
stencilMask r2 r1  = do
    glClear GL_DEPTH_BUFFER_BIT
    -- Enable stencil testing
    glEnable GL_STENCIL_TEST
    -- Disable writing frame buffer color components
    glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
    -- Disable writing into the depth buffer
    glDepthMask GL_FALSE
    -- Enable writing to all bits of the stencil mask
    glStencilMask 0xFF
    -- Clear the stencil buffer
    glClear GL_STENCIL_BUFFER_BIT
    glStencilFunc GL_NEVER 0 1
    glStencilOp GL_INVERT GL_INVERT GL_INVERT
    r1

    glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
    glDepthMask GL_TRUE
    glStencilFunc GL_EQUAL 1 1
    glStencilOp GL_ZERO GL_ZERO GL_ZERO
    r2
    glDisable GL_STENCIL_TEST

transformRenderer :: [RenderTransform2] -> Renderer2 -> Renderer2
transformRenderer ts (c, r) = (c, r . (ts ++))
--------------------------------------------------------------------------------
-- Working with textures.
--------------------------------------------------------------------------------
loadImage :: FilePath -> IO (Maybe (V2 Int, GLuint))
loadImage fp = readImage fp >>= maybeLoadTexture

loadImageAsTexture :: FilePath -> IO (Maybe GLuint)
loadImageAsTexture fp = do
  edyn <- readImage fp
  fmap snd <$> maybeLoadTexture edyn

maybeLoadTexture :: Either String DynamicImage -> IO (Maybe (V2 Int, GLuint))
maybeLoadTexture strOrImg = case strOrImg of
    Left err -> putStrLn err >> return Nothing
    Right i  -> Just <$> loadTexture i

loadTexture :: DynamicImage -> IO (V2 Int, GLuint)
loadTexture = loadTextureUnit Nothing

allocAndActivateTex :: GLenum -> IO GLuint
allocAndActivateTex u = do
    [t] <- allocaArray 1 $ \ptr -> do
        glGenTextures 1 ptr
        peekArray 1 ptr
    glActiveTexture u
    glBindTexture GL_TEXTURE_2D t
    return t

loadTextureUnit :: Maybe GLuint -> DynamicImage -> IO (V2 Int, GLuint)
loadTextureUnit Nothing img = loadTextureUnit (Just GL_TEXTURE0) img
loadTextureUnit (Just u) img = do
    t <- allocAndActivateTex u
    (w,h) <- loadJuicy img
  Generate mipmaps now ! ! !
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST_MIPMAP_NEAREST
    glBindTexture GL_TEXTURE_2D 0
    return (V2 w h, t)

unloadTexture :: GLuint -> IO ()
unloadTexture t = withArray [t] $ glDeleteTextures 1

loadJuicy :: DynamicImage -> IO (Int,Int)
loadJuicy (ImageY8 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_BYTE
loadJuicy (ImageY16 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_SHORT
loadJuicy (ImageYF (Image w h d)) = bufferImageData w h d GL_RED GL_FLOAT
loadJuicy (ImageYA8 i) = loadJuicy $ ImageRGB8 $ promoteImage i
loadJuicy (ImageYA16 i) = loadJuicy $ ImageRGBA16 $ promoteImage i
loadJuicy (ImageRGB8 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_BYTE
loadJuicy (ImageRGB16 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_SHORT
loadJuicy (ImageRGBF (Image w h d)) = bufferImageData w h d GL_RGB GL_FLOAT
loadJuicy (ImageRGBA8 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_BYTE
loadJuicy (ImageRGBA16 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_SHORT
loadJuicy (ImageYCbCr8 i) = loadJuicy $ ImageRGB8 $ convertImage i
loadJuicy (ImageCMYK8 i) = loadJuicy $ ImageRGB8 $ convertImage i
loadJuicy (ImageCMYK16 i) = loadJuicy $ ImageRGB16 $ convertImage i

toTexture :: Context -> IO () -> IO GLuint
toTexture = toTextureUnit Nothing

toTextureUnit :: Maybe GLuint -> Context -> IO () -> IO GLuint
toTextureUnit Nothing win r = toTextureUnit (Just GL_TEXTURE0) win r
toTextureUnit (Just u) win r = do
    [fb] <- allocaArray 1 $ \ptr -> do
        glGenFramebuffers 1 ptr
        peekArray 1 ptr
    glBindFramebuffer GL_FRAMEBUFFER fb

    t <- allocAndActivateTex u

    (w,h) <- ctxWindowSize win
    let [w',h'] = map fromIntegral [w,h]

    initializeTexImage2D w' h'

    glFramebufferTexture GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 t 0
    withArray [GL_COLOR_ATTACHMENT0] $ glDrawBuffers 1

    status <- glCheckFramebufferStatus GL_FRAMEBUFFER
    if status /= GL_FRAMEBUFFER_COMPLETE
    then putStrLn "incomplete framebuffer!"
    else do glClearColor 0 0 0 0
            glClear GL_COLOR_BUFFER_BIT
            glViewport 0 0 w' h'
            r
            glBindFramebuffer GL_FRAMEBUFFER 0
            with fb $ glDeleteFramebuffers 1
            (fbw, fbh) <- ctxFramebufferSize win
            glViewport 0 0 (fromIntegral fbw) (fromIntegral fbh)
    return t

initializeTexImage2D :: GLsizei -> GLsizei -> IO ()
initializeTexImage2D w h = do
  glTexImage2D GL_TEXTURE_2D 0 GL_RGBA w h 0 GL_RGBA GL_UNSIGNED_BYTE nullPtr
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST

type ClippingArea = (V2 Int, V2 Int)

-- | Sub-samples a texture using the given coordinate box and creates a new
-- texture. Keep in mind that OpenGL texture coordinates are flipped from
-- 'normal' graphics coordinates (y = 0 is the bottom of the texture). That
-- fact has bitten the author a number of times while clipping a texture
-- created with `toTexture` and `toUnitTexture`.
clipTexture :: GLuint -> ClippingArea -> IO GLuint
clipTexture rtex (V2 x1 y1, V2 x2 y2) = do
    -- Create our framebuffers
    [fbread,fbwrite] <- allocaArray 2 $ \ptr -> do
        glGenFramebuffers 2 ptr
        peekArray 2 ptr
    -- Bind our read frame buffer and attach the input texture to it
    glBindFramebuffer GL_READ_FRAMEBUFFER fbread
    glFramebufferTexture2D GL_READ_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D rtex 0
    clearErrors "clipTexture bind read framebuffer"
    -- Generate a new texture and bind our write framebuffer to it
    [wtex] <- allocaArray 1 $ \ptr -> do
        glGenTextures 1 ptr
        peekArray 1 ptr
    glActiveTexture GL_TEXTURE0
    glBindTexture GL_TEXTURE_2D wtex
    let [x1',y1',x2',y2',w',h'] = map fromIntegral
                                      [x1,y1,x2,y2,abs $ x2 - x1
                                                  ,abs $ y2 - y1]
    initializeTexImage2D w' h'
    glBindFramebuffer GL_DRAW_FRAMEBUFFER fbwrite
    glFramebufferTexture2D GL_DRAW_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D wtex 0
    clearErrors "clipTexture bind write framebuffer"
    -- Check our frame buffer stati
    forM_ [GL_READ_FRAMEBUFFER,GL_DRAW_FRAMEBUFFER] $ \fb -> do
        status <- glCheckFramebufferStatus fb
        when (status /= GL_FRAMEBUFFER_COMPLETE) $ do
            putStrLn "incomplete framebuffer!"
            exitFailure
    -- Blit the read framebuffer into the write framebuffer
    glBlitFramebuffer x1' y1' x2' y2' 0 0 w' h' GL_COLOR_BUFFER_BIT GL_NEAREST
    clearErrors "clipTexture blit framebuffers"
    -- Cleanup
    glBindFramebuffer GL_FRAMEBUFFER 0
    withArray [fbread,fbwrite] $ glDeleteFramebuffers 2
    glBindTexture GL_TEXTURE_2D 0
    return wtex
--------------------------------------------------------------------------------
-- Buffering, Vertex Array Objects, Uniforms, etc.
--------------------------------------------------------------------------------
bufferImageData :: forall a a1 a2. (Storable a2, Integral a1, Integral a) => a -> a1 -> S.Vector a2 -> GLenum -> GLenum -> IO (a,a1)
bufferImageData w h dat imgfmt pxfmt = S.unsafeWith dat $ \ptr -> do
    glTexImage2D
        GL_TEXTURE_2D
        0
        GL_RGBA
        (fromIntegral w)
        (fromIntegral h)
        0
        imgfmt
        pxfmt
        (castPtr ptr)
    err <- glGetError
    when (err /= 0) $ putStrLn $ "glTexImage2D Error: " ++ show err
    return (w,h)

withVAO :: (GLuint -> IO b) -> IO b
withVAO f = do
    [vao] <- allocaArray 1 $ \ptr -> do
        glGenVertexArrays 1 ptr
        peekArray 1 ptr
    glBindVertexArray vao
    r <- f vao
    clearErrors "withVAO"
    glBindVertexArray 0
    return r

withBuffers :: Int -> ([GLuint] -> IO b) -> IO b
withBuffers n f = do
    bufs <- allocaArray n $ \ptr -> do
        glGenBuffers (fromIntegral n) ptr
        peekArray (fromIntegral n) ptr
    f bufs

 : : ( Storable a , Unbox a )
--             => Simple2DAttrib -> GLint -> GLuint -> Vector a -> IO ()
bufferAttrib attr n buf as = do
     let  = locToGLuint attr
         asize = V.length as * sizeOf ( V.head as )
         f = S.convert : : ( G.Vector Vector a , Storable a )
--                      => Vector a -> S.Vector a
     glBindBuffer GL_ARRAY_BUFFER buf
--
      ( f as ) $ \ptr - >
--        glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW
     glEnableVertexAttribArray loc
         GL_FALSE 0 nullPtr

drawBuffer :: GLuint
           -> GLuint
           -> GLenum
           -> GLsizei
           -> IO ()
drawBuffer program vao mode num = do
    glUseProgram program
    glBindVertexArray vao
    clearErrors "drawBuffer:glBindVertex"
    glDrawArrays mode 0 num
    clearErrors "drawBuffer:glDrawArrays"

clearErrors :: String -> IO ()
clearErrors str = do
    err' <- glGetError
    when (err' /= 0) $ do
      putStrLn $ unwords [str, show err']
      assert False $ return ()

# LANGUAGE ConstraintKinds       #
# LANGUAGE FlexibleContexts      #
# LANGUAGE ScopedTypeVariables   #
 * Renderer
 * Loading and using textures
 * Line rendering
 * Triangle rendering
 * Masking
 * Transforming a rendering
 * Utils
------------------------------------------------------------------------------
 Uniform updates for the Simple2DShader
------------------------------------------------------------------------------
------------------------------------------------------------------------------
 Attribute toggling
------------------------------------------------------------------------------
enableAll :: IO ()
enableAll =
  sequence_ [ enablePosition, enableColor, enableUV, enableBez, enableBezUV
            , enablePrev, enableNext
            ]
------------------------------------------------------------------------------
 Attribute buffering
------------------------------------------------------------------------------
------------------------------------------------------------------------------
 Rendering
------------------------------------------------------------------------------
 projected in 2d space.
 | Binds the given textures to GL_TEXTURE0, GL_TEXTURE1, ... in ascending
 | Creates and returns a renderer that renders the given colored
 geometry.
 | Creates and returns a renderer that renders a textured
 geometry.
bezAttributes :: (Foldable f, Unbox (f Float))
              => Vector (V2 Float)
              -> Vector (f Float)
        cs = V.map realToFrac $
        getWinding i =
              (a,b,c) = (vs V.! n, vs V.! (n + 1), vs V.! (n + 2))
                        ]
        ws :: Vector GLfloat
 | Creates and returns a renderer that renders the given colored beziers.
 | Creates and returns a renderer that renders the given textured beziers.
 | Creates and returns a renderer that masks a textured rectangular area with
 another texture.
 | Creates a rendering that masks an IO () drawing computation with the alpha
 value of another.
 | Creates an IO () drawing computation that masks an IO () drawing
 computation with another using a stencil test.
 Enable stencil testing
 Disable writing frame buffer color components
 Disable writing into the depth buffer
 Enable writing to all bits of the stencil mask
 Clear the stencil buffer
------------------------------------------------------------------------------
 Working with textures.
------------------------------------------------------------------------------
 | Sub-samples a texture using the given coordinate box and creates a new
 texture. Keep in mind that OpenGL texture coordinates are flipped from
 'normal' graphics coordinates (y = 0 is the bottom of the texture). That
 fact has bitten the author a number of times while clipping a texture
 created with `toTexture` and `toUnitTexture`.
 Create our framebuffers
 Bind our read frame buffer and attach the input texture to it
 Generate a new texture and bind our write framebuffer to it
 Check our frame buffer stati
 Blit the read framebuffer into the write framebuffer
 Cleanup
------------------------------------------------------------------------------
 Buffering, Vertex Array Objects, Uniforms, etc.
------------------------------------------------------------------------------
             => Simple2DAttrib -> GLint -> GLuint -> Vector a -> IO ()
                      => Vector a -> S.Vector a

        glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW
# LANGUAGE PartialTypeSignatures #
module Gelatin.GL.Renderer (
    Renderer2,
    Context(..),
    allocAndActivateTex,
    initializeTexImage2D,
    loadImage,
    maybeLoadTexture,
    loadTexture,
    loadTextureUnit,
    unloadTexture,
    loadImageAsTexture,
    bindTexsAround,
    bindTexAround,
    colorPolylineRenderer,
    texPolylineRenderer,
    colorRenderer,
    textureRenderer,
  *  rendering
    colorBezRenderer,
    textureBezRenderer,
    maskRenderer,
    stencilMask,
    alphaMask,
    transformRenderer,
    toTexture,
    toTextureUnit,
    clipTexture
) where

import           Codec.Picture          (readImage)
import           Codec.Picture.Types
import           Control.Exception      (assert)
import           Control.Monad
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Reader   (ReaderT (..))
import qualified Data.Foldable          as F
import           Data.Proxy             (Proxy (..))
import qualified Data.Vector.Generic    as G
import qualified Data.Vector.Storable   as S
import           Data.Vector.Unboxed    (Unbox, Vector)
import qualified Data.Vector.Unboxed    as V
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           Gelatin
import           Gelatin.GL.Common
import           Gelatin.GL.Shader
import           Gelatin.Shaders
import           Graphics.GL.Core33
import           Graphics.GL.Types
import           System.Exit

updatePrimitive :& updateProjection :& updateModelView :& updateThickness :&
  updateFeather :& updateSumLength :& updateCap :& updateHasUV :& updateSampler :&
  updateMainTex :& updateMaskTex :& updateAlpha :& updateMultiply :&
  updateShouldReplaceColor :& updateReplacementColor :& ()
  = genFunction (Proxy :: Proxy Simple2DUniforms)
(enablePosition, disablePosition) :& (enableColor, disableColor) :&
  (enableUV, disableUV) :& (enableBez, disableBez) :&
  (enableBezUV, disableBezUV) :& (enablePrev, disablePrev) :&
  (enableNext, disableNext) :& ()
  = genFunction (Proxy :: Proxy Simple2DAttribToggles)

disableAll :: IO ()
disableAll =
  sequence_ [ disablePosition, disableColor, disableUV, disableBez, disableBezUV
            , disablePrev, disableNext
            ]


enableAttribsForLines :: Bool -> IO ()
enableAttribsForLines hasUV = do
  disableAll
  enablePosition
  enableBezUV
  enablePrev
  enableNext
  if hasUV
    then enableUV
    else enableColor

enableAttribsForTris :: Bool -> IO ()
enableAttribsForTris hasUV =
  disableAll >> enablePosition >> if hasUV then enableUV
                                           else enableColor

enableAttribsForBezs :: Bool -> IO ()
enableAttribsForBezs hasUV =
  disableAll >> enablePosition >> enableBez >> if hasUV then enableUV
                                                        else enableColor

enableAttribsForMask :: IO ()
enableAttribsForMask = disableAll >> enablePosition >> enableUV
bufferPosition :& bufferColor :& bufferUV :& bufferBez :& bufferBezUV :&
  bufferPrev :& bufferNext :& ()
  = genFunction (Proxy :: Proxy Simple2DAttribBuffers)
  | Creates and returns a renderer that renders a colored , expanded 2d polyline
colorPolylineRenderer :: Context -> Simple2DShader -> Float -> Float
                      -> (LineCap,LineCap) -> Vector (V2 Float)
                      -> Vector (V4 Float) -> IO Renderer2
colorPolylineRenderer win sh thickness feather caps verts colors = do
  let empty = putStrLn "could not expand polyline" >> return mempty
      mpoly = expandPolyline verts colors thickness feather
  flip (maybe empty) mpoly $ \(vs_,cs_,us_,ns_,ps_,totalLen) -> do
    let toFrac :: Float -> GLfloat
        toFrac = realToFrac
        vs = V.map (fmap toFrac) vs_
        cs = V.map (fmap toFrac) cs_
        us = V.map (fmap toFrac) us_
        ns = V.map (fmap toFrac) ns_
        ps = V.map (fmap toFrac) ps_

    withVAO $ \vao -> withBuffers 5 $ \bufs@[vbuf, cbuf, buvbuf, nbuf, pbuf] -> do
      enableAttribsForLines False
      bufferPosition 2 vbuf vs
      bufferColor 4 cbuf cs
      bufferBezUV 2 buvbuf us
      bufferNext 2 nbuf ns
      bufferPrev 2 pbuf ps
      glBindVertexArray 0

      let num = fromIntegral $ V.length vs_
          r t = do
            glUseProgram sh
            let (mv, a, m, mr) = unwrapTransforms t
            pj <- orthoContextProjection win
            updatePrimitive sh PrimLine
            updateProjection sh pj
            updateModelView sh mv
            updateHasUV sh False
            updateThickness sh thickness
            updateFeather sh feather
            updateSumLength sh totalLen
            updateCap sh caps
            updateAlpha sh a
            updateMultiply sh m
            case mr of
              Just c -> do updateShouldReplaceColor sh True
                           updateReplacementColor sh c
              _      -> updateShouldReplaceColor sh False
            drawBuffer sh vao GL_TRIANGLE_STRIP num
          free = do withArray bufs $ glDeleteBuffers 5
                    withArray [vao] $ glDeleteVertexArrays 1
      return (free,r)

  | Creates and returns a renderer that renders a textured , expanded 2d
  polyline projected in 2d space .
texPolylineRenderer :: Context -> Simple2DShader -> Float
                    -> Float -> (LineCap,LineCap) -> Vector (V2 Float)
                    -> Vector (V2 Float) -> IO Renderer2
texPolylineRenderer win sh thickness feather caps verts uvs = do
  let empty = putStrLn "could not expand polyline" >> return mempty
      mpoly = expandPolyline verts uvs thickness feather
  flip (maybe empty) mpoly $ \(vs_,cs_,us_,ns_,ps_,totalLen) -> do
    let toFrac :: Float -> GLfloat
        toFrac = realToFrac
        vs = V.map (fmap toFrac) vs_
        cs = V.map (fmap toFrac) cs_
        us = V.map (fmap toFrac) us_
        ns = V.map (fmap toFrac) ns_
        ps = V.map (fmap toFrac) ps_

    withVAO $ \vao -> withBuffers 5 $ \bufs@[vbuf, cbuf, buvbuf, nbuf, pbuf] -> do
      enableAttribsForLines True
      bufferPosition 2 vbuf vs
      bufferUV 2 cbuf cs
      bufferBezUV 2 buvbuf us
      bufferNext 2 nbuf ns
      bufferPrev 2 pbuf ps
      glBindVertexArray 0

      let num = fromIntegral $ V.length vs_
          r t = do
            glUseProgram sh
            let (mv, a, m, mr) = unwrapTransforms t
            pj <- orthoContextProjection win
            updatePrimitive sh PrimLine
            updateProjection sh pj
            updateModelView sh mv
            updateHasUV sh True
            updateThickness sh thickness
            updateFeather sh feather
            updateSumLength sh totalLen
            updateCap sh caps
            updateAlpha sh a
            updateMultiply sh m
            case mr of
              Just c -> do updateShouldReplaceColor sh True
                           updateReplacementColor sh c
              _      -> updateShouldReplaceColor sh False
            drawBuffer sh vao GL_TRIANGLE_STRIP num
          c = do withArray bufs $ glDeleteBuffers 5
                 withArray [vao] $ glDeleteVertexArrays 1
      return (c,r)

  order of the texture unit , runs the IO action and then unbinds the textures .
bindTexsAround :: MonadIO m => [GLuint] -> m a -> m a
bindTexsAround ts f = do
  liftIO $ mapM_ (uncurry bindTex) (zip ts [GL_TEXTURE0 ..])
  a <- f
  liftIO $ glBindTexture GL_TEXTURE_2D 0
  return a
  where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex

bindTexAround :: MonadIO m => GLuint -> m a -> m a
bindTexAround tx = bindTexsAround [tx]

colorRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float)
              -> Vector (V4 Float) -> IO Renderer2
colorRenderer window sh mode vs gs =
  withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do
let     $ V.concatMap ( V.fromList .  ) vs : : Vector GLfloat
         $ V.concatMap ( V.fromList . F.toList ) $ V.take ( V.length vs ) gs : : Vector GLfloat

    enableAttribsForTris False
    clearErrors "colorRenderer: enable attribs"
    bufferPosition 2 pbuf vs
    clearErrors "colorRenderer: buffer position"
    bufferColor 4 cbuf $ V.take (V.length vs) gs
    clearErrors "colorRenderer: buffer color"
    let num = fromIntegral $ V.length vs
        renderFunction t = do
          glUseProgram sh
          let (mv,a,m,mr) = unwrapTransforms t
          pj <- orthoContextProjection window
          updatePrimitive sh PrimTri
          updateProjection sh pj
          updateModelView sh mv
          updateHasUV sh False
          updateAlpha sh a
          updateMultiply sh m
          case mr of
            Just c -> do updateShouldReplaceColor sh True
                         updateReplacementColor sh c
            _      -> updateShouldReplaceColor sh False
          drawBuffer sh vao mode num
        cleanupFunction = do
          withArray [pbuf, cbuf] $ glDeleteBuffers 2
          withArray [vao] $ glDeleteVertexArrays 1
    return (cleanupFunction,renderFunction)

textureRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float)
                -> Vector (V2 Float) -> IO Renderer2
textureRenderer win sh mode vs uvs =
  withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do
let f xs = V.map realToFrac $ V.concatMap ( V.fromList . F.toList ) xs : : Vector GLfloat
        vs
     cs = f $ V.take ( V.length vs ) uvs

  enableAttribsForTris True
  bufferPosition 2 pbuf vs
  bufferUV 2 cbuf uvs
  glBindVertexArray 0

  let num = fromIntegral $ V.length vs
      renderFunction t = do
        glUseProgram sh
        let (mv,a,m,mr) = unwrapTransforms t
        pj <- orthoContextProjection win
        updatePrimitive sh PrimTri
        updateProjection sh pj
        updateModelView sh mv
        updateHasUV sh True
        updateSampler sh 0
        updateAlpha sh a
        updateMultiply sh m
        case mr of
          Just c -> do updateShouldReplaceColor sh True
                       updateReplacementColor sh c
          _      -> updateShouldReplaceColor sh False
        drawBuffer sh vao mode num
      cleanupFunction = do
        withArray [pbuf, cbuf] $ glDeleteBuffers 2
        withArray [vao] $ glDeleteVertexArrays 1
  return (cleanupFunction,renderFunction)

               - > ( Vector GLfloat ,   ,   )
bezAttributes vs cvs = ( ps , cs , ws )
   where ps = V.map realToFrac $
               ( V.fromList .  ) vs : : Vector GLfloat
                 ( V.fromList .  ) cvs : : Vector GLfloat
           let n = i * 3
               w = fromBool $ triangleArea a b c < = 0
           in V.fromList [ 0 , 0 , w
                         , 0.5 , 0 , w
                         , 1 , 1 , w
         numBezs = floor $ realToFrac ( V.length vs ) / ( 3 : : Double )
         ws =   $ V.generate numBezs i d

bezWinding :: Vector (V2 Float) -> Vector (V3 Float)
bezWinding vs = V.concatMap getWinding $ V.generate numBezs id
  where getWinding i =
          let n = i * 3
              (a,b,c) = (vs V.! n, vs V.! (n + 1), vs V.! (n + 2))
              w = fromBool $ triangleArea a b c <= 0
          in V.fromList [ V3 0 0 w
                        , V3 0.5 0 w
                        , V3 1 1 w
                        ]
        numBezs = floor $ realToFrac (V.length vs) / (3 :: Double)

colorBezRenderer :: Context -> Simple2DShader
                 -> Vector (V2 Float) -> Vector (V4 Float) -> IO Renderer2
colorBezRenderer win sh vs cs = do
  let ws = bezWinding vs
  withVAO $ \vao -> withBuffers 3 $ \[pbuf, tbuf, cbuf] -> do
    enableAttribsForBezs False
    bufferPosition 2 pbuf vs
    bufferBez 3 tbuf ws
    bufferColor 4 cbuf $ V.take (V.length vs) cs
    glBindVertexArray 0

    let cleanupFunction = do
          withArray [pbuf, tbuf, cbuf] $ glDeleteBuffers 3
          withArray [vao] $ glDeleteVertexArrays 1
        num = fromIntegral $ V.length vs
        renderFunction t = do
          glUseProgram sh
          pj <- orthoContextProjection win
          let (mv,a,m,mr) = unwrapTransforms t
          updatePrimitive sh PrimBez
          updateProjection sh pj
          updateModelView sh mv
          updateHasUV sh False
          updateAlpha sh a
          updateMultiply sh m
          case mr of
            Just c -> do updateShouldReplaceColor sh True
                         updateReplacementColor sh c
            _      -> updateShouldReplaceColor sh False
          drawBuffer sh vao GL_TRIANGLES num
    return (cleanupFunction,renderFunction)

textureBezRenderer :: Context -> Simple2DShader
                   -> Vector (V2 Float) -> Vector (V2 Float) -> IO Renderer2
textureBezRenderer win sh vs cs = do
  let ws = bezWinding vs
  withVAO $ \vao -> withBuffers 3 $ \[pbuf, tbuf, cbuf] -> do
    enableAttribsForBezs True
    bufferPosition 2 pbuf vs
    bufferBez 3 tbuf ws
    bufferUV 2 cbuf cs
    glBindVertexArray 0

    let cleanupFunction = do
            withArray [pbuf, tbuf, cbuf] $ glDeleteBuffers 3
            withArray [vao] $ glDeleteVertexArrays 1
        num = fromIntegral $ V.length vs
        renderFunction t = do
          glUseProgram sh
          pj <- orthoContextProjection win
          let (mv,a,m,mr) = unwrapTransforms t
          updatePrimitive sh PrimBez
          updateProjection sh pj
          updateModelView sh mv
          updateHasUV sh True
          updateSampler sh 0
          updateAlpha sh a
          updateMultiply sh m
          case mr of
            Just c -> do updateShouldReplaceColor sh True
                         updateReplacementColor sh c
            _      -> updateShouldReplaceColor sh False
          drawBuffer sh vao GL_TRIANGLES num
    return (cleanupFunction,renderFunction)

maskRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float)
             -> Vector (V2 Float) -> IO Renderer2
maskRenderer win sh mode vs uvs =
    withVAO $ \vao -> withBuffers 2 $ \[pbuf, uvbuf] -> do
let vs '   = V.map realToFrac $
               ( V.fromList .  ) vs : : Vector GLfloat
     uvs ' = V.map realToFrac $
               ( V.fromList . F.toList ) uvs : : Vector GLfloat

        enableAttribsForMask
        bufferPosition 2 pbuf vs
        bufferUV 2 uvbuf uvs
        glBindVertexArray 0

        let cleanup = do withArray [pbuf, uvbuf] $ glDeleteBuffers 2
                         withArray [vao] $ glDeleteVertexArrays 1
            num = fromIntegral $ V.length vs
            render t = do
                let (mv,a,m,_) = unwrapTransforms t
                pj <- orthoContextProjection win
updateUniformsForMask ( unShader sh )   a m 0 1
                updateProjection sh pj
                updateModelView sh mv
                updateAlpha sh a
                updateMultiply sh m
                updateMainTex sh 0
                updateMaskTex sh 1
                drawBuffer sh vao mode num
        return (cleanup,render)

alphaMask :: Context -> Simple2DShader -> IO () -> IO () -> IO Renderer2
alphaMask win mrs r2 r1 = do
    mainTex <- toTextureUnit (Just GL_TEXTURE0) win r2
    maskTex <- toTextureUnit (Just GL_TEXTURE1) win r1
    (w,h)   <- ctxWindowSize win
    let vs = V.fromList $ map (fmap fromIntegral) [V2 0 0, V2 w 0, V2 w h, V2 0 h]
        uvs = V.fromList [V2 0 1, V2 1 1, V2 1 0, V2 0 0]
    (c,f) <- maskRenderer win mrs GL_TRIANGLE_FAN vs uvs
    let f' _ = do glActiveTexture GL_TEXTURE0
                  glBindTexture GL_TEXTURE_2D mainTex
                  glActiveTexture GL_TEXTURE1
                  glBindTexture GL_TEXTURE_2D maskTex
        c'    = withArray [mainTex,maskTex] $ glDeleteTextures 2
        f'' _ = do glActiveTexture GL_TEXTURE0
                   glBindTexture GL_TEXTURE_2D 0
                   glActiveTexture GL_TEXTURE1
                   glBindTexture GL_TEXTURE_2D 0
    return (c >> c', \t -> f' t >> f t >> f'' t)

stencilMask :: IO () -> IO () -> IO ()
stencilMask r2 r1  = do
    glClear GL_DEPTH_BUFFER_BIT
    glEnable GL_STENCIL_TEST
    glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
    glDepthMask GL_FALSE
    glStencilMask 0xFF
    glClear GL_STENCIL_BUFFER_BIT
    glStencilFunc GL_NEVER 0 1
    glStencilOp GL_INVERT GL_INVERT GL_INVERT
    r1

    glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
    glDepthMask GL_TRUE
    glStencilFunc GL_EQUAL 1 1
    glStencilOp GL_ZERO GL_ZERO GL_ZERO
    r2
    glDisable GL_STENCIL_TEST

transformRenderer :: [RenderTransform2] -> Renderer2 -> Renderer2
transformRenderer ts (c, r) = (c, r . (ts ++))
loadImage :: FilePath -> IO (Maybe (V2 Int, GLuint))
loadImage fp = readImage fp >>= maybeLoadTexture

loadImageAsTexture :: FilePath -> IO (Maybe GLuint)
loadImageAsTexture fp = do
  edyn <- readImage fp
  fmap snd <$> maybeLoadTexture edyn

maybeLoadTexture :: Either String DynamicImage -> IO (Maybe (V2 Int, GLuint))
maybeLoadTexture strOrImg = case strOrImg of
    Left err -> putStrLn err >> return Nothing
    Right i  -> Just <$> loadTexture i

loadTexture :: DynamicImage -> IO (V2 Int, GLuint)
loadTexture = loadTextureUnit Nothing

allocAndActivateTex :: GLenum -> IO GLuint
allocAndActivateTex u = do
    [t] <- allocaArray 1 $ \ptr -> do
        glGenTextures 1 ptr
        peekArray 1 ptr
    glActiveTexture u
    glBindTexture GL_TEXTURE_2D t
    return t

loadTextureUnit :: Maybe GLuint -> DynamicImage -> IO (V2 Int, GLuint)
loadTextureUnit Nothing img = loadTextureUnit (Just GL_TEXTURE0) img
loadTextureUnit (Just u) img = do
    t <- allocAndActivateTex u
    (w,h) <- loadJuicy img
  Generate mipmaps now ! ! !
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST_MIPMAP_NEAREST
    glBindTexture GL_TEXTURE_2D 0
    return (V2 w h, t)

unloadTexture :: GLuint -> IO ()
unloadTexture t = withArray [t] $ glDeleteTextures 1

loadJuicy :: DynamicImage -> IO (Int,Int)
loadJuicy (ImageY8 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_BYTE
loadJuicy (ImageY16 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_SHORT
loadJuicy (ImageYF (Image w h d)) = bufferImageData w h d GL_RED GL_FLOAT
loadJuicy (ImageYA8 i) = loadJuicy $ ImageRGB8 $ promoteImage i
loadJuicy (ImageYA16 i) = loadJuicy $ ImageRGBA16 $ promoteImage i
loadJuicy (ImageRGB8 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_BYTE
loadJuicy (ImageRGB16 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_SHORT
loadJuicy (ImageRGBF (Image w h d)) = bufferImageData w h d GL_RGB GL_FLOAT
loadJuicy (ImageRGBA8 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_BYTE
loadJuicy (ImageRGBA16 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_SHORT
loadJuicy (ImageYCbCr8 i) = loadJuicy $ ImageRGB8 $ convertImage i
loadJuicy (ImageCMYK8 i) = loadJuicy $ ImageRGB8 $ convertImage i
loadJuicy (ImageCMYK16 i) = loadJuicy $ ImageRGB16 $ convertImage i

toTexture :: Context -> IO () -> IO GLuint
toTexture = toTextureUnit Nothing

toTextureUnit :: Maybe GLuint -> Context -> IO () -> IO GLuint
toTextureUnit Nothing win r = toTextureUnit (Just GL_TEXTURE0) win r
toTextureUnit (Just u) win r = do
    [fb] <- allocaArray 1 $ \ptr -> do
        glGenFramebuffers 1 ptr
        peekArray 1 ptr
    glBindFramebuffer GL_FRAMEBUFFER fb

    t <- allocAndActivateTex u

    (w,h) <- ctxWindowSize win
    let [w',h'] = map fromIntegral [w,h]

    initializeTexImage2D w' h'

    glFramebufferTexture GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 t 0
    withArray [GL_COLOR_ATTACHMENT0] $ glDrawBuffers 1

    status <- glCheckFramebufferStatus GL_FRAMEBUFFER
    if status /= GL_FRAMEBUFFER_COMPLETE
    then putStrLn "incomplete framebuffer!"
    else do glClearColor 0 0 0 0
            glClear GL_COLOR_BUFFER_BIT
            glViewport 0 0 w' h'
            r
            glBindFramebuffer GL_FRAMEBUFFER 0
            with fb $ glDeleteFramebuffers 1
            (fbw, fbh) <- ctxFramebufferSize win
            glViewport 0 0 (fromIntegral fbw) (fromIntegral fbh)
    return t

initializeTexImage2D :: GLsizei -> GLsizei -> IO ()
initializeTexImage2D w h = do
  glTexImage2D GL_TEXTURE_2D 0 GL_RGBA w h 0 GL_RGBA GL_UNSIGNED_BYTE nullPtr
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST

type ClippingArea = (V2 Int, V2 Int)

clipTexture :: GLuint -> ClippingArea -> IO GLuint
clipTexture rtex (V2 x1 y1, V2 x2 y2) = do
    [fbread,fbwrite] <- allocaArray 2 $ \ptr -> do
        glGenFramebuffers 2 ptr
        peekArray 2 ptr
    glBindFramebuffer GL_READ_FRAMEBUFFER fbread
    glFramebufferTexture2D GL_READ_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D rtex 0
    clearErrors "clipTexture bind read framebuffer"
    [wtex] <- allocaArray 1 $ \ptr -> do
        glGenTextures 1 ptr
        peekArray 1 ptr
    glActiveTexture GL_TEXTURE0
    glBindTexture GL_TEXTURE_2D wtex
    let [x1',y1',x2',y2',w',h'] = map fromIntegral
                                      [x1,y1,x2,y2,abs $ x2 - x1
                                                  ,abs $ y2 - y1]
    initializeTexImage2D w' h'
    glBindFramebuffer GL_DRAW_FRAMEBUFFER fbwrite
    glFramebufferTexture2D GL_DRAW_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D wtex 0
    clearErrors "clipTexture bind write framebuffer"
    forM_ [GL_READ_FRAMEBUFFER,GL_DRAW_FRAMEBUFFER] $ \fb -> do
        status <- glCheckFramebufferStatus fb
        when (status /= GL_FRAMEBUFFER_COMPLETE) $ do
            putStrLn "incomplete framebuffer!"
            exitFailure
    glBlitFramebuffer x1' y1' x2' y2' 0 0 w' h' GL_COLOR_BUFFER_BIT GL_NEAREST
    clearErrors "clipTexture blit framebuffers"
    glBindFramebuffer GL_FRAMEBUFFER 0
    withArray [fbread,fbwrite] $ glDeleteFramebuffers 2
    glBindTexture GL_TEXTURE_2D 0
    return wtex
bufferImageData :: forall a a1 a2. (Storable a2, Integral a1, Integral a) => a -> a1 -> S.Vector a2 -> GLenum -> GLenum -> IO (a,a1)
bufferImageData w h dat imgfmt pxfmt = S.unsafeWith dat $ \ptr -> do
    glTexImage2D
        GL_TEXTURE_2D
        0
        GL_RGBA
        (fromIntegral w)
        (fromIntegral h)
        0
        imgfmt
        pxfmt
        (castPtr ptr)
    err <- glGetError
    when (err /= 0) $ putStrLn $ "glTexImage2D Error: " ++ show err
    return (w,h)

withVAO :: (GLuint -> IO b) -> IO b
withVAO f = do
    [vao] <- allocaArray 1 $ \ptr -> do
        glGenVertexArrays 1 ptr
        peekArray 1 ptr
    glBindVertexArray vao
    r <- f vao
    clearErrors "withVAO"
    glBindVertexArray 0
    return r

withBuffers :: Int -> ([GLuint] -> IO b) -> IO b
withBuffers n f = do
    bufs <- allocaArray n $ \ptr -> do
        glGenBuffers (fromIntegral n) ptr
        peekArray (fromIntegral n) ptr
    f bufs

 : : ( Storable a , Unbox a )
bufferAttrib attr n buf as = do
     let  = locToGLuint attr
         asize = V.length as * sizeOf ( V.head as )
         f = S.convert : : ( G.Vector Vector a , Storable a )
     glBindBuffer GL_ARRAY_BUFFER buf
      ( f as ) $ \ptr - >
     glEnableVertexAttribArray loc
         GL_FALSE 0 nullPtr

drawBuffer :: GLuint
           -> GLuint
           -> GLenum
           -> GLsizei
           -> IO ()
drawBuffer program vao mode num = do
    glUseProgram program
    glBindVertexArray vao
    clearErrors "drawBuffer:glBindVertex"
    glDrawArrays mode 0 num
    clearErrors "drawBuffer:glDrawArrays"

clearErrors :: String -> IO ()
clearErrors str = do
    err' <- glGetError
    when (err' /= 0) $ do
      putStrLn $ unwords [str, show err']
      assert False $ return ()
