{-# LANGUAGE LambdaCase, RecordWildCards #-}

-- TODO: Formulate this module as a patch against lambdacube-gl.

module MaskableStream where

import Control.Monad
import Control.Monad.IO.Class
import Data.Foldable
import Data.Int
import Data.IORef
import Data.Maybe
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 Graphics.GL.Core33


-- based on addMeshToObjectArray
addToObjectArray :: GLStorage
                        -> String   -- ^ Slot name for a PrimitiveStream.
                        -> [String] -- ^ Uniform names.  IORefs will be put in 'objUniSetup'.
                        -> GPUData
                        -> IO Object
addToObjectArray input slotName objUniNames (GPUData prim streams indices _) = do
    let ObjectArraySchema _ slotStreams = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName)
                                                    $ Map.lookup slotName $! objectArrays $! schema input
    addObject input slotName prim indices (Map.intersection streams slotStreams) objUniNames

setUniformCommand :: (String -> GLUniform)
                               -> (String,GLint)
                               -> GLObjectCommand
setUniformCommand ulookup (n,i) = GLSetUniform i (ulookup n)

bindTextureCommand :: (String -> IORef GLint)
                   -> (String -> GLUniform)
                   -> String
                   -> GLObjectCommand
bindTextureCommand tlookup ulookup n = GLBindTexture (inputTypeToTextureTarget $ uniInputType u) (tlookup n) u
 where
    u = ulookup n
    uniInputType (GLTypedUniform ty _) = unwitnessType ty
    uniInputType (GLUniform r)         = objectType r

-- One of these:
--    VertexAttribPointer         -- Array
--    VertexAttribIPointer        --  streams.
--    VertexAttribI{1,2,3,4}[u]iv -- constant integer attribute.
-- Or some number of these in sequence:
--    VertexAttrib{1,2,3,4}fv -- constant vector or matrix of floats.
setVertexAttribCommmand :: (t -> Stream Buffer) -> (GLuint, t) -> GLObjectCommand
setVertexAttribCommmand alookup (i,name) = case alookup name of
    Stream ty (Buffer arrs bo) arrIdx start len -> mkAttrCmd i bo n (arrayTypeToGLType arrType) (intPtrToPtr $! offset)
      where
        (n, mkAttrCmd) = classifyStreamType ty
        ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
        offset = fromIntegral (arrOffs + start * fromIntegral n * sizeOfArrayType arrType)

    -- constant generic attribute
    constAttr -> GLSetVertexAttrib i constAttr


lookupOrLookup :: (Ord k, Show k) => String -> Map.Map k a -> Map.Map k a -> k -> a
lookupOrLookup callsite objUnis topUnis n = Map.findWithDefault (topUni n) n objUnis
 where
    topUni n = Map.findWithDefault (error $ "internal error ("++callsite++"): " ++ show n) n topUnis

classifyStreamType :: StreamType -> ( GLint
                                    , GLuint -> GLuint -> GLint -> GLenum -> Ptr () -> GLObjectCommand)
classifyStreamType = \case
    Attribute_Word   -> ( 1 , GLSetVertexAttribIArray )
    Attribute_V2U    -> ( 2 , GLSetVertexAttribIArray )
    Attribute_V3U    -> ( 3 , GLSetVertexAttribIArray )
    Attribute_V4U    -> ( 4 , GLSetVertexAttribIArray )
    Attribute_Int    -> ( 1 , GLSetVertexAttribIArray )
    Attribute_V2I    -> ( 2 , GLSetVertexAttribIArray )
    Attribute_V3I    -> ( 3 , GLSetVertexAttribIArray )
    Attribute_V4I    -> ( 4 , GLSetVertexAttribIArray )
    Attribute_Float  -> ( 1  , GLSetVertexAttribArray )
    Attribute_V2F    -> ( 2  , GLSetVertexAttribArray )
    Attribute_V3F    -> ( 3  , GLSetVertexAttribArray )
    Attribute_V4F    -> ( 4  , GLSetVertexAttribArray )
    Attribute_M22F   -> ( 4  , GLSetVertexAttribArray )
    Attribute_M23F   -> ( 6  , GLSetVertexAttribArray )
    Attribute_M24F   -> ( 8  , GLSetVertexAttribArray )
    Attribute_M32F   -> ( 6  , GLSetVertexAttribArray )
    Attribute_M33F   -> ( 9  , GLSetVertexAttribArray )
    Attribute_M34F   -> ( 12 , GLSetVertexAttribArray )
    Attribute_M42F   -> ( 8  , GLSetVertexAttribArray )
    Attribute_M43F   -> ( 12 , GLSetVertexAttribArray )
    Attribute_M44F   -> ( 16 , GLSetVertexAttribArray )

drawElementsCommand :: GLenum -> IndexStream Buffer -> GLObjectCommand
drawElementsCommand prim (IndexStream (Buffer arrs bo) arrIdx start idxCount)
        = GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
 where
    ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
    idxType = arrayTypeToGLType arrType
    ptr    = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)

