module TextureBufferRing where

import Control.Monad
import Data.Int
import Data.IORef
import qualified Data.Map.Strict as Map
import qualified Data.Vector     as V
import Foreign.Marshal.Array
import Foreign.Storable

import LambdaCube.GL      as LC
import LambdaCube.GL.Data (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
import LambdaCube.GL.Mesh as LC
import LambdaCube.IR      as LC

data Ring = Ring
    { ringMax     :: Int
    , ringTexture :: TextureBufferData
    , ringStart   :: IO Int
    , ringSize    :: IO Int
    , pushBack    :: Float -> Float -> Float -> IO ()
    , popFront    :: IO ()
    }

newRing :: GLStorage -> Int -> IO Ring
newRing storage cnt = do
    let ringCapacity = cnt * 3
    tbo <- uploadTextureBufferToGPU ringCapacity
    p <- uploadMeshToGPU Mesh
        { mAttributes = Map.singleton "position" $ A_Float $ V.fromList
            $ replicate ringCapacity 0.0
        , mPrimitive = P_Points
        }
    obj <- addMeshToObjectArray storage "Points" [] p
    LC.updateUniforms storage $ do
        "PointBuffer" @= return tbo
    rstart <- newIORef 0
    rsize <- newIORef 0
    return Ring
        { ringMax     = cnt * 3
        , ringTexture = tbo
        , ringStart   = readIORef rstart
        , ringSize    = readIORef rsize
        , pushBack    = \x y z -> do
                            start <- readIORef rstart
                            allocaArray 3 $ \ptr -> do
                                pokeElemOff ptr 0 x
                                pokeElemOff ptr 1 y
                                pokeElemOff ptr 2 z
                                updateTextureBuffer tbo start 3 ptr
                            writeIORef rstart (mod (start + 3) ringCapacity)
                            sz <- readIORef rsize
                            putStrLn $ "pushBack "++show (sz,start,(x,y,z))
                            when (sz < ringCapacity) $ do
                                writeIORef rsize (sz + 3)
        , popFront    = modifyIORef' rsize $ \s -> if s > 3 then s - 3 else 0
        }

updateRingUniforms storage ring = LC.updateUniforms storage $ do
      "PointsStart" @= fmap (fromIntegral :: Int -> Int32) (ringStart ring)
      "PointsMax" @= return (fromIntegral (ringMax ring) :: Int32)