summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL/Input.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL/Input.hs')
-rw-r--r--src/LambdaCube/GL/Input.hs56
1 files changed, 33 insertions, 23 deletions
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index 7e4ba74..9ceb35f 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -1,4 +1,4 @@
1{-# LANGUAGE FlexibleContexts #-} 1{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
2module LambdaCube.GL.Input where 2module LambdaCube.GL.Input where
3 3
4import Control.Applicative 4import Control.Applicative
@@ -22,12 +22,13 @@ import qualified Data.ByteString.Char8 as SB
22 22
23import Graphics.GL.Core33 23import Graphics.GL.Core33
24 24
25import IR as IR 25import LambdaCube.IR as IR
26import Linear as IR 26import LambdaCube.Linear as IR
27import LambdaCube.PipelineSchema
27import LambdaCube.GL.Type as T 28import LambdaCube.GL.Type as T
28import LambdaCube.GL.Util 29import LambdaCube.GL.Util
29 30
30import qualified IR as IR 31import qualified LambdaCube.IR as IR
31 32
32schemaFromPipeline :: IR.Pipeline -> PipelineSchema 33schemaFromPipeline :: IR.Pipeline -> PipelineSchema
33schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul) 34schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul)
@@ -392,29 +393,38 @@ uniformFTexture2D n is = case Map.lookup n is of
392 Just (SFTexture2D fun) -> fun 393 Just (SFTexture2D fun) -> fun
393 _ -> nullSetter n "FTexture2D" 394 _ -> nullSetter n "FTexture2D"
394 395
395a @: b = tell [(a,b)]
396defObjectArray n p m = mapM_ tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.singleton a t) mempty | (a,t) <- execWriter m]
397defUniforms m = tell $ PipelineSchema mempty $ Map.fromList $ execWriter m
398makeSchema a = execWriter a :: PipelineSchema
399
400unionObjectArraySchema (ObjectArraySchema a1 b1) (ObjectArraySchema a2 b2) =
401 ObjectArraySchema (if a1 == a2 then a1 else error $ "object array schema primitive mismatch " ++ show (a1,a2))
402 (Map.unionWith (\a b -> if a == b then a else error $ "object array schema attribute type mismatch " ++ show (a,b)) b1 b2)
403
404instance Monoid PipelineSchema where
405 mempty = PipelineSchema mempty mempty
406 mappend (PipelineSchema a1 b1) (PipelineSchema a2 b2) =
407 PipelineSchema (Map.unionWith unionObjectArraySchema a1 a2) (Map.unionWith (\a b -> if a == b then a else error $ "schema type mismatch " ++ show (a,b)) b1 b2)
408
409type UniM = Writer [GLStorage -> IO ()] 396type UniM = Writer [GLStorage -> IO ()]
410 397
411class UniformSetter a where 398class UniformSetter a where
412 (@=) :: GLUniformName -> IO a -> UniM () 399 (@=) :: GLUniformName -> IO a -> UniM ()
413 400
414instance UniformSetter Float where 401setUniM setUni n act = tell [\s -> let f = setUni n (uniformSetter s) in f =<< act]
415 n @= act = tell [\s -> let f = uniformFloat n (uniformSetter s) in f =<< act] 402
416 403instance UniformSetter Bool where (@=) = setUniM uniformBool
417instance UniformSetter TextureData where 404instance UniformSetter V2B where (@=) = setUniM uniformV2B
418 n @= act = tell [\s -> let f = uniformFTexture2D n (uniformSetter s) in f =<< act] 405instance UniformSetter V3B where (@=) = setUniM uniformV3B
406instance UniformSetter V4B where (@=) = setUniM uniformV4B
407instance UniformSetter Word32 where (@=) = setUniM uniformWord
408instance UniformSetter V2U where (@=) = setUniM uniformV2U
409instance UniformSetter V3U where (@=) = setUniM uniformV3U
410instance UniformSetter V4U where (@=) = setUniM uniformV4U
411instance UniformSetter Int32 where (@=) = setUniM uniformInt
412instance UniformSetter V2I where (@=) = setUniM uniformV2I
413instance UniformSetter V3I where (@=) = setUniM uniformV3I
414instance UniformSetter V4I where (@=) = setUniM uniformV4I
415instance UniformSetter Float where (@=) = setUniM uniformFloat
416instance UniformSetter V2F where (@=) = setUniM uniformV2F
417instance UniformSetter V3F where (@=) = setUniM uniformV3F
418instance UniformSetter V4F where (@=) = setUniM uniformV4F
419instance UniformSetter M22F where (@=) = setUniM uniformM22F
420instance UniformSetter M23F where (@=) = setUniM uniformM23F
421instance UniformSetter M24F where (@=) = setUniM uniformM24F
422instance UniformSetter M32F where (@=) = setUniM uniformM32F
423instance UniformSetter M33F where (@=) = setUniM uniformM33F
424instance UniformSetter M34F where (@=) = setUniM uniformM34F
425instance UniformSetter M42F where (@=) = setUniM uniformM42F
426instance UniformSetter M43F where (@=) = setUniM uniformM43F
427instance UniformSetter M44F where (@=) = setUniM uniformM44F
428instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D
419 429
420updateUniforms storage m = sequence_ $ let l = map ($ storage) $ execWriter m in l 430updateUniforms storage m = sequence_ $ let l = map ($ storage) $ execWriter m in l