From 7a54887c623c9328470a1ba302fa4b1c8373cb75 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 21 Apr 2019 05:16:17 -0400 Subject: Signatures, comments, dead-code removal. --- src/LambdaCube/GL/Backend.hs | 13 +++++++++++++ src/LambdaCube/GL/Input.hs | 3 +++ src/LambdaCube/GL/Mesh.hs | 19 ++++++++++++++++--- src/LambdaCube/GL/Util.hs | 1 - 4 files changed, 32 insertions(+), 4 deletions(-) (limited to 'src/LambdaCube') diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs index 1cf3f62..c5e3190 100644 --- a/src/LambdaCube/GL/Backend.hs +++ b/src/LambdaCube/GL/Backend.hs @@ -220,7 +220,10 @@ clearRenderTarget GLRenderTarget{..} values = do (mask,_) <- foldM setClearValue (0,0) values glClear $ fromIntegral mask +printGLStatus :: IO () printGLStatus = checkGL >>= print + +printFBOStatus :: IO () printFBOStatus = checkFBO >>= print compileProgram :: Program -> IO GLProgram @@ -777,6 +780,8 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_ --isOk <- checkGL --putStrLn $ isOk ++ " - " ++ show cmd +setupRenderTarget :: IORef (Maybe InputConnection) + -> GLRenderTarget -> IO () setupRenderTarget glInput GLRenderTarget{..} = do -- set target viewport ic' <- readIORef glInput @@ -792,6 +797,11 @@ setupRenderTarget glInput GLRenderTarget{..} = do Nothing -> return () Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl) +setupDrawContext :: IORef Bool + -> IORef GLDrawContext + -> IORef (Maybe InputConnection) + -> GLDrawContext + -> IO () setupDrawContext glForceSetup glDrawContextRef glInput new = do old <- readIORef glDrawContextRef writeIORef glDrawContextRef new @@ -878,6 +888,7 @@ data CGState , samplerMapping :: IntMap GLSampler } +initCGState :: CGState initCGState = CGState { drawCommands = mempty -- draw context data @@ -895,6 +906,8 @@ type CG a = State CGState a emit :: GLCommand -> CG () emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s} +drawContext :: MonadState CGState m => + Vector GLProgram -> m GLDrawContext drawContext programs = do GLProgram{..} <- (programs !) <$> gets currentProgram let f = take (Map.size inputTextures) . IntMap.toList diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs index 30125d9..5d2a49e 100644 --- a/src/LambdaCube/GL/Input.hs +++ b/src/LambdaCube/GL/Input.hs @@ -397,6 +397,7 @@ type UniM = Writer [Map GLUniformName InputSetter -> IO ()] class UniformSetter a where (@=) :: GLUniformName -> IO a -> UniM () +setUniM :: (n -> Map GLUniformName InputSetter -> a -> IO ()) -> n -> IO a -> UniM () setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act] instance UniformSetter Bool where (@=) = setUniM uniformBool @@ -426,10 +427,12 @@ instance UniformSetter M43F where (@=) = setUniM uniformM43F instance UniformSetter M44F where (@=) = setUniM uniformM44F instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D +updateUniforms :: GLStorage -> UniM a -> IO () updateUniforms storage m = sequence_ l where setters = uniformSetter storage l = map ($ setters) $ execWriter m +updateObjectUniforms :: Object -> UniM a -> IO () updateObjectUniforms object m = sequence_ l where setters = objectUniformSetter object l = map ($ setters) $ execWriter m diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs index 95ca582..384cdd1 100644 --- a/src/LambdaCube/GL/Mesh.hs +++ b/src/LambdaCube/GL/Mesh.hs @@ -46,13 +46,18 @@ data GPUMesh , gpuData :: GPUData } -addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object +addMeshToObjectArray :: GLStorage + -> String -- ^ Slot name for a PrimitiveStream. + -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'. + -> GPUMesh + -> IO Object addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do -- select proper attributes let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input filterStream n _ = Map.member n slotStreams addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames +withV :: (v a -> (Ptr a -> io) -> io) -> v a -> (Ptr () -> io) -> io withV w a f = w a (\p -> f $ castPtr p) meshAttrToArray :: MeshAttribute -> Array @@ -77,11 +82,17 @@ meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v) meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) -updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () +-- | Update a mesh without allocating new buffer objects. Each update must +-- provide new values for all existing array elements. +updateMesh :: GPUMesh -- ^ Mesh to be updated. + -> [(String,MeshAttribute)] -- ^ A list of updates. + -> Maybe MeshPrimitive -- ^ Ignored. + -> IO () updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do -- check type match let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 - ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let a2 = fromMaybe (error $ "missing mesh attribute: " ++ n) $ Map.lookup n dMA] + ok = and [ Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) + | (n,a1) <- al, let a2 = fromMaybe (error $ "missing mesh attribute: " ++ n) $ Map.lookup n dMA] if not ok then putStrLn "updateMesh: attribute mismatch!" else do forM_ al $ \(n,a) -> do @@ -98,6 +109,8 @@ updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do (a,b) -> a == b -} +-- | This allocates buffer objects. Use 'disposeMesh' to free them. Use +-- 'updateMesh' to modify the allocated buffer object data. uploadMeshToGPU :: Mesh -> IO GPUMesh uploadMeshToGPU mesh@(Mesh attrs mPrim) = do let mkIndexBuf v = do diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs index b267c7f..fbc0f50 100644 --- a/src/LambdaCube/GL/Util.hs +++ b/src/LambdaCube/GL/Util.hs @@ -260,7 +260,6 @@ fromGLType (t,1) | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube | otherwise = error "Failed fromGLType" -fromGLUniformType _ = error "Failed fromGLType" printShaderLog :: GLuint -> IO String printShaderLog o = do -- cgit v1.2.3