Factored lambdacube patch module from ring buffer.

1 files changed, 199 insertions, 0 deletions

diff --git a/MaskableStream.hs b/MaskableStream.hs
new file mode 100644
index 0000000..c023998
--- /dev/null
+++ b/MaskableStream.hs
@@ -0,0 +1,199 @@
+{-# 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
+
+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)
+
+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
+    , envDrawStyle :: Either [(GLint,GLsizei)] (IndexStream Buffer)
+    , tlookup      :: String -> IORef GLint
+    , ulookup      :: String -> GLUniform
+    , alookup      :: String -> Stream Buffer
+    }
+
+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