{-# LANGUAGE LambdaCase, RecordWildCards, DataKinds #-}
module PointPrimitiveRing where

import Control.Monad
import Control.Monad.Writer
import Data.Data
import Data.Dependent.Sum
import Data.Foldable
import Data.Function
import Data.Int
import Data.IORef
import Data.Maybe
import Data.Some
import Data.Word
import qualified Data.Map.Strict as Map
import qualified Data.Vector as V
         ;import Data.Vector as V ((!),(//))
import Foreign.C.Types (CPtrdiff)
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable

import LambdaCube.GL      as LC
import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
import LambdaCube.GL.Mesh as LC
import LambdaCube.GL.Type
import LambdaCube.IR      as LC
import LambdaCube.GL.Util
import LambdaCube.GL.Input.Type
import LambdaCube.GL.Input hiding (createObjectCommands)

import AttributeData

-- import Graphics.GL.Core33

import MaskableStream

data Ring keys = Ring
    { rBufferObject :: Buffer
    , rStorage      :: GLStorage
    , rObject       :: Object
    , rSize         :: IORef Int -- Current count of vertices in the ring buffer.
    , rBack         :: IORef Int -- Where next vertex will be added.
    , ringCapacity  :: Int       -- Maximum number of vertices in buffer.
    , rKeys         :: keys
    }

newRing :: Data keys => GLStorage -> Int -> (String -> String) -> IO (Ring keys)
newRing storage sz toAttr = fix $ \retProxy -> do
    let paramProxy = paramProxy' retProxy
            where paramProxy' :: io (ring keys) -> Proxy keys
                  paramProxy' _ = Proxy
    startRef <- newIORef 0
    sizeRef <- newIORef 0
    let ps = fieldParameters paramProxy toAttr
    putStrLn $ "Ring params: " ++ show ps
    gd <- uploadDynamicBuffer sz ps
    Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr)
    obj <- addToObjectArray storage "Points" [] gd
    readIORef (objCommands obj) >>= mapM_ print
    let r = Ring
            { rBufferObject = streamBuffer $ head $ Map.elems (dStreams gd)
            , rStorage      = storage
            , rObject       = obj
            , rSize         = sizeRef
            , rBack         = startRef
            , ringCapacity  = sz
            , rKeys         = keys
            }
    updateRingCommands r
    return r

updateRingCommands :: Ring keys -> IO ()
updateRingCommands r = do
    back <- fromIntegral <$> readIORef (rBack r)
    size  <- fromIntegral <$> readIORef (rSize r)
    let mask 0   = []
        mask cnt
            | cnt==size = [(0,cnt)]
            | otherwise = case cnt + back - size of
                front | front > cnt -> [(front - cnt,size)]
                      | otherwise   -> [(0,back), (front,cnt - front)]
    updateCommands (rStorage r) (rObject r) mask
    -- readIORef (objCommands $ rObject r) >>= mapM_ print
    return ()

pushBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
pushBack r attrs = do
    back <- readIORef $ rBack r
    writeIORef (rBack r) (mod (back + 1) (ringCapacity r))
    updateAttributes back $ attrs (rKeys r)
    sz <- readIORef (rSize r)
    when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1)
    updateRingCommands r

updateBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
updateBack r attrs = do
    back <- readIORef $ rBack r
    updateAttributes (mod (back - 1) (ringCapacity r)) $ attrs (rKeys r)

updateRingUniforms :: GLStorage -> Ring keys -> IO ()
updateRingUniforms _ _ = return ()