summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL')
-rw-r--r--src/LambdaCube/GL/Backend.hs13
-rw-r--r--src/LambdaCube/GL/Input.hs3
-rw-r--r--src/LambdaCube/GL/Mesh.hs19
-rw-r--r--src/LambdaCube/GL/Util.hs1
4 files changed, 32 insertions, 4 deletions
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
220 (mask,_) <- foldM setClearValue (0,0) values 220 (mask,_) <- foldM setClearValue (0,0) values
221 glClear $ fromIntegral mask 221 glClear $ fromIntegral mask
222 222
223printGLStatus :: IO ()
223printGLStatus = checkGL >>= print 224printGLStatus = checkGL >>= print
225
226printFBOStatus :: IO ()
224printFBOStatus = checkFBO >>= print 227printFBOStatus = checkFBO >>= print
225 228
226compileProgram :: Program -> IO GLProgram 229compileProgram :: Program -> IO GLProgram
@@ -777,6 +780,8 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_
777 --isOk <- checkGL 780 --isOk <- checkGL
778 --putStrLn $ isOk ++ " - " ++ show cmd 781 --putStrLn $ isOk ++ " - " ++ show cmd
779 782
783setupRenderTarget :: IORef (Maybe InputConnection)
784 -> GLRenderTarget -> IO ()
780setupRenderTarget glInput GLRenderTarget{..} = do 785setupRenderTarget glInput GLRenderTarget{..} = do
781 -- set target viewport 786 -- set target viewport
782 ic' <- readIORef glInput 787 ic' <- readIORef glInput
@@ -792,6 +797,11 @@ setupRenderTarget glInput GLRenderTarget{..} = do
792 Nothing -> return () 797 Nothing -> return ()
793 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl) 798 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
794 799
800setupDrawContext :: IORef Bool
801 -> IORef GLDrawContext
802 -> IORef (Maybe InputConnection)
803 -> GLDrawContext
804 -> IO ()
795setupDrawContext glForceSetup glDrawContextRef glInput new = do 805setupDrawContext glForceSetup glDrawContextRef glInput new = do
796 old <- readIORef glDrawContextRef 806 old <- readIORef glDrawContextRef
797 writeIORef glDrawContextRef new 807 writeIORef glDrawContextRef new
@@ -878,6 +888,7 @@ data CGState
878 , samplerMapping :: IntMap GLSampler 888 , samplerMapping :: IntMap GLSampler
879 } 889 }
880 890
891initCGState :: CGState
881initCGState = CGState 892initCGState = CGState
882 { drawCommands = mempty 893 { drawCommands = mempty
883 -- draw context data 894 -- draw context data
@@ -895,6 +906,8 @@ type CG a = State CGState a
895emit :: GLCommand -> CG () 906emit :: GLCommand -> CG ()
896emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s} 907emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s}
897 908
909drawContext :: MonadState CGState m =>
910 Vector GLProgram -> m GLDrawContext
898drawContext programs = do 911drawContext programs = do
899 GLProgram{..} <- (programs !) <$> gets currentProgram 912 GLProgram{..} <- (programs !) <$> gets currentProgram
900 let f = take (Map.size inputTextures) . IntMap.toList 913 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 ()]
397class UniformSetter a where 397class UniformSetter a where
398 (@=) :: GLUniformName -> IO a -> UniM () 398 (@=) :: GLUniformName -> IO a -> UniM ()
399 399
400setUniM :: (n -> Map GLUniformName InputSetter -> a -> IO ()) -> n -> IO a -> UniM ()
400setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act] 401setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act]
401 402
402instance UniformSetter Bool where (@=) = setUniM uniformBool 403instance UniformSetter Bool where (@=) = setUniM uniformBool
@@ -426,10 +427,12 @@ instance UniformSetter M43F where (@=) = setUniM uniformM43F
426instance UniformSetter M44F where (@=) = setUniM uniformM44F 427instance UniformSetter M44F where (@=) = setUniM uniformM44F
427instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D 428instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D
428 429
430updateUniforms :: GLStorage -> UniM a -> IO ()
429updateUniforms storage m = sequence_ l where 431updateUniforms storage m = sequence_ l where
430 setters = uniformSetter storage 432 setters = uniformSetter storage
431 l = map ($ setters) $ execWriter m 433 l = map ($ setters) $ execWriter m
432 434
435updateObjectUniforms :: Object -> UniM a -> IO ()
433updateObjectUniforms object m = sequence_ l where 436updateObjectUniforms object m = sequence_ l where
434 setters = objectUniformSetter object 437 setters = objectUniformSetter object
435 l = map ($ setters) $ execWriter m 438 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
46 , gpuData :: GPUData 46 , gpuData :: GPUData
47 } 47 }
48 48
49addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object 49addMeshToObjectArray :: GLStorage
50 -> String -- ^ Slot name for a PrimitiveStream.
51 -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'.
52 -> GPUMesh
53 -> IO Object
50addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do 54addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do
51 -- select proper attributes 55 -- select proper attributes
52 let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input 56 let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input
53 filterStream n _ = Map.member n slotStreams 57 filterStream n _ = Map.member n slotStreams
54 addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames 58 addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames
55 59
60withV :: (v a -> (Ptr a -> io) -> io) -> v a -> (Ptr () -> io) -> io
56withV w a f = w a (\p -> f $ castPtr p) 61withV w a f = w a (\p -> f $ castPtr p)
57 62
58meshAttrToArray :: MeshAttribute -> Array 63meshAttrToArray :: MeshAttribute -> Array
@@ -77,11 +82,17 @@ meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v)
77meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) 82meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v)
78meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) 83meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v)
79 84
80updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () 85-- | Update a mesh without allocating new buffer objects. Each update must
86-- provide new values for all existing array elements.
87updateMesh :: GPUMesh -- ^ Mesh to be updated.
88 -> [(String,MeshAttribute)] -- ^ A list of updates.
89 -> Maybe MeshPrimitive -- ^ Ignored.
90 -> IO ()
81updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do 91updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do
82 -- check type match 92 -- check type match
83 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 93 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
84 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] 94 ok = and [ Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2)
95 | (n,a1) <- al, let a2 = fromMaybe (error $ "missing mesh attribute: " ++ n) $ Map.lookup n dMA]
85 if not ok then putStrLn "updateMesh: attribute mismatch!" 96 if not ok then putStrLn "updateMesh: attribute mismatch!"
86 else do 97 else do
87 forM_ al $ \(n,a) -> do 98 forM_ al $ \(n,a) -> do
@@ -98,6 +109,8 @@ updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do
98 (a,b) -> a == b 109 (a,b) -> a == b
99-} 110-}
100 111
112-- | This allocates buffer objects. Use 'disposeMesh' to free them. Use
113-- 'updateMesh' to modify the allocated buffer object data.
101uploadMeshToGPU :: Mesh -> IO GPUMesh 114uploadMeshToGPU :: Mesh -> IO GPUMesh
102uploadMeshToGPU mesh@(Mesh attrs mPrim) = do 115uploadMeshToGPU mesh@(Mesh attrs mPrim) = do
103 let mkIndexBuf v = do 116 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)
260 | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer 260 | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer
261 | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube 261 | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube
262 | otherwise = error "Failed fromGLType" 262 | otherwise = error "Failed fromGLType"
263fromGLUniformType _ = error "Failed fromGLType"
264 263
265printShaderLog :: GLuint -> IO String 264printShaderLog :: GLuint -> IO String
266printShaderLog o = do 265printShaderLog o = do