path: root/MaskableStream.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs, DeriveDataTypeable, StandaloneDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

module MaskableStream where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Writer
import Data.Data
import Data.Foldable
import Data.Function
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 Data.Dependent.Sum
import Data.Some
import Data.GADT.Show
import GHC.TypeLits
import System.IO

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

data Witness c = c => Witness

tagTypable :: TypeTag c -> Witness (Typeable c)
tagTypable TypeBool  = Witness
tagTypable TypeV2B   = Witness
tagTypable TypeV3B   = Witness
tagTypable TypeV4B   = Witness
tagTypable TypeWord  = Witness
tagTypable TypeV2U   = Witness
tagTypable TypeV3U   = Witness
tagTypable TypeV4U   = Witness
tagTypable TypeInt   = Witness
tagTypable TypeV2I   = Witness
tagTypable TypeV3I   = Witness
tagTypable TypeV4I   = Witness
tagTypable TypeFloat = Witness
tagTypable TypeV2F   = Witness
tagTypable TypeV3F   = Witness
tagTypable TypeV4F   = Witness
tagTypable TypeM22F  = Witness
tagTypable TypeM23F  = Witness
tagTypable TypeM24F  = Witness
tagTypable TypeM32F  = Witness
tagTypable TypeM33F  = Witness
tagTypable TypeM34F  = Witness
tagTypable TypeM42F  = Witness
tagTypable TypeM43F  = Witness
tagTypable TypeM44F  = Witness



-- 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


componentCount :: GLABI c -> Int
componentCount x@(IsGLVector _) = fromIntegral $ natVal $ vectorLength x
componentCount x@(IsGLMatrix _) = let (r,c) = matrixDimensions x
                                    in fromIntegral (natVal r) * fromIntegral (natVal c)

uploadDynamicBuffer :: Int -> [Parameter] -> IO GPUData
uploadDynamicBuffer sz params = do
    bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
    glBindBuffer GL_ARRAY_BUFFER bo
    let (mkstreams, mkarrays) = unzip $ mapMaybe attrInfo params
        attrInfo (Parameter n typ) = do
            atyp <- toStreamType typ
            This tt <- witnessType typ
            let abi = glABI tt
                cnt = componentCount abi
                arrtyp = let go :: GLPointerType typ -> ArrayType
                             go = \case GLPrimUInt  -> ArrWord32
                                        GLPrimInt   -> ArrInt32
                                        GLPrimFloat -> ArrFloat
                         in case abi of { IsGLVector p -> go p ; IsGLMatrix p -> go p }
            return ( \b i -> (n, Stream atyp b i 0 sz)
                   , \offset -> ArrayDesc arrtyp (cnt * sz) offset (4 * sz * cnt))
        streams = zipWith ($ buffer) mkstreams [0..]
        arrays = foldr mk (const []) mkarrays 0
            where mk f fin offset = let a = f offset
                                    in a : fin (offset + arrSize a)
        buffer = Buffer (V.fromList arrays) bo
        byteCount = sum $ map arrSize arrays
    glBufferData GL_ARRAY_BUFFER (fromIntegral byteCount) nullPtr GL_DYNAMIC_DRAW
    glBindBuffer GL_ARRAY_BUFFER 0
    let gd = GPUData PointList (Map.fromList streams) 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

deriving instance Data InputType
deriving instance Data ArrayType
deriving instance Data ArrayDesc
deriving instance Data Buffer
instance Typeable c => Data (AttributeKey c) where
  gfoldl f z (AttributeKey tt b offset) = z mk
                                            `f` unwitnessType tt
                                            `f` b
                                            `f` fromIntegral offset
    where
        mk :: Typeable c => InputType -> Buffer -> Int64 -> AttributeKey c
        mk t bo i = fix $ \ret -> case witnessType t of
            Just (This tt) -> case tagTypable tt of
                Witness -> case withTypes tt ret <$> eqT of
                    Just Refl -> AttributeKey tt bo (fromIntegral i)
  toConstr _     = error "AttributeKey.toConstr"
  gunfold _ _    = error "AttributeKey.gunfold"
#if MIN_VERSION_base(4,2,0)
  dataTypeOf _   = mkNoRepType "MaskableStream.AttributeKey"
#else
  dataTypeOf _   = mkNorepType "MaskableStream.AttributeKey"
#endif


data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff

attributeKey :: TypeTaggable c => GPUData -> String -> Maybe (AttributeKey c)
attributeKey dta name = do
    stream <- Map.lookup name (dStreams dta)
    fix $ \mp -> let typ = typeTag (fromJust mp) in case stream of
        Stream t b i _ _ -> do
            let a = bufArrays b ! i
                -- arrType :: ArrayType
                -- arrLength :: Int -- number of 32 bit values
                -- arrOffset :: Int -- byte offset into buffer
                -- arrSize   :: Int -- byte count
                off = arrOffset a
            guard (fromStreamType t == unwitnessType typ)
            Just $ AttributeKey typ b (fromIntegral off)
        _ -> Nothing

lookupAttributeKey :: GPUData -> String -> Maybe (Some AttributeKey)
lookupAttributeKey dta name = do
    stream <- Map.lookup name (dStreams dta)
    case stream of
        Stream t b i _ _ -> do
            let a = bufArrays b ! i
                off = arrOffset a
            This tt <- witnessType (fromStreamType t)
            Just $ This (AttributeKey tt b (fromIntegral off))
        _ -> Nothing

(@<-) :: GLData a c => AttributeKey c -> a -> Writer [DSum AttributeKey GLUniformValue] ()
k @<- v = tell [k :=> GLUniformValue v]

updateAttributes :: Int -> Writer [DSum AttributeKey GLUniformValue] a -> IO ()
updateAttributes i writer = forM_ (execWriter writer) $ \case
    AttributeKey typ b base :=> GLUniformValue a -> do
        glBindBuffer GL_ARRAY_BUFFER (bufGLObj b)
        let abi = glABI typ
            attribSize = 4 * componentCount abi
        case marshalUniform abi a of

            Just (MarshalGLVector with) -> with $ \sz ptr -> do
                let sz' = fromIntegral $ attribSize * (fromIntegral sz)
                glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr

            Just (MarshalGLMatrix with) -> with $ \sz isrowcol ptr -> case isrowcol of
                0 -> do
                    let sz' = fromIntegral $ attribSize * (fromIntegral sz)
                    glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr
                _ -> hPutStrLn stderr $ "WARNING: (TODO) row-major matrix attribute update unimplemented."

            Nothing -> hPutStrLn stderr $ "Warning: dimension mismatch updating " ++ show (unwitnessType typ) ++ " attribute."
        glBindBuffer GL_ARRAY_BUFFER 0