{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Types.Graphics.IndexBuffer where

import Affection

import qualified Graphics.Rendering.OpenGL as GL

import SDL (($=))

import Data.String (fromString)

import qualified Data.Vector.Storable as VS

import Control.Monad (when)
import Control.Monad.Loops (whileM_)

import Control.Concurrent.STM

import Foreign
import Foreign.C.Types

-- internal imports

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

-- layout of the IndexBuffer data object
data IndexBuffer = IndexBuffer
  { iBufId    :: TVar GL.BufferObject -- buffer id
  , iBufSize  :: TVar GL.GLsizeiptr   -- size of data
  -- , iBufData  :: Ptr a           -- pointer to data
  , iBufCount :: TVar GL.GLint        -- number of data elements
  }

-- instanciate typeclass from Buffer and fill in missing implementations
instance Buffer IndexBuffer where

  type StoreType IndexBuffer = GL.GLuint

  type StoreContainer IndexBuffer = VS.Vector

  target _ = GL.ElementArrayBuffer

  glId = readTVarIO . iBufId

  initialize buf = do
    -- bind the buffer using the default iplementation of the typeclass
    bind buf
    size <- readTVarIO $ iBufSize 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 (iBufSize buf)
        pure $ (fromIntegral offset + VS.length dat) *
          sizeOf (undefined :: StoreType IndexBuffer)
          > fromIntegral currentSize)
       $ do
         currentBufSize <- readTVarIO (iBufSize buf)
         allocaArray
           (fromIntegral currentBufSize `div`
             sizeOf (undefined :: StoreType IndexBuffer))
           $ \ (ptr :: Ptr (StoreType IndexBuffer)) -> 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
    let elemCount = fromIntegral offset + VS.length dat
    logIO Verbose ("elemCount: " <> (fromString $ show elemCount))
    currentCount <- atomically $ readTVar (iBufCount buf)
    when (fromIntegral elemCount > currentCount) $
      atomically $ writeTVar (iBufCount buf) (fromIntegral elemCount)
    VS.unsafeWith dat $ \ ptr ->
      GL.bufferSubData
        (target buf)
        GL.WriteToBuffer
        (CPtrdiff $ fromIntegral offset *
          fromIntegral (sizeOf (undefined :: StoreType IndexBuffer)))
        (CPtrdiff $ fromIntegral $
          VS.length dat * sizeOf (undefined :: StoreType IndexBuffer))
        ptr

  expand buf = do
    unbind buf
    delete buf
    newId <- GL.genObjectName
    newSize <- (2 *) <$> readTVarIO (iBufSize buf)
    atomically $ do
      writeTVar (iBufId buf) newId
      writeTVar (iBufSize buf) newSize
    initialize buf

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


instance Bindable IndexBuffer 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

newIndexBuffer
  :: Word
  -> IO IndexBuffer  -- newly built IndexBuffer data object
newIndexBuffer initLength = do
  -- create the buffer object in applicative style
  buf <- IndexBuffer
    -- generate the ID
    <$> (newTVarIO =<< GL.genObjectName)
    -- compute buffer size
    <*> newTVarIO (CPtrdiff (fromIntegral $
      (fromIntegral initLength * sizeOf (undefined :: StoreType IndexBuffer))))
    -- -- make pointer out of list
    -- <*> newArray list
    -- -- get count
    <*> newTVarIO 0
  -- fill the data in to the buffer
  initialize buf
  -- return the data object
  return buf
