diff options
Diffstat (limited to 'src/LambdaCube/GL')
-rw-r--r-- | src/LambdaCube/GL/Backend.hs | 9 | ||||
-rw-r--r-- | src/LambdaCube/GL/Input.hs | 5 | ||||
-rw-r--r-- | src/LambdaCube/GL/Mesh.hs | 4 |
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 | |||
4 | import Control.Applicative | 4 | import Control.Applicative |
5 | import Control.Monad | 5 | import Control.Monad |
6 | import Control.Monad.State | 6 | import Control.Monad.State |
7 | import Data.Maybe | ||
7 | import Data.Bits | 8 | import Data.Bits |
8 | import Data.IORef | 9 | import Data.IORef |
9 | import Data.IntMap (IntMap) | 10 | import 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 | ||
270 | compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget | 271 | compileRenderTarget :: 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 | |||
5 | import Control.Exception | 5 | import Control.Exception |
6 | import Control.Monad | 6 | import Control.Monad |
7 | import Control.Monad.Writer | 7 | import Control.Monad.Writer |
8 | import Data.Maybe | ||
8 | import Data.IORef | 9 | import Data.IORef |
9 | import Data.Map (Map) | 10 | import Data.Map (Map) |
10 | import Data.IntMap (IntMap) | 11 | import 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 | |||
50 | addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object | 50 | addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object |
51 | addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do | 51 | addMeshToObjectArray 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 ( | |||
82 | updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do | 82 | updateMesh (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 |