-- Note: all enabled attribute arrays should have the same count.
-- So an object should select similarly sized streams from 'dStreams' of GPUData.
-- So the 'mAttributes' map of a Mesh should contain equally sized arrays.
-- uploadMeshToGPU uses a single Buffer for all of a Mesh's attributes.
objectDrawStyle :: (GLsizei -> [(GLint,GLsizei)]) -- ^ mask, normally \x -> [(0,x)]
                    -> Object
                    -> Either [(GLint,GLsizei)] (IndexStream Buffer)
objectDrawStyle streamMask obj = case objIndices obj of
    Nothing -> Left $ let cnt = head [c | Stream _ _ _ _ c <- Map.elems (objAttributes obj)]
                       in streamMask $ fromIntegral cnt
    Just idxStream -> Right idxStream

-- backward-compatible non-masking interface.
createObjectCommands :: Map.Map String (IORef GLint) -> Map.Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand]
createObjectCommands texUnitMap topUnis obj prg =
    createObjectCommands_ (objectEnvironment texUnitMap topUnis obj (pure . ((,) 0))) prg

data ObjectEnvironment = ObjectEnvironment
    { envPrim      :: GLenum -- GL version of LambdaCube.GL.Primitive
    , envDrawStyle :: Either [(GLint,GLsizei)]    -- Mask of array attributes (one draw command for pair).
                             (IndexStream Buffer) -- Indirect P_TriangleStripI or P_TrianglesI indices.
    , tlookup      :: String -> IORef GLint   -- lookup texture unit
    , ulookup      :: String -> GLUniform     -- lookup uniform
    , alookup      :: String -> Stream Buffer -- lookup vertex attribute
    }

objectEnvironment :: Map.Map String (IORef GLint)
                     -> Map.Map String GLUniform
                     -> Object
                     -> (GLsizei -> [(GLint, GLsizei)])
                     -> ObjectEnvironment
objectEnvironment texUnitMap topUnis obj streamMask = ObjectEnvironment
    { envPrim      = primitiveToGLType $ objPrimitive obj
    , envDrawStyle = objectDrawStyle streamMask obj
    , tlookup      = \n -> Map.findWithDefault (error $ "missing texture unit: " ++ show n) n texUnitMap
    , ulookup      = lookupOrLookup "missing uniform: " (objUniSetup obj) topUnis
    , alookup      = \n -> Map.findWithDefault (error $ "missing attribute: " ++ n) n $ objAttributes obj
    }


createObjectCommands_ :: ObjectEnvironment -> GLProgram -> [GLObjectCommand]
createObjectCommands_ ObjectEnvironment{..} prg = concat
    [ map (setUniformCommand ulookup)          $ Map.toList (inputUniforms prg)
    , map (bindTextureCommand tlookup ulookup) $ toList (inputTextureUniforms prg)
    , map (setVertexAttribCommmand alookup)    $ Map.elems (inputStreams prg)
    , case envDrawStyle of
        Left ranges   -> map (uncurry $ GLDrawArrays envPrim) ranges
        Right indexed -> pure $ drawElementsCommand envPrim indexed
    ]

updateCommands :: GLStorage
                  -> Object
                  -> (GLsizei -> [(GLint,GLsizei)])
                  -> IO Object
updateCommands input obj mask = do
    let cmdsRef = objCommands obj :: IORef (V.Vector (V.Vector [GLObjectCommand]))
        slotIdx = objSlot obj :: Int
    ppls <- readIORef $ pipelines input
    cmds <- V.forM (ppls :: V.Vector (Maybe GLRenderer)) $ \mp -> case mp of
        Nothing -> return V.empty
        Just p  -> do
            let env = objectEnvironment (glTexUnitMapping p) (uniformSetup input) obj mask
            Just ic <- readIORef $ glInput p
            case icSlotMapInputToPipeline ic ! slotIdx of
                Nothing         -> return V.empty -- this slot is not used in that pipeline
                Just pSlotIdx   -> do
                    let emptyV = V.replicate (V.length $ glPrograms p) []
                    return $ emptyV // [(prgIdx,createObjectCommands_ env (glPrograms p ! prgIdx))
                                        | prgIdx <- glSlotPrograms p ! pSlotIdx]
    writeIORef cmdsRef cmds
    return obj


-- TODO: Add flexibility.
-- Currently this allocates a buffer consisting of a single named vertex attribute that
-- must be of type V3F.
uploadDynamicBuffer :: Int -> String -> IO GPUData
uploadDynamicBuffer sz attrname = do
    bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
    glBindBuffer GL_ARRAY_BUFFER bo
    let bufsize = 3 * fromIntegral sz
        byteCount = 4 * bufsize
    glBufferData GL_ARRAY_BUFFER byteCount nullPtr GL_DYNAMIC_DRAW
    glBindBuffer GL_ARRAY_BUFFER 0
    let buffer = Buffer (V.singleton $ ArrayDesc ArrFloat (fromIntegral bufsize) 0 (fromIntegral byteCount))
                        bo
        gd = GPUData PointList (Map.singleton attrname $ Stream Attribute_V3F buffer 0 0 sz) Nothing [buffer]
    return gd


incrementalUpdateBuffer :: MonadIO m => Buffer -> GLintptr -> GLsizeiptr -> Ptr a -> m ()
incrementalUpdateBuffer b byteoffset bytecount ptr = do
    glBindBuffer GL_ARRAY_BUFFER (bufGLObj b)
    glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr
    glBindBuffer GL_ARRAY_BUFFER 0