summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL')
-rw-r--r--src/LambdaCube/GL/Backend.hs9
-rw-r--r--src/LambdaCube/GL/Input.hs5
-rw-r--r--src/LambdaCube/GL/Mesh.hs4
3 files changed, 10 insertions, 8 deletions
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 478dfd1..282c281 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -4,6 +4,7 @@ module LambdaCube.GL.Backend where
4import Control.Applicative 4import Control.Applicative
5import Control.Monad 5import Control.Monad
6import Control.Monad.State 6import Control.Monad.State
7import Data.Maybe
7import Data.Bits 8import Data.Bits
8import Data.IORef 9import Data.IORef
9import Data.IntMap (IntMap) 10import Data.IntMap (IntMap)
@@ -264,7 +265,7 @@ compileProgram p = do
264 , inputUniforms = Map.fromList inUniforms 265 , inputUniforms = Map.fromList inUniforms
265 , inputTextures = Map.fromList inTextures 266 , inputTextures = Map.fromList inTextures
266 , inputTextureUniforms = S.fromList $ texUnis 267 , inputTextureUniforms = S.fromList $ texUnis
267 , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let Just attrName = Map.lookup n lcStreamName] 268 , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName]
268 } 269 }
269 270
270compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget 271compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
@@ -393,7 +394,7 @@ compileStreamData s = do
393 buffer <- compileBuffer arrays 394 buffer <- compileBuffer arrays
394 cmdRef <- newIORef [] 395 cmdRef <- newIORef []
395 let toStream (n,i) = (n,Stream 396 let toStream (n,i) = (n,Stream
396 { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s) 397 { streamType = fromMaybe (error $ "missing attribute: " ++ n) $ toStreamType =<< Map.lookup n (IR.streamType s)
397 , streamBuffer = buffer 398 , streamBuffer = buffer
398 , streamArrIdx = i 399 , streamArrIdx = i
399 , streamStart = 0 400 , streamStart = 0
@@ -436,7 +437,7 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
436 uniInputType (GLUniform ty _) = ty 437 uniInputType (GLUniform ty _) = ty
437 438
438 -- object attribute stream commands 439 -- object attribute stream commands
439 streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name attrs] 440 streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]
440 where 441 where
441 attrMap = inputStreams prg 442 attrMap = inputStreams prg
442 attrCmd i s = case s of 443 attrCmd i s = case s of
@@ -603,7 +604,7 @@ setStorage' p@GLRenderer{..} input' = do
603 return (i,Nothing) 604 return (i,Nothing)
604 -- create input connection 605 -- create input connection
605 let sm = slotMap input 606 let sm = slotMap input
606 pToI = [i | n <- glSlotNames, let Just i = Map.lookup n sm] 607 pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "missing object array: " ++ n) $ Map.lookup n sm]
607 iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) 608 iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
608 writeIORef glInput $ Just $ InputConnection idx input pToI iToP 609 writeIORef glInput $ Just $ InputConnection idx input pToI iToP
609 610
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index 0471a57..7a3b809 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -5,6 +5,7 @@ import Control.Applicative
5import Control.Exception 5import Control.Exception
6import Control.Monad 6import Control.Monad
7import Control.Monad.Writer 7import Control.Monad.Writer
8import Data.Maybe
8import Data.IORef 9import Data.IORef
9import Data.Map (Map) 10import Data.Map (Map)
10import Data.IntMap (IntMap) 11import Data.IntMap (IntMap)
@@ -101,7 +102,7 @@ addObject input slotName prim indices attribs uniformNames = do
101 enabled <- newIORef True 102 enabled <- newIORef True
102 index <- readIORef seed 103 index <- readIORef seed
103 modifyIORef seed (1+) 104 modifyIORef seed (1+)
104 (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = Map.lookup n (uniforms sch)] 105 (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let t = fromMaybe (error $ "missing uniform: " ++ n) $ Map.lookup n (uniforms sch)]
105 cmdsRef <- newIORef (V.singleton V.empty) 106 cmdsRef <- newIORef (V.singleton V.empty)
106 let obj = Object 107 let obj = Object
107 { objSlot = slotIdx 108 { objSlot = slotIdx
@@ -216,7 +217,7 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
216 uniInputType (GLUniform ty _) = ty 217 uniInputType (GLUniform ty _) = ty
217 218
218 -- object attribute stream commands 219 -- object attribute stream commands
219 objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name objAttrs] 220 objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs]
220 where 221 where
221 attrMap = inputStreams prg 222 attrMap = inputStreams prg
222 objAttrs = objAttributes obj 223 objAttrs = objAttributes obj
diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs
index 0c56f26..5c16e42 100644
--- a/src/LambdaCube/GL/Mesh.hs
+++ b/src/LambdaCube/GL/Mesh.hs
@@ -50,7 +50,7 @@ data GPUMesh
50addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object 50addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object
51addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do 51addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do
52 -- select proper attributes 52 -- select proper attributes
53 let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input 53 let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input
54 filterStream n _ = Map.member n slotStreams 54 filterStream n _ = Map.member n slotStreams
55 addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames 55 addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames
56 56
@@ -82,7 +82,7 @@ updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO (
82updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do 82updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do
83 -- check type match 83 -- check type match
84 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 84 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
85 ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA] 85 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]
86 if not ok then putStrLn "updateMesh: attribute mismatch!" 86 if not ok then putStrLn "updateMesh: attribute mismatch!"
87 else do 87 else do
88 forM_ al $ \(n,a) -> do 88 forM_ al $ \(n,a) -> do