{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Types.Graphics.VertexBuffer where

import qualified Graphics.Rendering.OpenGL as GL

import SDL (($=), get)

import Control.Monad.Loops (whileM_)

import Control.Concurrent.STM

import qualified Data.Vector.Storable as VS

import Linear

import Foreign
import Foreign
import Foreign.C.Types
import Foreign.Storable.Generic

import GHC.Generics

-- internal imports

import Classes.Graphics.Bindable
import Classes.Graphics.Buffer
import Classes.Graphics.VertexLayout

-- | layout of the VertexBuffer data object
data VertexBuffer = VertexBuffer
  { vBufId   :: TVar GL.BufferObject -- ^ buffer id
  , vBufSize :: TVar GL.GLsizeiptr   -- ^ size of data
  -- , vBufData :: Ptr a           -- pointer to data
  }

data Vertex = Vertex
  { vertPosition :: V3 GL.GLfloat
  , vertColor    :: V4 GL.GLfloat
  , vertTexCoord :: V2 GL.GLfloat
  , vertTexID    :: GL.GLfloat
  }
  deriving (Generic)

-- | make vertices instances of 'Storable'. it's a kind of magic ^.^
instance GStorable Vertex
instance GStorable (V2 GL.GLfloat)
instance GStorable (V3 GL.GLfloat)
instance GStorable (V4 GL.GLfloat)

-- | Smart constructor for a new Vertex
newVertex
 :: V3 GL.GLfloat
 -> V4 GL.GLfloat
 -> V2 GL.GLfloat
 -> GL.GLfloat
 -> Vertex
newVertex pos color texcoord index =
  Vertex
    pos
    color
    texcoord
    index

-- | Instanciate typeclass Buffer and fill in missing implementations
instance Buffer VertexBuffer where

  type StoreType VertexBuffer = Vertex

  type StoreContainer VertexBuffer = VS.Vector

  target _ = GL.ArrayBuffer

  glId = readTVarIO . vBufId

  initialize buf = do
    -- bind the buffer using the default iplementation of the typeclass
    bind buf
    size <- readTVarIO (vBufSize buf)
    -- fill in the data
    GL.bufferData (target buf) $=
      ( size
      , nullPtr
      , GL.DynamicDraw
      )
    -- release the buffer using the default implementation of the typeclass
    unbind buf

  write buf offset dat = do
    whileM_
      (do
        currentSize <- readTVarIO (vBufSize buf)
        pure $ (fromIntegral offset + VS.length dat) *
          sizeOf (undefined :: StoreType VertexBuffer)
          > fromIntegral currentSize)
      $ do
        currentBufSize <- readTVarIO (vBufSize buf)
        allocaArray
          (fromIntegral currentBufSize `div`
            sizeOf (undefined :: StoreType VertexBuffer))
          $ \ (ptr :: Ptr (StoreType VertexBuffer)) -> do
            bind buf
            GL.bufferSubData
              (target buf)
              GL.ReadFromBuffer
              0
              currentBufSize
              ptr
            expand buf
            bind buf
            GL.bufferSubData
              (target buf)
              GL.WriteToBuffer
              0
              currentBufSize
              ptr
    -- bind buffer, just to be safe
    bind buf
    VS.unsafeWith dat $ \ ptr ->
      GL.bufferSubData
        (target buf)
          -- target buffer type
        GL.WriteToBuffer
          -- data access direction
        (CPtrdiff $ fromIntegral offset *
          fromIntegral (sizeOf (undefined :: StoreType VertexBuffer)))
          -- offset from buffer start
        (CPtrdiff $ fromIntegral $
          VS.length dat * sizeOf (undefined :: StoreType VertexBuffer))
          -- length of data to write
        ptr
          -- pointer to first data object

  --le | expand the buffer to double of it's previous size.
  --   This discards all previously written data and layouts, as internally the
  --   old buffer is discarded and a new buffer allocated.
  expand buf = do
    -- unbind the buffer before meddling with its innards
    unbind buf
    -- free the old buffer
    delete buf
    -- generate new buffer
    newId <- GL.genObjectName
    -- calculate new size
    newSize <- (2 *) <$> readTVarIO (vBufSize buf)
    -- update data object
    atomically $ do
      writeTVar (vBufId buf) newId
      writeTVar (vBufSize buf) newSize
    -- allocate and fill buffer with null data
    initialize buf

  delete buf = do
    unbind buf
    GL.deleteObjectName =<< (readTVarIO $ vBufId buf)

-- | Instanciate Bindable typeclass required by Buffer typeclass implement it
instance Bindable VertexBuffer where

  -- bind the buffer
  bind buf =
    (\a -> GL.bindBuffer (target buf) $= Just a) =<< glId buf

  -- unbind the buffer
  unbind buf =
    GL.bindBuffer (target buf) $= Nothing

-- | smart constructor for a VertexBuffer data object
newVertexBuffer
  :: Word             -- ^ initial Buffer size
  -> IO VertexBuffer  -- ^ newly built VertexBuffer data object
newVertexBuffer initSize = do
  -- let dummyVertex = newVertex (V3 0 0 0) (V4 0 0 0 0) (V2 0 0) 0
  -- create the buffer object in applicative style
  buf <- VertexBuffer
    -- generate the ID
    <$> (newTVarIO =<< GL.genObjectName)
    -- compute buffer size
    <*> (newTVarIO (CPtrdiff (fromIntegral $
      (fromIntegral initSize * sizeOf (undefined :: StoreType VertexBuffer)))))
    -- make pointer out of list
    -- <*> newArray list
  -- fill the data in to the buffer
  initialize buf
  -- return the data object
  return buf

instance VertexLayout Vertex where

  type VertBuffer Vertex = VertexBuffer

  layoutElements _ =
    foldl
      (\acc a@(index, count) -> 
        ( index
        , GL.VertexArrayDescriptor
          count
          GL.Float
          (fromIntegral $ sizeOf (undefined :: Vertex))
          (nullPtr `plusPtr` (sizeOf (undefined :: GL.GLfloat) * fromIntegral
            (sum (map ((\(GL.VertexArrayDescriptor c _ _ _) -> c) . snd) acc))))
        ) : acc
        )
      []
      (zip [0 ..] [3, 4, 2, 1])

  addBuffer vert vb = do
    -- bind vertex buffer to associate them
    bind vb
    -- enable and fill vertex attrib pointer(s)
    let list = layoutElements vert
    mapM_
      (\(index, descriptor) -> do
        GL.vertexAttribArray (GL.AttribLocation index) $= GL.Enabled
        GL.vertexAttribPointer (GL.AttribLocation index) $=
          ( GL.ToNormalizedFloat
          , descriptor
          )
        )
      list
    unbind vb
