-- | OpenGL support for Data.Bitmap

{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Data.Bitmap.OpenGL 
  ( makeSimpleBitmapTexture
  , makeTextureFromBitmap
  , texImageFromBitmap
  ) where

--------------------------------------------------------------------------------

import Data.Bitmap.Pure  -- Data.Bitmap.IO

import Graphics.Rendering.OpenGL

--------------------------------------------------------------------------------

-- OpenGL data type
dataType :: PixelComponent t => t -> DataType
dataType t = case pixelComponentType t of
  PctWord8  -> UnsignedByte
  PctWord16 -> UnsignedShort
  PctWord32 -> UnsignedInt
  PctFloat  -> Float

--------------------------------------------------------------------------------

-- OpenGL pixel store
-- unfortunately, it is not really flexible enough :(
data PixelStore = PixelStore
  { _swapBytes    :: Bool 
  , _lsbFirst     :: Bool 
  , _rowLength    :: GLint
  , _skipRows     :: GLint
  , _skipPixels   :: GLint
  , _rowAlignment :: GLint
  , _imageHeight  :: GLint
  , _skipImages   :: GLint
  }
  
getPixelStore :: PixelStoreDirection -> IO PixelStore
getPixelStore dir = do
  sb <- get (swapBytes    dir)
  lf <- get (lsbFirst     dir)
  rl <- get (rowLength    dir)
  sr <- get (skipRows     dir)
  sp <- get (skipPixels   dir)
  ra <- get (rowAlignment dir)
  ih <- get (imageHeight  dir)
  si <- get (skipImages   dir)
  return (PixelStore sb lf rl sr sp ra ih si)
      
setPixelStore :: PixelStoreDirection -> PixelStore -> IO ()
setPixelStore dir (PixelStore sb lf rl sr sp ra ih si) = do
  (swapBytes    dir) $= sb
  (lsbFirst     dir) $= lf
  (rowLength    dir) $= rl
  (skipRows     dir) $= sr
  (skipPixels   dir) $= sp
  (rowAlignment dir) $= ra
  (imageHeight  dir) $= ih
  (skipImages   dir) $= si

{-# SPECIALIZE isValidOpenGLAlignment :: Int -> Bool #-}
isValidOpenGLAlignment :: Integral a => a -> Bool
isValidOpenGLAlignment k = elem k [1,2,4,8]

-- computes the padding of OpenGL pixel rectangle
glPadding :: Int -> Alignment -> PixelComponentType -> NChn -> Padding
glPadding width glalign pct nchn = pad where
  n = nchn
  s = pixelComponentSize pct
  l = width
  b = glalign
  a = if b >= s then b else s
  k = div a s * div (s*n*l+a-1) a   -- OpenGL is a bit weird
  pad = s * (k - n*l)

--------------------------------------------------------------------------------

-- | This function guesses the pixel format from the number of channels:
-- 
-- * 1 ~> Intensity
--
-- * 2 ~> Luminance, Alpha
--
-- * 3 ~> RGB
--
-- * 4 ~> RGBA
--
-- For more control, use 'makeTextureFromBitmap'.
makeSimpleBitmapTexture :: forall s. PixelComponent s => Bitmap s -> IO TextureObject
makeSimpleBitmapTexture bm = do
  let (pf,pif) = case pixelComponentType (undefined::s) of 
        PctWord8 -> case bitmapNChannels bm of
          1 -> (Luminance, Intensity8) -- (Intensity, Intensity8) -- (Alpha, Alpha8)
          2 -> (LuminanceAlpha, Luminance8Alpha8)
          3 -> (RGB, RGB8)
          4 -> (RGBA, RGBA8)  
        _ -> case bitmapNChannels bm of
          1 -> (Luminance, Intensity) -- (Intensity, Intensity')   -- (Alpha, Alpha')
          2 -> (LuminanceAlpha, LuminanceAlpha')
          3 -> (RGB, RGB')
          4 -> (RGBA, RGBA')  
#if OPENGL_VERSION >= 29
  makeTextureFromBitmap bm Texture2D 0 pf pif 0 
#else
  makeTextureFromBitmap bm Nothing   0 pf pif 0 
#endif
  
-- | Creates a new OpenGL texture from a bitmap
makeTextureFromBitmap 
#if OPENGL_VERSION >= 29
  :: (PixelComponent s, TwoDimensionalTextureTarget target) 
  => Bitmap s -> target -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO TextureObject
#else
  :: PixelComponent s 
  => Bitmap s -> Maybe CubeMapTarget -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO TextureObject
#endif  
makeTextureFromBitmap bm cubemap level pf pif border = do
  old_binding <- get (textureBinding Texture2D)
  [tex] <- genObjectNames 1 
  textureBinding Texture2D $= Just tex 
  textureFilter Texture2D $= ((Linear',Nothing),Linear')
  textureWrapMode Texture2D S $= (Repeated,Clamp)
  textureWrapMode Texture2D T $= (Repeated,Clamp)
  texImageFromBitmap bm cubemap level pf pif border   
  textureBinding Texture2D $= old_binding
  return tex

texImageFromBitmap
#if OPENGL_VERSION >= 29
  :: forall s target. (PixelComponent s, TwoDimensionalTextureTarget target) 
  => Bitmap s -> target -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO ()
#else
  :: forall s. PixelComponent s 
  => Bitmap s -> Maybe CubeMapTarget -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO ()
#endif  
texImageFromBitmap bm cubemap level pf pif border = do
  withBitmap bm $ \(width,height) nchn pad ptr -> do
--    old_rowlength <- get (rowLength Unpack)
    old_alignment <- get (rowAlignment Unpack)
    let pdata = PixelData pf (dataType (undefined::s)) ptr  
        size = TextureSize2D (fromIntegral width) (fromIntegral height) 
--    rowLength Unpack $= fromIntegral (bitmapPaddedRowSizeInBytes bm)
    rowAlignment Unpack $= fromIntegral (bitmapRowAlignment bm)
    texImage2D cubemap NoProxy level pif size border pdata
--    rowLength Unpack $= old_rowlength 
    rowAlignment Unpack $= old_alignment
  
--------------------------------------------------------------------------------