summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorCsaba Hruska <csaba.hruska@gmail.com>2016-01-08 12:01:39 +0100
committerCsaba Hruska <csaba.hruska@gmail.com>2016-01-08 12:01:39 +0100
commit64e13239772dae2a73e30bd0aa8ca2c70154987c (patch)
treed5f2e4d528fcf9b7815c2dcec255268413dfd61b
parent65c124310c6aad1fa7a97c547292f8b90a70e991 (diff)
move to LambdaCube.GL, use more descriptive names, update for OpenGLRaw 3.0
Diffstat
-rw-r--r--lambdacube-gl-ir.cabal23
-rw-r--r--src/LambdaCube/GL.hs (renamed from Backend/GL.hs)31
-rw-r--r--src/LambdaCube/GL/Backend.hs (renamed from Backend/GL/Backend.hs)233
-rw-r--r--src/LambdaCube/GL/Data.hs (renamed from Backend/GL/Data.hs)86
-rw-r--r--src/LambdaCube/GL/Input.hs (renamed from Backend/GL/Input.hs)69
-rw-r--r--src/LambdaCube/GL/Mesh.hs (renamed from Backend/GL/Mesh.hs)62
-rw-r--r--src/LambdaCube/GL/Type.hs (renamed from Backend/GL/Type.hs)190
-rw-r--r--src/LambdaCube/GL/Util.hs (renamed from Backend/GL/Util.hs)516
8 files changed, 587 insertions, 623 deletions
diff --git a/lambdacube-gl-ir.cabal b/lambdacube-gl-ir.cabal
index f648d10..79db63d 100644
--- a/lambdacube-gl-ir.cabal
+++ b/lambdacube-gl-ir.cabal
@@ -2,7 +2,7 @@
2-- documentation, see http://haskell.org/cabal/users-guide/ 2-- documentation, see http://haskell.org/cabal/users-guide/
3 3
4name: lambdacube-gl-ir 4name: lambdacube-gl-ir
5version: 0.1.0.0 5version: 0.2.0.0
6-- synopsis: 6-- synopsis:
7-- description: 7-- description:
8homepage: lambdacube3d.com 8homepage: lambdacube3d.com
@@ -20,13 +20,13 @@ library
20 exposed-modules: 20 exposed-modules:
21 --SampleIR 21 --SampleIR
22 -- Backend 22 -- Backend
23 Backend.GL 23 LambdaCube.GL
24 Backend.GL.Backend 24 LambdaCube.GL.Backend
25 Backend.GL.Data 25 LambdaCube.GL.Data
26 Backend.GL.Input 26 LambdaCube.GL.Input
27 Backend.GL.Mesh 27 LambdaCube.GL.Mesh
28 Backend.GL.Type 28 LambdaCube.GL.Type
29 Backend.GL.Util 29 LambdaCube.GL.Util
30 -- other-modules: 30 -- other-modules:
31 other-extensions: 31 other-extensions:
32 LambdaCase 32 LambdaCase
@@ -54,15 +54,14 @@ library
54 bytestring >=0.10 && <0.11, 54 bytestring >=0.10 && <0.11,
55 vector >=0.11 && <0.12, 55 vector >=0.11 && <0.12,
56 bytestring-trie >=0.2 && <0.3, 56 bytestring-trie >=0.2 && <0.3,
57 OpenGLRaw >=2.5 && <2.6,
58 JuicyPixels >=3.2.6.2 && <3.3,
59 vector-algorithms >=0.7 && <0.8, 57 vector-algorithms >=0.7 && <0.8,
60 binary >=0.7 && <0.8, 58 binary >=0.7 && <0.8,
61 GLFW-b >= 1.4.7,
62 vect >= 0.4.7, 59 vect >= 0.4.7,
60 JuicyPixels >=3.2.6.4 && <3.3,
61 OpenGLRaw >=3.0 && <3.1,
63 pretty-show >=1.6 && <1.7, 62 pretty-show >=1.6 && <1.7,
64 lambdacube-ir 63 lambdacube-ir
65 hs-source-dirs: . 64 hs-source-dirs: src
66 default-language: Haskell2010 65 default-language: Haskell2010
67 66
68--executable sampleIR 67--executable sampleIR
diff --git a/Backend/GL.hs b/src/LambdaCube/GL.hs
index 3edb4fa..37ba205 100644
--- a/Backend/GL.hs
+++ b/src/LambdaCube/GL.hs
@@ -1,4 +1,4 @@
1module Backend.GL ( 1module LambdaCube.GL (
2 -- IR 2 -- IR
3 V2(..),V3(..),V4(..), 3 V2(..),V3(..),V4(..),
4 -- Array, Buffer, Texture 4 -- Array, Buffer, Texture
@@ -22,22 +22,23 @@ module Backend.GL (
22 bufferSize, 22 bufferSize,
23 arraySize, 23 arraySize,
24 arrayType, 24 arrayType,
25 compileTexture2DRGBAF, 25 uploadTexture2DToGPU,
26 compileTexture2DRGBAF', 26 uploadTexture2DToGPU',
27 27
28 -- GL Pipeline Input, Object 28 -- GL: Renderer, Storage, Object
29 GLPipeline, 29 GLRenderer,
30 GLPipelineInput, 30 GLStorage,
31 Object, 31 Object,
32 PipelineSchema(..), 32 PipelineSchema(..),
33 SlotSchema(..), 33 SlotSchema(..),
34 schema, 34 schema,
35 schemaFromPipeline, 35 schemaFromPipeline,
36 allocPipeline, 36 allocRenderer,
37 disposePipeline, 37 disposeRenderer,
38 setPipelineInput, 38 setStorage,
39 renderPipeline, 39 renderFrame,
40 mkGLPipelineInput, 40 allocStorage,
41 disposeStorage,
41 uniformSetter, 42 uniformSetter,
42 addObject, 43 addObject,
43 removeObject, 44 removeObject,
@@ -80,9 +81,9 @@ module Backend.GL (
80 uniformFTexture2D 81 uniformFTexture2D
81) where 82) where
82 83
83import Backend.GL.Type 84import LambdaCube.GL.Type
84import Backend.GL.Backend 85import LambdaCube.GL.Backend
85import Backend.GL.Data 86import LambdaCube.GL.Data
86import Backend.GL.Input 87import LambdaCube.GL.Input
87import IR 88import IR
88import Linear 89import Linear
diff --git a/Backend/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 55ae443..7251a78 100644
--- a/Backend/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -1,5 +1,5 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-} 1{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-}
2module Backend.GL.Backend where 2module LambdaCube.GL.Backend where
3 3
4import Control.Applicative 4import Control.Applicative
5import Control.Monad 5import Control.Monad
@@ -23,7 +23,7 @@ import qualified Data.Set as S
23import qualified Data.Vector as V 23import qualified Data.Vector as V
24import qualified Data.Vector.Storable as SV 24import qualified Data.Vector.Storable as SV
25 25
26import Graphics.Rendering.OpenGL.Raw.Core33 26import Graphics.GL.Core33
27import Foreign 27import Foreign
28 28
29-- LC IR imports 29-- LC IR imports
@@ -31,38 +31,38 @@ import Linear
31import IR hiding (streamType) 31import IR hiding (streamType)
32import qualified IR as IR 32import qualified IR as IR
33 33
34import Backend.GL.Type 34import LambdaCube.GL.Type
35import Backend.GL.Util 35import LambdaCube.GL.Util
36 36
37import Backend.GL.Data 37import LambdaCube.GL.Data
38import Backend.GL.Input 38import LambdaCube.GL.Input
39 39
40setupRasterContext :: RasterContext -> IO () 40setupRasterContext :: RasterContext -> IO ()
41setupRasterContext = cvt 41setupRasterContext = cvt
42 where 42 where
43 cff :: FrontFace -> GLenum 43 cff :: FrontFace -> GLenum
44 cff CCW = gl_CCW 44 cff CCW = GL_CCW
45 cff CW = gl_CW 45 cff CW = GL_CW
46 46
47 setProvokingVertex :: ProvokingVertex -> IO () 47 setProvokingVertex :: ProvokingVertex -> IO ()
48 setProvokingVertex pv = glProvokingVertex $ case pv of 48 setProvokingVertex pv = glProvokingVertex $ case pv of
49 FirstVertex -> gl_FIRST_VERTEX_CONVENTION 49 FirstVertex -> GL_FIRST_VERTEX_CONVENTION
50 LastVertex -> gl_LAST_VERTEX_CONVENTION 50 LastVertex -> GL_LAST_VERTEX_CONVENTION
51 51
52 setPointSize :: PointSize -> IO () 52 setPointSize :: PointSize -> IO ()
53 setPointSize ps = case ps of 53 setPointSize ps = case ps of
54 ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE 54 ProgramPointSize -> glEnable GL_PROGRAM_POINT_SIZE
55 PointSize s -> do 55 PointSize s -> do
56 glDisable gl_PROGRAM_POINT_SIZE 56 glDisable GL_PROGRAM_POINT_SIZE
57 glPointSize $ realToFrac s 57 glPointSize $ realToFrac s
58 58
59 cvt :: RasterContext -> IO () 59 cvt :: RasterContext -> IO ()
60 cvt (PointCtx ps fts sc) = do 60 cvt (PointCtx ps fts sc) = do
61 setPointSize ps 61 setPointSize ps
62 glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts) 62 glPointParameterf GL_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
63 glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of 63 glPointParameterf GL_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
64 LowerLeft -> gl_LOWER_LEFT 64 LowerLeft -> GL_LOWER_LEFT
65 UpperLeft -> gl_UPPER_LEFT 65 UpperLeft -> GL_UPPER_LEFT
66 66
67 cvt (LineCtx lw pv) = do 67 cvt (LineCtx lw pv) = do
68 glLineWidth (realToFrac lw) 68 glLineWidth (realToFrac lw)
@@ -71,38 +71,38 @@ setupRasterContext = cvt
71 cvt (TriangleCtx cm pm po pv) = do 71 cvt (TriangleCtx cm pm po pv) = do
72 -- cull mode 72 -- cull mode
73 case cm of 73 case cm of
74 CullNone -> glDisable gl_CULL_FACE 74 CullNone -> glDisable GL_CULL_FACE
75 CullFront f -> do 75 CullFront f -> do
76 glEnable gl_CULL_FACE 76 glEnable GL_CULL_FACE
77 glCullFace gl_FRONT 77 glCullFace GL_FRONT
78 glFrontFace $ cff f 78 glFrontFace $ cff f
79 CullBack f -> do 79 CullBack f -> do
80 glEnable gl_CULL_FACE 80 glEnable GL_CULL_FACE
81 glCullFace gl_BACK 81 glCullFace GL_BACK
82 glFrontFace $ cff f 82 glFrontFace $ cff f
83 83
84 -- polygon mode 84 -- polygon mode
85 case pm of 85 case pm of
86 PolygonPoint ps -> do 86 PolygonPoint ps -> do
87 setPointSize ps 87 setPointSize ps
88 glPolygonMode gl_FRONT_AND_BACK gl_POINT 88 glPolygonMode GL_FRONT_AND_BACK GL_POINT
89 PolygonLine lw -> do 89 PolygonLine lw -> do
90 glLineWidth (realToFrac lw) 90 glLineWidth (realToFrac lw)
91 glPolygonMode gl_FRONT_AND_BACK gl_LINE 91 glPolygonMode GL_FRONT_AND_BACK GL_LINE
92 PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL 92 PolygonFill -> glPolygonMode GL_FRONT_AND_BACK GL_FILL
93 93
94 -- polygon offset 94 -- polygon offset
95 glDisable gl_POLYGON_OFFSET_POINT 95 glDisable GL_POLYGON_OFFSET_POINT
96 glDisable gl_POLYGON_OFFSET_LINE 96 glDisable GL_POLYGON_OFFSET_LINE
97 glDisable gl_POLYGON_OFFSET_FILL 97 glDisable GL_POLYGON_OFFSET_FILL
98 case po of 98 case po of
99 NoOffset -> return () 99 NoOffset -> return ()
100 Offset f u -> do 100 Offset f u -> do
101 glPolygonOffset (realToFrac f) (realToFrac u) 101 glPolygonOffset (realToFrac f) (realToFrac u)
102 glEnable $ case pm of 102 glEnable $ case pm of
103 PolygonPoint _ -> gl_POLYGON_OFFSET_POINT 103 PolygonPoint _ -> GL_POLYGON_OFFSET_POINT
104 PolygonLine _ -> gl_POLYGON_OFFSET_LINE 104 PolygonLine _ -> GL_POLYGON_OFFSET_LINE
105 PolygonFill -> gl_POLYGON_OFFSET_FILL 105 PolygonFill -> GL_POLYGON_OFFSET_FILL
106 106
107 -- provoking vertex 107 -- provoking vertex
108 setProvokingVertex pv 108 setProvokingVertex pv
@@ -119,17 +119,17 @@ setupAccumulationContext (AccumulationContext n ops) = cvt ops
119 cvtC 0 xs 119 cvtC 0 xs
120 cvt (DepthOp df dm : xs) = do 120 cvt (DepthOp df dm : xs) = do
121 -- TODO 121 -- TODO
122 glDisable gl_STENCIL_TEST 122 glDisable GL_STENCIL_TEST
123 case df == Always && dm == False of 123 case df == Always && dm == False of
124 True -> glDisable gl_DEPTH_TEST 124 True -> glDisable GL_DEPTH_TEST
125 False -> do 125 False -> do
126 glEnable gl_DEPTH_TEST 126 glEnable GL_DEPTH_TEST
127 glDepthFunc $! comparisonFunctionToGLType df 127 glDepthFunc $! comparisonFunctionToGLType df
128 glDepthMask (cvtBool dm) 128 glDepthMask (cvtBool dm)
129 cvtC 0 xs 129 cvtC 0 xs
130 cvt xs = do 130 cvt xs = do
131 glDisable gl_DEPTH_TEST 131 glDisable GL_DEPTH_TEST
132 glDisable gl_STENCIL_TEST 132 glDisable GL_STENCIL_TEST
133 cvtC 0 xs 133 cvtC 0 xs
134 134
135 cvtC :: Int -> [FragmentOperation] -> IO () 135 cvtC :: Int -> [FragmentOperation] -> IO ()
@@ -138,18 +138,18 @@ setupAccumulationContext (AccumulationContext n ops) = cvt ops
138 case b of 138 case b of
139 NoBlending -> do 139 NoBlending -> do
140 -- FIXME: requires GL 3.1 140 -- FIXME: requires GL 3.1
141 --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i 141 --glDisablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i
142 glDisable gl_BLEND -- workaround 142 glDisable GL_BLEND -- workaround
143 glDisable gl_COLOR_LOGIC_OP 143 glDisable GL_COLOR_LOGIC_OP
144 BlendLogicOp op -> do 144 BlendLogicOp op -> do
145 glDisable gl_BLEND 145 glDisable GL_BLEND
146 glEnable gl_COLOR_LOGIC_OP 146 glEnable GL_COLOR_LOGIC_OP
147 glLogicOp $ logicOperationToGLType op 147 glLogicOp $ logicOperationToGLType op
148 Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do 148 Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do
149 glDisable gl_COLOR_LOGIC_OP 149 glDisable GL_COLOR_LOGIC_OP
150 -- FIXME: requires GL 3.1 150 -- FIXME: requires GL 3.1
151 --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i 151 --glEnablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i
152 glEnable gl_BLEND -- workaround 152 glEnable GL_BLEND -- workaround
153 glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq) 153 glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)
154 glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF) 154 glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)
155 (blendingFactorToGLType saF) (blendingFactorToGLType daF) 155 (blendingFactorToGLType saF) (blendingFactorToGLType daF)
@@ -176,10 +176,10 @@ clearRenderTarget values = do
176 ClearImage Depth (VFloat v) -> do 176 ClearImage Depth (VFloat v) -> do
177 glDepthMask 1 177 glDepthMask 1
178 glClearDepth $ realToFrac v 178 glClearDepth $ realToFrac v
179 return (m .|. gl_DEPTH_BUFFER_BIT, i) 179 return (m .|. GL_DEPTH_BUFFER_BIT, i)
180 ClearImage Stencil (VWord v) -> do 180 ClearImage Stencil (VWord v) -> do
181 glClearStencil $ fromIntegral v 181 glClearStencil $ fromIntegral v
182 return (m .|. gl_STENCIL_BUFFER_BIT, i) 182 return (m .|. GL_STENCIL_BUFFER_BIT, i)
183 ClearImage Color c -> do 183 ClearImage Color c -> do
184 let (r,g,b,a) = case c of 184 let (r,g,b,a) = case c of
185 VFloat r -> (realToFrac r, 0, 0, 1) 185 VFloat r -> (realToFrac r, 0, 0, 1)
@@ -189,7 +189,7 @@ clearRenderTarget values = do
189 _ -> (0,0,0,1) 189 _ -> (0,0,0,1)
190 glColorMask 1 1 1 1 190 glColorMask 1 1 1 1
191 glClearColor r g b a 191 glClearColor r g b a
192 return (m .|. gl_COLOR_BUFFER_BIT, i+1) 192 return (m .|. GL_COLOR_BUFFER_BIT, i+1)
193 _ -> error "internal error (clearRenderTarget)" 193 _ -> error "internal error (clearRenderTarget)"
194 (mask,_) <- foldM setClearValue (0,0) values 194 (mask,_) <- foldM setClearValue (0,0) values
195 glClear $ fromIntegral mask 195 glClear $ fromIntegral mask
@@ -209,9 +209,9 @@ compileProgram uniTrie p = do
209 putStr " + compile shader source: " >> printGLStatus 209 putStr " + compile shader source: " >> printGLStatus
210 return o 210 return o
211 211
212 objs <- sequence $ createAndAttach (vertexShader p) gl_VERTEX_SHADER : createAndAttach (fragmentShader p) gl_FRAGMENT_SHADER : case geometryShader p of 212 objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of
213 Nothing -> [] 213 Nothing -> []
214 Just s -> [createAndAttach s gl_GEOMETRY_SHADER] 214 Just s -> [createAndAttach s GL_GEOMETRY_SHADER]
215 215
216 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do 216 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do
217 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i) 217 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
@@ -222,8 +222,8 @@ compileProgram uniTrie p = do
222 printProgramLog po 222 printProgramLog po
223 223
224 -- check link status 224 -- check link status
225 status <- glGetProgramiv1 gl_LINK_STATUS po 225 status <- glGetProgramiv1 GL_LINK_STATUS po
226 when (status /= fromIntegral gl_TRUE) $ fail "link program failed!" 226 when (status /= fromIntegral GL_TRUE) $ fail "link program failed!"
227 227
228 -- check program input 228 -- check program input
229 (uniforms,uniformsType) <- queryUniforms po 229 (uniforms,uniformsType) <- queryUniforms po
@@ -269,32 +269,8 @@ compileProgram uniTrie p = do
269 } 269 }
270 270
271compileSampler :: SamplerDescriptor -> IO GLSampler 271compileSampler :: SamplerDescriptor -> IO GLSampler
272compileSampler s = return $ GLSampler {} 272compileSampler s = return $ GLSampler {} -- TODO
273 273
274{-
275data ImageIndex
276 = TextureImage TextureName Int (Maybe Int) -- Texture name, mip index, array index
277 | Framebuffer ImageSemantic
278
279data ImageSemantic
280 = Depth
281 | Stencil
282 | Color
283-}
284{-
285 = RenderTarget
286 { renderTargets :: [(ImageSemantic,Maybe ImageIndex)] -- render texture or default framebuffer (semantic, render texture for the program output)
287 }
288-}
289{-
290 glDrawBuffers
291 GL_NONE
292 --GL_FRONT_LEFT
293 --GL_FRONT_RIGHT
294 GL_BACK_LEFT
295 --GL_BACK_RIGHT
296 GL_COLOR_ATTACHMENTn
297-}
298compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget 274compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
299compileRenderTarget texs glTexs (RenderTarget targets) = do 275compileRenderTarget texs glTexs (RenderTarget targets) = do
300 let isFB (Framebuffer _) = True 276 let isFB (Framebuffer _) = True
@@ -304,8 +280,8 @@ compileRenderTarget texs glTexs (RenderTarget targets) = do
304 True -> do 280 True -> do
305 let bufs = [cvt img | TargetItem Color img <- V.toList targets] 281 let bufs = [cvt img | TargetItem Color img <- V.toList targets]
306 cvt a = case a of 282 cvt a = case a of
307 Nothing -> gl_NONE 283 Nothing -> GL_NONE
308 Just (Framebuffer Color) -> gl_BACK_LEFT 284 Just (Framebuffer Color) -> GL_BACK_LEFT
309 _ -> error "internal error (compileRenderTarget)!" 285 _ -> error "internal error (compileRenderTarget)!"
310 return $ GLRenderTarget 286 return $ GLRenderTarget
311 { framebufferObject = 0 287 { framebufferObject = 0
@@ -314,7 +290,7 @@ compileRenderTarget texs glTexs (RenderTarget targets) = do
314 False -> do 290 False -> do
315 when (any isFB images) $ fail "internal error (compileRenderTarget)!" 291 when (any isFB images) $ fail "internal error (compileRenderTarget)!"
316 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo 292 fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
317 glBindFramebuffer gl_DRAW_FRAMEBUFFER fbo 293 glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo
318 {- 294 {-
319 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level); 295 void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);
320 GL_TEXTURE_1D 296 GL_TEXTURE_1D
@@ -333,19 +309,19 @@ compileRenderTarget texs glTexs (RenderTarget targets) = do
333 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level); 309 void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);
334 -} 310 -}
335 let attach attachment (TextureImage texIdx level (Just layer)) = 311 let attach attachment (TextureImage texIdx level (Just layer)) =
336 glFramebufferTextureLayer gl_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer) 312 glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
337 attach attachment (TextureImage texIdx level Nothing) = do 313 attach attachment (TextureImage texIdx level Nothing) = do
338 let glTex = glTexs ! texIdx 314 let glTex = glTexs ! texIdx
339 tex = texs ! texIdx 315 tex = texs ! texIdx
340 txLevel = fromIntegral level 316 txLevel = fromIntegral level
341 txTarget = glTextureTarget glTex 317 txTarget = glTextureTarget glTex
342 txObj = glTextureObject glTex 318 txObj = glTextureObject glTex
343 attachArray = glFramebufferTexture gl_DRAW_FRAMEBUFFER attachment txObj txLevel 319 attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel
344 attach2D = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel 320 attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
345 case textureType tex of 321 case textureType tex of
346 Texture1D _ n 322 Texture1D _ n
347 | n > 1 -> attachArray 323 | n > 1 -> attachArray
348 | otherwise -> glFramebufferTexture1D gl_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel 324 | otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
349 Texture2D _ n 325 Texture2D _ n
350 | n > 1 -> attachArray 326 | n > 1 -> attachArray
351 | otherwise -> attach2D 327 | otherwise -> attach2D
@@ -361,13 +337,13 @@ compileRenderTarget texs glTexs (RenderTarget targets) = do
361 fail "Stencil support is not implemented yet!" 337 fail "Stencil support is not implemented yet!"
362 return a 338 return a
363 go a (TargetItem Depth (Just img)) = do 339 go a (TargetItem Depth (Just img)) = do
364 attach gl_DEPTH_ATTACHMENT img 340 attach GL_DEPTH_ATTACHMENT img
365 return a 341 return a
366 go (bufs,colorIdx) (TargetItem Color (Just img)) = do 342 go (bufs,colorIdx) (TargetItem Color (Just img)) = do
367 let attachment = gl_COLOR_ATTACHMENT0 + fromIntegral colorIdx 343 let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx
368 attach attachment img 344 attach attachment img
369 return (attachment : bufs, colorIdx + 1) 345 return (attachment : bufs, colorIdx + 1)
370 go (bufs,colorIdx) (TargetItem Color Nothing) = return (gl_NONE : bufs, colorIdx + 1) 346 go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1)
371 go a _ = return a 347 go a _ = return a
372 (bufs,_) <- foldM go ([],0) targets 348 (bufs,_) <- foldM go ([],0) targets
373 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs) 349 withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
@@ -469,27 +445,27 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
469 attrMap = inputStreams prg 445 attrMap = inputStreams prg
470 attrCmd i s = case s of 446 attrCmd i s = case s of
471 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of 447 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
472 TWord -> setIntAttrib 1 448 Attribute_Word -> setIntAttrib 1
473 TV2U -> setIntAttrib 2 449 Attribute_V2U -> setIntAttrib 2
474 TV3U -> setIntAttrib 3 450 Attribute_V3U -> setIntAttrib 3
475 TV4U -> setIntAttrib 4 451 Attribute_V4U -> setIntAttrib 4
476 TInt -> setIntAttrib 1 452 Attribute_Int -> setIntAttrib 1
477 TV2I -> setIntAttrib 2 453 Attribute_V2I -> setIntAttrib 2
478 TV3I -> setIntAttrib 3 454 Attribute_V3I -> setIntAttrib 3
479 TV4I -> setIntAttrib 4 455 Attribute_V4I -> setIntAttrib 4
480 TFloat -> setFloatAttrib 1 456 Attribute_Float -> setFloatAttrib 1
481 TV2F -> setFloatAttrib 2 457 Attribute_V2F -> setFloatAttrib 2
482 TV3F -> setFloatAttrib 3 458 Attribute_V3F -> setFloatAttrib 3
483 TV4F -> setFloatAttrib 4 459 Attribute_V4F -> setFloatAttrib 4
484 TM22F -> setFloatAttrib 4 460 Attribute_M22F -> setFloatAttrib 4
485 TM23F -> setFloatAttrib 6 461 Attribute_M23F -> setFloatAttrib 6
486 TM24F -> setFloatAttrib 8 462 Attribute_M24F -> setFloatAttrib 8
487 TM32F -> setFloatAttrib 6 463 Attribute_M32F -> setFloatAttrib 6
488 TM33F -> setFloatAttrib 9 464 Attribute_M33F -> setFloatAttrib 9
489 TM34F -> setFloatAttrib 12 465 Attribute_M34F -> setFloatAttrib 12
490 TM42F -> setFloatAttrib 8 466 Attribute_M42F -> setFloatAttrib 8
491 TM43F -> setFloatAttrib 12 467 Attribute_M43F -> setFloatAttrib 12
492 TM44F -> setFloatAttrib 16 468 Attribute_M44F -> setFloatAttrib 16
493 where 469 where
494 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n) 470 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
495 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n) 471 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
@@ -500,8 +476,8 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
500 -- constant generic attribute 476 -- constant generic attribute
501 constAttr -> GLSetVertexAttrib i constAttr 477 constAttr -> GLSetVertexAttrib i constAttr
502 478
503allocPipeline :: Pipeline -> IO GLPipeline 479allocRenderer :: Pipeline -> IO GLRenderer
504allocPipeline p = do 480allocRenderer p = do
505 let uniTrie = uniforms $ schemaFromPipeline p 481 let uniTrie = uniforms $ schemaFromPipeline p
506 smps <- V.mapM compileSampler $ samplers p 482 smps <- V.mapM compileSampler $ samplers p
507 texs <- V.mapM compileTexture $ textures p 483 texs <- V.mapM compileTexture $ textures p
@@ -515,7 +491,7 @@ allocPipeline p = do
515 -- default Vertex Array Object 491 -- default Vertex Array Object
516 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao 492 vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
517 strs <- V.mapM compileStreamData $ streams p 493 strs <- V.mapM compileStreamData $ streams p
518 return $ GLPipeline 494 return $ GLRenderer
519 { glPrograms = prgs 495 { glPrograms = prgs
520 , glTextures = texs 496 , glTextures = texs
521 , glSamplers = smps 497 , glSamplers = smps
@@ -529,9 +505,9 @@ allocPipeline p = do
529 , glStreams = strs 505 , glStreams = strs
530 } 506 }
531 507
532disposePipeline :: GLPipeline -> IO () 508disposeRenderer :: GLRenderer -> IO ()
533disposePipeline p = do 509disposeRenderer p = do
534 setPipelineInput p Nothing 510 setStorage' p Nothing
535 V.forM_ (glPrograms p) $ \prg -> do 511 V.forM_ (glPrograms p) $ \prg -> do
536 glDeleteProgram $ programObject prg 512 glDeleteProgram $ programObject prg
537 mapM_ glDeleteShader $ shaderObjects prg 513 mapM_ glDeleteShader $ shaderObjects prg
@@ -581,8 +557,12 @@ isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a)
581 , show sType 557 , show sType
582 ] 558 ]
583-} 559-}
584setPipelineInput :: GLPipeline -> Maybe GLPipelineInput -> IO () 560
585setPipelineInput p input' = do 561setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)
562setStorage p input' = setStorage' p (Just input')
563
564setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)
565setStorage' p input' = do
586 -- TODO: check matching input schema 566 -- TODO: check matching input schema
587 {- 567 {-
588 case input' of 568 case input' of
@@ -615,7 +595,7 @@ setPipelineInput p input' = do
615 - update used slots, and generate object commands for objects in the related slots 595 - update used slots, and generate object commands for objects in the related slots
616 -} 596 -}
617 case input' of 597 case input' of
618 Nothing -> writeIORef (glInput p) Nothing 598 Nothing -> writeIORef (glInput p) Nothing >> return Nothing
619 Just input -> do 599 Just input -> do
620 let pipelinesRef = pipelines input 600 let pipelinesRef = pipelines input
621 oldPipelineV <- readIORef pipelinesRef 601 oldPipelineV <- readIORef pipelinesRef
@@ -658,6 +638,7 @@ setPipelineInput p input' = do
658 -- generate stream commands 638 -- generate stream commands
659 V.forM_ (glStreams p) $ \s -> do 639 V.forM_ (glStreams p) $ \s -> do
660 writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s) 640 writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
641 return Nothing
661{- 642{-
662 track state: 643 track state:
663 - render target 644 - render target
@@ -691,23 +672,23 @@ setPipelineInput p input' = do
691-} 672-}
692{- 673{-
693 track: 674 track:
694 buffer binding on various targets: gl_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER 675 buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER
695 glEnable/DisableVertexAttribArray 676 glEnable/DisableVertexAttribArray
696-} 677-}
697renderSlot :: [GLObjectCommand] -> IO () 678renderSlot :: [GLObjectCommand] -> IO ()
698renderSlot cmds = forM_ cmds $ \cmd -> do 679renderSlot cmds = forM_ cmds $ \cmd -> do
699 case cmd of 680 case cmd of
700 GLSetVertexAttribArray idx buf size typ ptr -> do 681 GLSetVertexAttribArray idx buf size typ ptr -> do
701 glBindBuffer gl_ARRAY_BUFFER buf 682 glBindBuffer GL_ARRAY_BUFFER buf
702 glEnableVertexAttribArray idx 683 glEnableVertexAttribArray idx
703 glVertexAttribPointer idx size typ (fromIntegral gl_FALSE) 0 ptr 684 glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr
704 GLSetVertexAttribIArray idx buf size typ ptr -> do 685 GLSetVertexAttribIArray idx buf size typ ptr -> do
705 glBindBuffer gl_ARRAY_BUFFER buf 686 glBindBuffer GL_ARRAY_BUFFER buf
706 glEnableVertexAttribArray idx 687 glEnableVertexAttribArray idx
707 glVertexAttribIPointer idx size typ 0 ptr 688 glVertexAttribIPointer idx size typ 0 ptr
708 GLDrawArrays mode first count -> glDrawArrays mode first count 689 GLDrawArrays mode first count -> glDrawArrays mode first count
709 GLDrawElements mode count typ buf indicesPtr -> do 690 GLDrawElements mode count typ buf indicesPtr -> do
710 glBindBuffer gl_ELEMENT_ARRAY_BUFFER buf 691 glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf
711 glDrawElements mode count typ indicesPtr 692 glDrawElements mode count typ indicesPtr
712 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref 693 GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
713 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do 694 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
@@ -716,7 +697,7 @@ renderSlot cmds = forM_ cmds $ \cmd -> do
716 with txObjVal $ \txObjPtr -> do 697 with txObjVal $ \txObjPtr -> do
717 txObj <- peek $ castPtr txObjPtr :: IO GLuint 698 txObj <- peek $ castPtr txObjPtr :: IO GLuint
718 texUnit <- readIORef tuRef 699 texUnit <- readIORef tuRef
719 glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit 700 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
720 glBindTexture txTarget txObj 701 glBindTexture txTarget txObj
721 putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj 702 putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
722 GLSetVertexAttrib idx val -> do 703 GLSetVertexAttrib idx val -> do
@@ -725,8 +706,8 @@ renderSlot cmds = forM_ cmds $ \cmd -> do
725 isOk <- checkGL 706 isOk <- checkGL
726 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd 707 putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
727 708
728renderPipeline :: GLPipeline -> IO () 709renderFrame :: GLRenderer -> IO ()
729renderPipeline glp = do 710renderFrame glp = do
730 glBindVertexArray (glVAO glp) 711 glBindVertexArray (glVAO glp)
731 forM_ (glCommands glp) $ \cmd -> do 712 forM_ (glCommands glp) $ \cmd -> do
732 case cmd of 713 case cmd of
@@ -743,7 +724,7 @@ renderPipeline glp = do
743 (w,h) <- readIORef $ screenSize input 724 (w,h) <- readIORef $ screenSize input
744 glViewport 0 0 (fromIntegral w) (fromIntegral h) 725 glViewport 0 0 (fromIntegral w) (fromIntegral h)
745 -- TODO: set FBO target viewport 726 -- TODO: set FBO target viewport
746 glBindFramebuffer gl_DRAW_FRAMEBUFFER rt 727 glBindFramebuffer GL_DRAW_FRAMEBUFFER rt
747 case bufs of 728 case bufs of
748 Nothing -> return () 729 Nothing -> return ()
749 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl) 730 Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
@@ -809,7 +790,7 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
809 SetTexture tu t -> do 790 SetTexture tu t -> do
810 let tex = textures ! t 791 let tex = textures ! t
811 modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s}) 792 modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
812 return $ GLSetTexture (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex) 793 return $ GLSetTexture (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
813{- 794{-
814 SetSampler tu s -> liftIO $ do 795 SetSampler tu s -> liftIO $ do
815 glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s) 796 glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
@@ -826,7 +807,7 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
826 tb <- textureBinding <$> get 807 tb <- textureBinding <$> get
827 case IM.lookup tu tb of 808 case IM.lookup tu tb of
828 Nothing -> fail "internal error (GenerateMipMap)!" 809 Nothing -> fail "internal error (GenerateMipMap)!"
829 Just tex -> return $ GLGenerateMipMap (gl_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) 810 Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
830{- 811{-
831 SaveImage _ _ -> undefined 812 SaveImage _ _ -> undefined
832 LoadImage _ _ -> undefined 813 LoadImage _ _ -> undefined
diff --git a/Backend/GL/Data.hs b/src/LambdaCube/GL/Data.hs
index 2c6e596..231da8b 100644
--- a/Backend/GL/Data.hs
+++ b/src/LambdaCube/GL/Data.hs
@@ -1,4 +1,4 @@
1module Backend.GL.Data where 1module LambdaCube.GL.Data where
2 2
3import Control.Applicative 3import Control.Applicative
4import Control.Monad 4import Control.Monad
@@ -16,13 +16,13 @@ import qualified Data.Vector.Storable as SV
16 16
17--import Control.DeepSeq 17--import Control.DeepSeq
18 18
19import Graphics.Rendering.OpenGL.Raw.Core33 19import Graphics.GL.Core33
20import Data.Word 20import Data.Word
21import Codec.Picture 21import Codec.Picture
22import Codec.Picture.Types 22import Codec.Picture.Types
23 23
24import Backend.GL.Type 24import LambdaCube.GL.Type
25import Backend.GL.Util 25import LambdaCube.GL.Util
26 26
27-- Buffer 27-- Buffer
28compileBuffer :: [Array] -> IO Buffer 28compileBuffer :: [Array] -> IO Buffer
@@ -32,20 +32,20 @@ compileBuffer arrs = do
32 in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs) 32 in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)
33 (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs 33 (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs
34 bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo 34 bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
35 glBindBuffer gl_ARRAY_BUFFER bo 35 glBindBuffer GL_ARRAY_BUFFER bo
36 glBufferData gl_ARRAY_BUFFER (fromIntegral bufSize) nullPtr gl_STATIC_DRAW 36 glBufferData GL_ARRAY_BUFFER (fromIntegral bufSize) nullPtr GL_STATIC_DRAW
37 forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) 37 forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
38 glBindBuffer gl_ARRAY_BUFFER 0 38 glBindBuffer GL_ARRAY_BUFFER 0
39 return $! Buffer (V.fromList $! reverse arrDescs) bo 39 return $! Buffer (V.fromList $! reverse arrDescs) bo
40 40
41updateBuffer :: Buffer -> [(Int,Array)] -> IO () 41updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
42updateBuffer (Buffer arrDescs bo) arrs = do 42updateBuffer (Buffer arrDescs bo) arrs = do
43 glBindBuffer gl_ARRAY_BUFFER bo 43 glBindBuffer GL_ARRAY_BUFFER bo
44 forM arrs $ \(i,Array arrType cnt setter) -> do 44 forM arrs $ \(i,Array arrType cnt setter) -> do
45 let ArrayDesc ty len offset size = arrDescs V.! i 45 let ArrayDesc ty len offset size = arrDescs V.! i
46 when (ty == arrType && cnt == len) $ 46 when (ty == arrType && cnt == len) $
47 setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) 47 setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
48 glBindBuffer gl_ARRAY_BUFFER 0 48 glBindBuffer GL_ARRAY_BUFFER 0
49 49
50bufferSize :: Buffer -> Int 50bufferSize :: Buffer -> Int
51bufferSize = V.length . bufArrays 51bufferSize = V.length . bufArrays
@@ -59,30 +59,30 @@ arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
59-- Texture 59-- Texture
60 60
61-- FIXME: Temporary implemenation 61-- FIXME: Temporary implemenation
62compileTexture2DRGBAF :: Bool -> Bool -> DynamicImage -> IO TextureData 62uploadTexture2DToGPU :: DynamicImage -> IO TextureData
63compileTexture2DRGBAF = compileTexture2DRGBAF' False 63uploadTexture2DToGPU = uploadTexture2DToGPU' False True False
64 64
65compileTexture2DRGBAF' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData 65uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData
66compileTexture2DRGBAF' isSRGB isMip isClamped bitmap' = do 66uploadTexture2DToGPU' isSRGB isMip isClamped bitmap' = do
67 let bitmap = case bitmap' of 67 let bitmap = case bitmap' of
68 ImageRGB8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGB8 r g b) -> [PixelRGBA8 r g b maxBound]) i 68 ImageRGB8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGB8 r g b) -> [PixelRGBA8 r g b maxBound]) i
69 ImageRGBA8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGBA8 r g b a) -> [PixelRGBA8 r g b a]) i 69 ImageRGBA8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGBA8 r g b a) -> [PixelRGBA8 r g b a]) i
70 ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i -- $ Image w h $ SV.fromList $ pixelFoldMap (\p -> let PixelRGB8 r g b = convertPixel p in [PixelRGBA8 r g b maxBound]) i 70 ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i -- $ Image w h $ SV.fromList $ pixelFoldMap (\p -> let PixelRGB8 r g b = convertPixel p in [PixelRGBA8 r g b maxBound]) i
71 ImageCMYK16 _ -> error "compileTexture2DRGBAF: ImageCMYK16" 71 ImageCMYK16 _ -> error "uploadTexture2DToGPU: ImageCMYK16"
72 ImageCMYK8 _ -> error "compileTexture2DRGBAF: ImageCMYK8" 72 ImageCMYK8 _ -> error "uploadTexture2DToGPU: ImageCMYK8"
73 ImageRGBA16 _ -> error "compileTexture2DRGBAF: ImageRGBA16" 73 ImageRGBA16 _ -> error "uploadTexture2DToGPU: ImageRGBA16"
74 ImageRGBF _ -> error "compileTexture2DRGBAF: ImageRGBF" 74 ImageRGBF _ -> error "uploadTexture2DToGPU: ImageRGBF"
75 ImageRGB16 _ -> error "compileTexture2DRGBAF: ImageRGB16" 75 ImageRGB16 _ -> error "uploadTexture2DToGPU: ImageRGB16"
76 ImageYA16 _ -> error "compileTexture2DRGBAF: ImageYA16" 76 ImageYA16 _ -> error "uploadTexture2DToGPU: ImageYA16"
77 ImageYA8 _ -> error "compileTexture2DRGBAF: ImageYA8" 77 ImageYA8 _ -> error "uploadTexture2DToGPU: ImageYA8"
78 ImageYF _ -> error "compileTexture2DRGBAF: ImageYF" 78 ImageYF _ -> error "uploadTexture2DToGPU: ImageYF"
79 ImageY16 _ -> error "compileTexture2DRGBAF: ImageY16" 79 ImageY16 _ -> error "uploadTexture2DToGPU: ImageY16"
80 ImageY8 _ -> error "compileTexture2DRGBAF: ImageY8" 80 ImageY8 _ -> error "uploadTexture2DToGPU: ImageY8"
81 _ -> error "compileTexture2DRGBAF: unknown image" 81 _ -> error "uploadTexture2DToGPU: unknown image"
82 82
83 glPixelStorei gl_UNPACK_ALIGNMENT 1 83 glPixelStorei GL_UNPACK_ALIGNMENT 1
84 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto 84 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
85 glBindTexture gl_TEXTURE_2D to 85 glBindTexture GL_TEXTURE_2D to
86 let (width,height) = bitmapSize bitmap 86 let (width,height) = bitmapSize bitmap
87 bitmapSize (ImageRGB8 (Image w h _)) = (w,h) 87 bitmapSize (ImageRGB8 (Image w h _)) = (w,h)
88 bitmapSize (ImageRGBA8 (Image w h _)) = (w,h) 88 bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)
@@ -91,23 +91,23 @@ compileTexture2DRGBAF' isSRGB isMip isClamped bitmap' = do
91 withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0 91 withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0
92 withBitmap _ _ = error "unsupported image type :(" 92 withBitmap _ _ = error "unsupported image type :("
93 wrapMode = case isClamped of 93 wrapMode = case isClamped of
94 True -> gl_CLAMP_TO_EDGE 94 True -> GL_CLAMP_TO_EDGE
95 False -> gl_REPEAT 95 False -> GL_REPEAT
96 (minFilter,maxLevel) = case isMip of 96 (minFilter,maxLevel) = case isMip of
97 False -> (gl_LINEAR,0) 97 False -> (GL_LINEAR,0)
98 True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2) 98 True -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
99 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode 99 glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral wrapMode
100 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode 100 glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral wrapMode
101 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter 101 glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter
102 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR 102 glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $ fromIntegral GL_LINEAR
103 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0 103 glTexParameteri GL_TEXTURE_2D GL_TEXTURE_BASE_LEVEL 0
104 glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel 104 glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
105 withBitmap bitmap $ \(w,h) nchn 0 ptr -> do 105 withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
106 let internalFormat = fromIntegral $ if isSRGB then (if nchn == 3 then gl_SRGB8 else gl_SRGB8_ALPHA8) else (if nchn == 3 then gl_RGB8 else gl_RGBA8) 106 let internalFormat = fromIntegral $ if isSRGB then (if nchn == 3 then GL_SRGB8 else GL_SRGB8_ALPHA8) else (if nchn == 3 then GL_RGB8 else GL_RGBA8)
107 dataFormat = fromIntegral $ case nchn of 107 dataFormat = fromIntegral $ case nchn of
108 3 -> gl_RGB 108 3 -> GL_RGB
109 4 -> gl_RGBA 109 4 -> GL_RGBA
110 _ -> error "unsupported texture format!" 110 _ -> error "unsupported texture format!"
111 glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr 111 glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
112 when isMip $ glGenerateMipmap gl_TEXTURE_2D 112 when isMip $ glGenerateMipmap GL_TEXTURE_2D
113 return $ TextureData to 113 return $ TextureData to
diff --git a/Backend/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index f92a9c9..aabf0e6 100644
--- a/Backend/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -1,4 +1,4 @@
1module Backend.GL.Input where 1module LambdaCube.GL.Input where
2 2
3import Control.Applicative 3import Control.Applicative
4import Control.Exception 4import Control.Exception
@@ -19,12 +19,12 @@ import qualified Data.Trie as T
19import qualified Data.Vector as V 19import qualified Data.Vector as V
20import qualified Data.Vector.Algorithms.Intro as I 20import qualified Data.Vector.Algorithms.Intro as I
21 21
22import Graphics.Rendering.OpenGL.Raw.Core33 22import Graphics.GL.Core33
23 23
24import IR as IR 24import IR as IR
25import Linear as IR 25import Linear as IR
26import Backend.GL.Type as T 26import LambdaCube.GL.Type as T
27import Backend.GL.Util 27import LambdaCube.GL.Util
28 28
29import qualified IR as IR 29import qualified IR as IR
30 30
@@ -48,8 +48,8 @@ mkUniform l = do
48 let (unis,setters) = unzip unisAndSetters 48 let (unis,setters) = unzip unisAndSetters
49 return (T.fromList setters, T.fromList unis) 49 return (T.fromList setters, T.fromList unis)
50 50
51mkGLPipelineInput :: PipelineSchema -> IO GLPipelineInput 51allocStorage :: PipelineSchema -> IO GLStorage
52mkGLPipelineInput sch = do 52allocStorage sch = do
53 let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..] 53 let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..]
54 len = T.size sm 54 len = T.size sm
55 (setters,unis) <- mkUniform $ T.toList $ uniforms sch 55 (setters,unis) <- mkUniform $ T.toList $ uniforms sch
@@ -57,7 +57,7 @@ mkGLPipelineInput sch = do
57 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered) 57 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered)
58 size <- newIORef (0,0) 58 size <- newIORef (0,0)
59 ppls <- newIORef $ V.singleton Nothing 59 ppls <- newIORef $ V.singleton Nothing
60 return $ GLPipelineInput 60 return $ GLStorage
61 { schema = sch 61 { schema = sch
62 , slotMap = sm 62 , slotMap = sm
63 , slotVector = slotV 63 , slotVector = slotV
@@ -68,8 +68,11 @@ mkGLPipelineInput sch = do
68 , pipelines = ppls 68 , pipelines = ppls
69 } 69 }
70 70
71disposeStorage :: GLStorage -> IO ()
72disposeStorage = error "not implemented: disposeStorage"
73
71-- object 74-- object
72addObject :: GLPipelineInput -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object 75addObject :: GLStorage -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
73addObject input slotName prim indices attribs uniformNames = do 76addObject input slotName prim indices attribs uniformNames = do
74 let sch = schema input 77 let sch = schema input
75 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of 78 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
@@ -137,13 +140,13 @@ addObject input slotName prim indices attribs uniformNames = do
137 writeIORef cmdsRef cmds 140 writeIORef cmdsRef cmds
138 return obj 141 return obj
139 142
140removeObject :: GLPipelineInput -> Object -> IO () 143removeObject :: GLStorage -> Object -> IO ()
141removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate 144removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate
142 145
143enableObject :: Object -> Bool -> IO () 146enableObject :: Object -> Bool -> IO ()
144enableObject obj b = writeIORef (objEnabled obj) b 147enableObject obj b = writeIORef (objEnabled obj) b
145 148
146setObjectOrder :: GLPipelineInput -> Object -> Int -> IO () 149setObjectOrder :: GLStorage -> Object -> Int -> IO ()
147setObjectOrder p obj i = do 150setObjectOrder p obj i = do
148 writeIORef (objOrder obj) i 151 writeIORef (objOrder obj) i
149 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder 152 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
@@ -151,10 +154,10 @@ setObjectOrder p obj i = do
151objectUniformSetter :: Object -> Trie InputSetter 154objectUniformSetter :: Object -> Trie InputSetter
152objectUniformSetter = objUniSetter 155objectUniformSetter = objUniSetter
153 156
154setScreenSize :: GLPipelineInput -> Word -> Word -> IO () 157setScreenSize :: GLStorage -> Word -> Word -> IO ()
155setScreenSize p w h = writeIORef (screenSize p) (w,h) 158setScreenSize p w h = writeIORef (screenSize p) (w,h)
156 159
157sortSlotObjects :: GLPipelineInput -> IO () 160sortSlotObjects :: GLStorage -> IO ()
158sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do 161sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do
159 GLSlot objMap sortedV ord <- readIORef slotRef 162 GLSlot objMap sortedV ord <- readIORef slotRef
160 let cmpFun (a,_) (b,_) = a `compare` b 163 let cmpFun (a,_) (b,_) = a `compare` b
@@ -215,27 +218,27 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
215 objAttrs = objAttributes obj 218 objAttrs = objAttributes obj
216 attrCmd i s = case s of 219 attrCmd i s = case s of
217 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of 220 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
218 TWord -> setIntAttrib 1 221 Attribute_Word -> setIntAttrib 1
219 TV2U -> setIntAttrib 2 222 Attribute_V2U -> setIntAttrib 2
220 TV3U -> setIntAttrib 3 223 Attribute_V3U -> setIntAttrib 3
221 TV4U -> setIntAttrib 4 224 Attribute_V4U -> setIntAttrib 4
222 TInt -> setIntAttrib 1 225 Attribute_Int -> setIntAttrib 1
223 TV2I -> setIntAttrib 2 226 Attribute_V2I -> setIntAttrib 2
224 TV3I -> setIntAttrib 3 227 Attribute_V3I -> setIntAttrib 3
225 TV4I -> setIntAttrib 4 228 Attribute_V4I -> setIntAttrib 4
226 TFloat -> setFloatAttrib 1 229 Attribute_Float -> setFloatAttrib 1
227 TV2F -> setFloatAttrib 2 230 Attribute_V2F -> setFloatAttrib 2
228 TV3F -> setFloatAttrib 3 231 Attribute_V3F -> setFloatAttrib 3
229 TV4F -> setFloatAttrib 4 232 Attribute_V4F -> setFloatAttrib 4
230 TM22F -> setFloatAttrib 4 233 Attribute_M22F -> setFloatAttrib 4
231 TM23F -> setFloatAttrib 6 234 Attribute_M23F -> setFloatAttrib 6
232 TM24F -> setFloatAttrib 8 235 Attribute_M24F -> setFloatAttrib 8
233 TM32F -> setFloatAttrib 6 236 Attribute_M32F -> setFloatAttrib 6
234 TM33F -> setFloatAttrib 9 237 Attribute_M33F -> setFloatAttrib 9
235 TM34F -> setFloatAttrib 12 238 Attribute_M34F -> setFloatAttrib 12
236 TM42F -> setFloatAttrib 8 239 Attribute_M42F -> setFloatAttrib 8
237 TM43F -> setFloatAttrib 12 240 Attribute_M43F -> setFloatAttrib 12
238 TM44F -> setFloatAttrib 16 241 Attribute_M44F -> setFloatAttrib 16
239 where 242 where
240 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n) 243 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
241 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n) 244 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
diff --git a/Backend/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs
index 4539622..f8a0bb9 100644
--- a/Backend/GL/Mesh.hs
+++ b/src/LambdaCube/GL/Mesh.hs
@@ -1,10 +1,10 @@
1{-# LANGUAGE TupleSections #-} 1{-# LANGUAGE TupleSections #-}
2module Backend.GL.Mesh ( 2module LambdaCube.GL.Mesh (
3 loadMesh', 3 loadMesh',
4 loadMesh, 4 loadMesh,
5 saveMesh, 5 saveMesh,
6 addMesh, 6 addMeshToObjectArray,
7 compileMesh, 7 uploadMeshToGPU,
8 updateMesh, 8 updateMesh,
9 Mesh(..), 9 Mesh(..),
10 MeshPrimitive(..), 10 MeshPrimitive(..),
@@ -27,8 +27,8 @@ import qualified Data.Trie as T
27import qualified Data.Vector.Storable as V 27import qualified Data.Vector.Storable as V
28import qualified Data.Vector.Storable.Mutable as MV 28import qualified Data.Vector.Storable.Mutable as MV
29 29
30import Backend.GL 30import LambdaCube.GL
31import Backend.GL.Type as T 31import LambdaCube.GL.Type as T
32import IR as IR 32import IR as IR
33import Linear as IR 33import Linear as IR
34 34
@@ -71,20 +71,20 @@ loadMesh' :: String -> IO Mesh
71loadMesh' n = decode <$> LB.readFile n 71loadMesh' n = decode <$> LB.readFile n
72 72
73loadMesh :: String -> IO Mesh 73loadMesh :: String -> IO Mesh
74loadMesh n = compileMesh =<< loadMesh' n 74loadMesh n = uploadMeshToGPU =<< loadMesh' n
75 75
76saveMesh :: String -> Mesh -> IO () 76saveMesh :: String -> Mesh -> IO ()
77saveMesh n m = LB.writeFile n (encode m) 77saveMesh n m = LB.writeFile n (encode m)
78 78
79addMesh :: GLPipelineInput -> ByteString -> Mesh -> [ByteString] -> IO Object 79addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object
80addMesh input slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = do 80addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do
81 -- select proper attributes 81 -- select proper attributes
82 let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input 82 let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input
83 filterStream n s 83 filterStream n s
84 | T.member n slotStreams = Just s 84 | T.member n slotStreams = Just s
85 | otherwise = Nothing 85 | otherwise = Nothing
86 addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames 86 addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames
87addMesh _ _ _ _ = fail "addMesh: only compiled mesh with GPUData is supported" 87addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported"
88 88
89withV w a f = w a (\p -> f $ castPtr p) 89withV w a f = w a (\p -> f $ castPtr p)
90 90
@@ -100,36 +100,16 @@ meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafe
100meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v 100meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v
101 101
102meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer 102meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
103meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v) 103meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v)
104meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v) 104meshAttrToStream b i (A_V2F v) = Stream Attribute_V2F b i 0 (V.length v)
105meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v) 105meshAttrToStream b i (A_V3F v) = Stream Attribute_V3F b i 0 (V.length v)
106meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v) 106meshAttrToStream b i (A_V4F v) = Stream Attribute_V4F b i 0 (V.length v)
107meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v) 107meshAttrToStream b i (A_M22F v) = Stream Attribute_M22F b i 0 (V.length v)
108meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v) 108meshAttrToStream b i (A_M33F v) = Stream Attribute_M33F b i 0 (V.length v)
109meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v) 109meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v)
110meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v) 110meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v)
111meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v) 111meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v)
112 112
113{-
114updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
115
116 | Stream
117 { streamType :: StreamType
118 , streamBuffer :: b
119 , streamArrIdx :: Int
120 , streamStart :: Int
121 , streamLength :: Int
122 }
123
124-- stream of index values (for index buffer)
125data IndexStream b
126 = IndexStream
127 { indexBuffer :: b
128 , indexArrIdx :: Int
129 , indexStart :: Int
130 , indexLength :: Int
131 }
132-}
133updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO () 113updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()
134updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do 114updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
135 -- check type match 115 -- check type match
@@ -151,8 +131,8 @@ updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
151 (a,b) -> a == b 131 (a,b) -> a == b
152-} 132-}
153 133
154compileMesh :: Mesh -> IO Mesh 134uploadMeshToGPU :: Mesh -> IO Mesh
155compileMesh (Mesh attrs mPrim Nothing) = do 135uploadMeshToGPU (Mesh attrs mPrim Nothing) = do
156 let mkIndexBuf v = do 136 let mkIndexBuf v = do
157 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] 137 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]
158 return $! Just $! IndexStream iBuf 0 0 (V.length v) 138 return $! Just $! IndexStream iBuf 0 0 (V.length v)
@@ -167,7 +147,7 @@ compileMesh (Mesh attrs mPrim Nothing) = do
167 gpuData = GPUData prim streams indices 147 gpuData = GPUData prim streams indices
168 return $! Mesh attrs mPrim (Just gpuData) 148 return $! Mesh attrs mPrim (Just gpuData)
169 149
170compileMesh mesh = return mesh 150uploadMeshToGPU mesh = return mesh
171 151
172sblToV :: Storable a => [SB.ByteString] -> V.Vector a 152sblToV :: Storable a => [SB.ByteString] -> V.Vector a
173sblToV ls = v 153sblToV ls = v
diff --git a/Backend/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index f420e74..c82a8f0 100644
--- a/Backend/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -1,5 +1,5 @@
1{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 1{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2module Backend.GL.Type where 2module LambdaCube.GL.Type where
3 3
4import Data.ByteString.Char8 (ByteString) 4import Data.ByteString.Char8 (ByteString)
5import Data.IORef 5import Data.IORef
@@ -12,7 +12,7 @@ import Data.Word
12import Foreign.Ptr 12import Foreign.Ptr
13import Foreign.Storable 13import Foreign.Storable
14 14
15import Graphics.Rendering.OpenGL.Raw.Core33 15import Graphics.GL.Core33
16 16
17import Linear 17import Linear
18import IR 18import IR
@@ -56,7 +56,7 @@ data ArrayDesc
56 buffers 56 buffers
57 objects 57 objects
58 58
59 GLPipelineInput can be attached to GLPipeline 59 GLStorage can be attached to GLRenderer
60-} 60-}
61 61
62{- 62{-
@@ -96,8 +96,8 @@ data GLSlot
96 , orderJob :: OrderJob 96 , orderJob :: OrderJob
97 } 97 }
98 98
99data GLPipelineInput 99data GLStorage
100 = GLPipelineInput 100 = GLStorage
101 { schema :: PipelineSchema 101 { schema :: PipelineSchema
102 , slotMap :: Trie SlotName 102 , slotMap :: Trie SlotName
103 , slotVector :: Vector (IORef GLSlot) 103 , slotVector :: Vector (IORef GLSlot)
@@ -105,7 +105,7 @@ data GLPipelineInput
105 , uniformSetter :: Trie InputSetter 105 , uniformSetter :: Trie InputSetter
106 , uniformSetup :: Trie GLUniform 106 , uniformSetup :: Trie GLUniform
107 , screenSize :: IORef (Word,Word) 107 , screenSize :: IORef (Word,Word)
108 , pipelines :: IORef (Vector (Maybe GLPipeline)) -- attached pipelines 108 , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines
109 } 109 }
110 110
111data Object -- internal type 111data Object -- internal type
@@ -145,9 +145,9 @@ data GLTexture
145data InputConnection 145data InputConnection
146 = InputConnection 146 = InputConnection
147 { icId :: Int -- identifier (vector index) for attached pipeline 147 { icId :: Int -- identifier (vector index) for attached pipeline
148 , icInput :: GLPipelineInput 148 , icInput :: GLStorage
149 , icSlotMapPipelineToInput :: Vector SlotName -- GLPipeline to GLPipelineInput slot name mapping 149 , icSlotMapPipelineToInput :: Vector SlotName -- GLRenderer to GLStorage slot name mapping
150 , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLPipelineInput to GLPipeline slot name mapping 150 , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLStorage to GLRenderer slot name mapping
151 } 151 }
152 152
153data GLStream 153data GLStream
@@ -158,8 +158,8 @@ data GLStream
158 , glStreamProgram :: ProgramName 158 , glStreamProgram :: ProgramName
159 } 159 }
160 160
161data GLPipeline 161data GLRenderer
162 = GLPipeline 162 = GLRenderer
163 { glPrograms :: Vector GLProgram 163 { glPrograms :: Vector GLProgram
164 , glTextures :: Vector GLTexture 164 , glTextures :: Vector GLTexture
165 , glSamplers :: Vector GLSampler 165 , glSamplers :: Vector GLSampler
@@ -324,75 +324,75 @@ data Array -- array type, element count (NOT byte size!), setter
324-- we restrict StreamType using type class 324-- we restrict StreamType using type class
325-- subset of InputType, describes a stream type (in GPU side) 325-- subset of InputType, describes a stream type (in GPU side)
326data StreamType 326data StreamType
327 = TWord 327 = Attribute_Word
328 | TV2U 328 | Attribute_V2U
329 | TV3U 329 | Attribute_V3U
330 | TV4U 330 | Attribute_V4U
331 | TInt 331 | Attribute_Int
332 | TV2I 332 | Attribute_V2I
333 | TV3I 333 | Attribute_V3I
334 | TV4I 334 | Attribute_V4I
335 | TFloat 335 | Attribute_Float
336 | TV2F 336 | Attribute_V2F
337 | TV3F 337 | Attribute_V3F
338 | TV4F 338 | Attribute_V4F
339 | TM22F 339 | Attribute_M22F
340 | TM23F 340 | Attribute_M23F
341 | TM24F 341 | Attribute_M24F
342 | TM32F 342 | Attribute_M32F
343 | TM33F 343 | Attribute_M33F
344 | TM34F 344 | Attribute_M34F
345 | TM42F 345 | Attribute_M42F
346 | TM43F 346 | Attribute_M43F
347 | TM44F 347 | Attribute_M44F
348 deriving (Show,Eq,Ord) 348 deriving (Show,Eq,Ord)
349 349
350toStreamType :: InputType -> Maybe StreamType 350toStreamType :: InputType -> Maybe StreamType
351toStreamType Word = Just TWord 351toStreamType Word = Just Attribute_Word
352toStreamType V2U = Just TV2U 352toStreamType V2U = Just Attribute_V2U
353toStreamType V3U = Just TV3U 353toStreamType V3U = Just Attribute_V3U
354toStreamType V4U = Just TV4U 354toStreamType V4U = Just Attribute_V4U
355toStreamType Int = Just TInt 355toStreamType Int = Just Attribute_Int
356toStreamType V2I = Just TV2I 356toStreamType V2I = Just Attribute_V2I
357toStreamType V3I = Just TV3I 357toStreamType V3I = Just Attribute_V3I
358toStreamType V4I = Just TV4I 358toStreamType V4I = Just Attribute_V4I
359toStreamType Float = Just TFloat 359toStreamType Float = Just Attribute_Float
360toStreamType V2F = Just TV2F 360toStreamType V2F = Just Attribute_V2F
361toStreamType V3F = Just TV3F 361toStreamType V3F = Just Attribute_V3F
362toStreamType V4F = Just TV4F 362toStreamType V4F = Just Attribute_V4F
363toStreamType M22F = Just TM22F 363toStreamType M22F = Just Attribute_M22F
364toStreamType M23F = Just TM23F 364toStreamType M23F = Just Attribute_M23F
365toStreamType M24F = Just TM24F 365toStreamType M24F = Just Attribute_M24F
366toStreamType M32F = Just TM32F 366toStreamType M32F = Just Attribute_M32F
367toStreamType M33F = Just TM33F 367toStreamType M33F = Just Attribute_M33F
368toStreamType M34F = Just TM34F 368toStreamType M34F = Just Attribute_M34F
369toStreamType M42F = Just TM42F 369toStreamType M42F = Just Attribute_M42F
370toStreamType M43F = Just TM43F 370toStreamType M43F = Just Attribute_M43F
371toStreamType M44F = Just TM44F 371toStreamType M44F = Just Attribute_M44F
372toStreamType _ = Nothing 372toStreamType _ = Nothing
373 373
374fromStreamType :: StreamType -> InputType 374fromStreamType :: StreamType -> InputType
375fromStreamType TWord = Word 375fromStreamType Attribute_Word = Word
376fromStreamType TV2U = V2U 376fromStreamType Attribute_V2U = V2U
377fromStreamType TV3U = V3U 377fromStreamType Attribute_V3U = V3U
378fromStreamType TV4U = V4U 378fromStreamType Attribute_V4U = V4U
379fromStreamType TInt = Int 379fromStreamType Attribute_Int = Int
380fromStreamType TV2I = V2I 380fromStreamType Attribute_V2I = V2I
381fromStreamType TV3I = V3I 381fromStreamType Attribute_V3I = V3I
382fromStreamType TV4I = V4I 382fromStreamType Attribute_V4I = V4I
383fromStreamType TFloat = Float 383fromStreamType Attribute_Float = Float
384fromStreamType TV2F = V2F 384fromStreamType Attribute_V2F = V2F
385fromStreamType TV3F = V3F 385fromStreamType Attribute_V3F = V3F
386fromStreamType TV4F = V4F 386fromStreamType Attribute_V4F = V4F
387fromStreamType TM22F = M22F 387fromStreamType Attribute_M22F = M22F
388fromStreamType TM23F = M23F 388fromStreamType Attribute_M23F = M23F
389fromStreamType TM24F = M24F 389fromStreamType Attribute_M24F = M24F
390fromStreamType TM32F = M32F 390fromStreamType Attribute_M32F = M32F
391fromStreamType TM33F = M33F 391fromStreamType Attribute_M33F = M33F
392fromStreamType TM34F = M34F 392fromStreamType Attribute_M34F = M34F
393fromStreamType TM42F = M42F 393fromStreamType Attribute_M42F = M42F
394fromStreamType TM43F = M43F 394fromStreamType Attribute_M43F = M43F
395fromStreamType TM44F = M44F 395fromStreamType Attribute_M44F = M44F
396 396
397-- user can specify streams using Stream type 397-- user can specify streams using Stream type
398-- a stream can be constant (ConstXXX) or can came from a buffer 398-- a stream can be constant (ConstXXX) or can came from a buffer
@@ -429,27 +429,27 @@ data Stream b
429 429
430streamToStreamType :: Stream a -> StreamType 430streamToStreamType :: Stream a -> StreamType
431streamToStreamType s = case s of 431streamToStreamType s = case s of
432 ConstWord _ -> TWord 432 ConstWord _ -> Attribute_Word
433 ConstV2U _ -> TV2U 433 ConstV2U _ -> Attribute_V2U
434 ConstV3U _ -> TV3U 434 ConstV3U _ -> Attribute_V3U
435 ConstV4U _ -> TV4U 435 ConstV4U _ -> Attribute_V4U
436 ConstInt _ -> TInt 436 ConstInt _ -> Attribute_Int
437 ConstV2I _ -> TV2I 437 ConstV2I _ -> Attribute_V2I
438 ConstV3I _ -> TV3I 438 ConstV3I _ -> Attribute_V3I
439 ConstV4I _ -> TV4I 439 ConstV4I _ -> Attribute_V4I
440 ConstFloat _ -> TFloat 440 ConstFloat _ -> Attribute_Float
441 ConstV2F _ -> TV2F 441 ConstV2F _ -> Attribute_V2F
442 ConstV3F _ -> TV3F 442 ConstV3F _ -> Attribute_V3F
443 ConstV4F _ -> TV4F 443 ConstV4F _ -> Attribute_V4F
444 ConstM22F _ -> TM22F 444 ConstM22F _ -> Attribute_M22F
445 ConstM23F _ -> TM23F 445 ConstM23F _ -> Attribute_M23F
446 ConstM24F _ -> TM24F 446 ConstM24F _ -> Attribute_M24F
447 ConstM32F _ -> TM32F 447 ConstM32F _ -> Attribute_M32F
448 ConstM33F _ -> TM33F 448 ConstM33F _ -> Attribute_M33F
449 ConstM34F _ -> TM34F 449 ConstM34F _ -> Attribute_M34F
450 ConstM42F _ -> TM42F 450 ConstM42F _ -> Attribute_M42F
451 ConstM43F _ -> TM43F 451 ConstM43F _ -> Attribute_M43F
452 ConstM44F _ -> TM44F 452 ConstM44F _ -> Attribute_M44F
453 Stream t _ _ _ _ -> t 453 Stream t _ _ _ _ -> t
454 454
455-- stream of index values (for index buffer) 455-- stream of index values (for index buffer)
diff --git a/Backend/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index 75c2e3a..2059415 100644
--- a/Backend/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -1,5 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings #-}
2module Backend.GL.Util ( 2module LambdaCube.GL.Util (
3 queryUniforms, 3 queryUniforms,
4 queryStreams, 4 queryStreams,
5 mkUniformSetter, 5 mkUniformSetter,
@@ -46,10 +46,10 @@ import qualified Data.Vector.Unboxed.Mutable as MV
46import Data.Map (Map) 46import Data.Map (Map)
47import qualified Data.Map as Map 47import qualified Data.Map as Map
48 48
49import Graphics.Rendering.OpenGL.Raw.Core33 49import Graphics.GL.Core33
50import Linear 50import Linear
51import IR 51import IR
52import Backend.GL.Type 52import LambdaCube.GL.Type
53 53
54toTrie :: Map String a -> Trie a 54toTrie :: Map String a -> Trie a
55toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m] 55toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m]
@@ -64,7 +64,7 @@ z4 = V4 0 0 0 0 :: V4F
64-- uniform functions 64-- uniform functions
65queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType) 65queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)
66queryUniforms po = do 66queryUniforms po = do
67 ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation gl_ACTIVE_UNIFORMS gl_ACTIVE_UNIFORM_MAX_LENGTH 67 ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH
68 let uNames = [n | (n,_,_,_) <- ul] 68 let uNames = [n | (n,_,_,_) <- ul]
69 uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul] 69 uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]
70 uLocation = [i | (_,i,_,_) <- ul] 70 uLocation = [i | (_,i,_,_) <- ul]
@@ -106,7 +106,7 @@ mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return
106setUniform :: Storable a => GLint -> InputType -> IORef a -> IO () 106setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()
107setUniform i ty ref = do 107setUniform i ty ref = do
108 v <- readIORef ref 108 v <- readIORef ref
109 let false = fromIntegral gl_FALSE 109 let false = fromIntegral GL_FALSE
110 with v $ \p -> case ty of 110 with v $ \p -> case ty of
111 Bool -> glUniform1uiv i 1 (castPtr p) 111 Bool -> glUniform1uiv i 1 (castPtr p)
112 V2B -> glUniform2uiv i 1 (castPtr p) 112 V2B -> glUniform2uiv i 1 (castPtr p)
@@ -139,7 +139,7 @@ setUniform i ty ref = do
139-- attribute functions 139-- attribute functions
140queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType) 140queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)
141queryStreams po = do 141queryStreams po = do
142 al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation gl_ACTIVE_ATTRIBUTES gl_ACTIVE_ATTRIBUTE_MAX_LENGTH 142 al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH
143 let aNames = [n | (n,_,_,_) <- al] 143 let aNames = [n | (n,_,_,_) <- al]
144 aTypes = [fromGLType (e,s) | (_,_,e,s) <- al] 144 aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]
145 aLocation = [fromIntegral i | (_,i,_,_) <- al] 145 aLocation = [fromIntegral i | (_,i,_,_) <- al]
@@ -147,14 +147,14 @@ queryStreams po = do
147 147
148arrayTypeToGLType :: ArrayType -> GLenum 148arrayTypeToGLType :: ArrayType -> GLenum
149arrayTypeToGLType a = case a of 149arrayTypeToGLType a = case a of
150 ArrWord8 -> gl_UNSIGNED_BYTE 150 ArrWord8 -> GL_UNSIGNED_BYTE
151 ArrWord16 -> gl_UNSIGNED_SHORT 151 ArrWord16 -> GL_UNSIGNED_SHORT
152 ArrWord32 -> gl_UNSIGNED_INT 152 ArrWord32 -> GL_UNSIGNED_INT
153 ArrInt8 -> gl_BYTE 153 ArrInt8 -> GL_BYTE
154 ArrInt16 -> gl_SHORT 154 ArrInt16 -> GL_SHORT
155 ArrInt32 -> gl_INT 155 ArrInt32 -> GL_INT
156 ArrFloat -> gl_FLOAT 156 ArrFloat -> GL_FLOAT
157 ArrHalf -> gl_HALF_FLOAT 157 ArrHalf -> GL_HALF_FLOAT
158 158
159setVertexAttrib :: GLuint -> Stream Buffer -> IO () 159setVertexAttrib :: GLuint -> Stream Buffer -> IO ()
160setVertexAttrib i val = case val of 160setVertexAttrib i val = case val of
@@ -202,73 +202,73 @@ getNameTypeSize o f g enum enumLen = do
202 202
203fromGLType :: (GLenum,GLint) -> InputType 203fromGLType :: (GLenum,GLint) -> InputType
204fromGLType (t,1) 204fromGLType (t,1)
205 | t == gl_BOOL = Bool 205 | t == GL_BOOL = Bool
206 | t == gl_BOOL_VEC2 = V2B 206 | t == GL_BOOL_VEC2 = V2B
207 | t == gl_BOOL_VEC3 = V3B 207 | t == GL_BOOL_VEC3 = V3B
208 | t == gl_BOOL_VEC4 = V4B 208 | t == GL_BOOL_VEC4 = V4B
209 | t == gl_UNSIGNED_INT = Word 209 | t == GL_UNSIGNED_INT = Word
210 | t == gl_UNSIGNED_INT_VEC2 = V2U 210 | t == GL_UNSIGNED_INT_VEC2 = V2U
211 | t == gl_UNSIGNED_INT_VEC3 = V3U 211 | t == GL_UNSIGNED_INT_VEC3 = V3U
212 | t == gl_UNSIGNED_INT_VEC4 = V4U 212 | t == GL_UNSIGNED_INT_VEC4 = V4U
213 | t == gl_INT = Int 213 | t == GL_INT = Int
214 | t == gl_INT_VEC2 = V2I 214 | t == GL_INT_VEC2 = V2I
215 | t == gl_INT_VEC3 = V3I 215 | t == GL_INT_VEC3 = V3I
216 | t == gl_INT_VEC4 = V4I 216 | t == GL_INT_VEC4 = V4I
217 | t == gl_FLOAT = Float 217 | t == GL_FLOAT = Float
218 | t == gl_FLOAT_VEC2 = V2F 218 | t == GL_FLOAT_VEC2 = V2F
219 | t == gl_FLOAT_VEC3 = V3F 219 | t == GL_FLOAT_VEC3 = V3F
220 | t == gl_FLOAT_VEC4 = V4F 220 | t == GL_FLOAT_VEC4 = V4F
221 | t == gl_FLOAT_MAT2 = M22F 221 | t == GL_FLOAT_MAT2 = M22F
222 | t == gl_FLOAT_MAT2x3 = M23F 222 | t == GL_FLOAT_MAT2x3 = M23F
223 | t == gl_FLOAT_MAT2x4 = M24F 223 | t == GL_FLOAT_MAT2x4 = M24F
224 | t == gl_FLOAT_MAT3x2 = M32F 224 | t == GL_FLOAT_MAT3x2 = M32F
225 | t == gl_FLOAT_MAT3 = M33F 225 | t == GL_FLOAT_MAT3 = M33F
226 | t == gl_FLOAT_MAT3x4 = M34F 226 | t == GL_FLOAT_MAT3x4 = M34F
227 | t == gl_FLOAT_MAT4x2 = M42F 227 | t == GL_FLOAT_MAT4x2 = M42F
228 | t == gl_FLOAT_MAT4x3 = M43F 228 | t == GL_FLOAT_MAT4x3 = M43F
229 | t == gl_FLOAT_MAT4 = M44F 229 | t == GL_FLOAT_MAT4 = M44F
230 | t == gl_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray 230 | t == GL_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray
231 | t == gl_SAMPLER_1D_SHADOW = STexture1D 231 | t == GL_SAMPLER_1D_SHADOW = STexture1D
232 | t == gl_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray 232 | t == GL_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray
233 | t == gl_SAMPLER_2D_RECT_SHADOW = STexture2DRect 233 | t == GL_SAMPLER_2D_RECT_SHADOW = STexture2DRect
234 | t == gl_SAMPLER_2D_SHADOW = STexture2D 234 | t == GL_SAMPLER_2D_SHADOW = STexture2D
235 | t == gl_SAMPLER_CUBE_SHADOW = STextureCube 235 | t == GL_SAMPLER_CUBE_SHADOW = STextureCube
236 | t == gl_INT_SAMPLER_1D = ITexture1D 236 | t == GL_INT_SAMPLER_1D = ITexture1D
237 | t == gl_INT_SAMPLER_1D_ARRAY = ITexture1DArray 237 | t == GL_INT_SAMPLER_1D_ARRAY = ITexture1DArray
238 | t == gl_INT_SAMPLER_2D = ITexture2D 238 | t == GL_INT_SAMPLER_2D = ITexture2D
239 | t == gl_INT_SAMPLER_2D_ARRAY = ITexture2DArray 239 | t == GL_INT_SAMPLER_2D_ARRAY = ITexture2DArray
240 | t == gl_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS 240 | t == GL_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS
241 | t == gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray 241 | t == GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray
242 | t == gl_INT_SAMPLER_2D_RECT = ITexture2DRect 242 | t == GL_INT_SAMPLER_2D_RECT = ITexture2DRect
243 | t == gl_INT_SAMPLER_3D = ITexture3D 243 | t == GL_INT_SAMPLER_3D = ITexture3D
244 | t == gl_INT_SAMPLER_BUFFER = ITextureBuffer 244 | t == GL_INT_SAMPLER_BUFFER = ITextureBuffer
245 | t == gl_INT_SAMPLER_CUBE = ITextureCube 245 | t == GL_INT_SAMPLER_CUBE = ITextureCube
246 | t == gl_SAMPLER_1D = FTexture1D 246 | t == GL_SAMPLER_1D = FTexture1D
247 | t == gl_SAMPLER_1D_ARRAY = FTexture1DArray 247 | t == GL_SAMPLER_1D_ARRAY = FTexture1DArray
248 | t == gl_SAMPLER_2D = FTexture2D 248 | t == GL_SAMPLER_2D = FTexture2D
249 | t == gl_SAMPLER_2D_ARRAY = FTexture2DArray 249 | t == GL_SAMPLER_2D_ARRAY = FTexture2DArray
250 | t == gl_SAMPLER_2D_MULTISAMPLE = FTexture2DMS 250 | t == GL_SAMPLER_2D_MULTISAMPLE = FTexture2DMS
251 | t == gl_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray 251 | t == GL_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray
252 | t == gl_SAMPLER_2D_RECT = FTexture2DRect 252 | t == GL_SAMPLER_2D_RECT = FTexture2DRect
253 | t == gl_SAMPLER_3D = FTexture3D 253 | t == GL_SAMPLER_3D = FTexture3D
254 | t == gl_SAMPLER_BUFFER = FTextureBuffer 254 | t == GL_SAMPLER_BUFFER = FTextureBuffer
255 | t == gl_SAMPLER_CUBE = FTextureCube 255 | t == GL_SAMPLER_CUBE = FTextureCube
256 | t == gl_UNSIGNED_INT_SAMPLER_1D = UTexture1D 256 | t == GL_UNSIGNED_INT_SAMPLER_1D = UTexture1D
257 | t == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray 257 | t == GL_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray
258 | t == gl_UNSIGNED_INT_SAMPLER_2D = UTexture2D 258 | t == GL_UNSIGNED_INT_SAMPLER_2D = UTexture2D
259 | t == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray 259 | t == GL_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray
260 | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS 260 | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS
261 | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray 261 | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray
262 | t == gl_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect 262 | t == GL_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect
263 | t == gl_UNSIGNED_INT_SAMPLER_3D = UTexture3D 263 | t == GL_UNSIGNED_INT_SAMPLER_3D = UTexture3D
264 | t == gl_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer 264 | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer
265 | t == gl_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube 265 | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube
266 | otherwise = error "Failed fromGLType" 266 | otherwise = error "Failed fromGLType"
267fromGLUniformType _ = error "Failed fromGLType" 267fromGLUniformType _ = error "Failed fromGLType"
268 268
269printShaderLog :: GLuint -> IO () 269printShaderLog :: GLuint -> IO ()
270printShaderLog o = do 270printShaderLog o = do
271 i <- glGetShaderiv1 gl_INFO_LOG_LENGTH o 271 i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o
272 when (i > 0) $ 272 when (i > 0) $
273 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do 273 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
274 glGetShaderInfoLog o (fromIntegral i) sizePtr ps 274 glGetShaderInfoLog o (fromIntegral i) sizePtr ps
@@ -284,7 +284,7 @@ glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi
284 284
285printProgramLog :: GLuint -> IO () 285printProgramLog :: GLuint -> IO ()
286printProgramLog o = do 286printProgramLog o = do
287 i <- glGetProgramiv1 gl_INFO_LOG_LENGTH o 287 i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o
288 when (i > 0) $ 288 when (i > 0) $
289 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do 289 alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
290 glGetProgramInfoLog o (fromIntegral i) sizePtr ps 290 glGetProgramInfoLog o (fromIntegral i) sizePtr ps
@@ -297,17 +297,17 @@ compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p
297 glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr 297 glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
298 glCompileShader o 298 glCompileShader o
299 printShaderLog o 299 printShaderLog o
300 status <- glGetShaderiv1 gl_COMPILE_STATUS o 300 status <- glGetShaderiv1 GL_COMPILE_STATUS o
301 when (status /= fromIntegral gl_TRUE) $ fail "compileShader failed!" 301 when (status /= fromIntegral GL_TRUE) $ fail "compileShader failed!"
302 302
303checkGL :: IO ByteString 303checkGL :: IO ByteString
304checkGL = do 304checkGL = do
305 let f e | e == gl_INVALID_ENUM = "INVALID_ENUM" 305 let f e | e == GL_INVALID_ENUM = "INVALID_ENUM"
306 | e == gl_INVALID_VALUE = "INVALID_VALUE" 306 | e == GL_INVALID_VALUE = "INVALID_VALUE"
307 | e == gl_INVALID_OPERATION = "INVALID_OPERATION" 307 | e == GL_INVALID_OPERATION = "INVALID_OPERATION"
308 | e == gl_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION" 308 | e == GL_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"
309 | e == gl_OUT_OF_MEMORY = "OUT_OF_MEMORY" 309 | e == GL_OUT_OF_MEMORY = "OUT_OF_MEMORY"
310 | e == gl_NO_ERROR = "OK" 310 | e == GL_NO_ERROR = "OK"
311 | otherwise = "Unknown error" 311 | otherwise = "Unknown error"
312 e <- glGetError 312 e <- glGetError
313 return $ f e 313 return $ f e
@@ -342,99 +342,99 @@ streamToInputType s = case s of
342 | otherwise -> throw $ userError "streamToInputType failed" 342 | otherwise -> throw $ userError "streamToInputType failed"
343 where 343 where
344 at = arrType $! (a V.! i) 344 at = arrType $! (a V.! i)
345 integralTypes = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I] 345 integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I]
346 integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32] 346 integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]
347 347
348comparisonFunctionToGLType :: ComparisonFunction -> GLenum 348comparisonFunctionToGLType :: ComparisonFunction -> GLenum
349comparisonFunctionToGLType a = case a of 349comparisonFunctionToGLType a = case a of
350 Always -> gl_ALWAYS 350 Always -> GL_ALWAYS
351 Equal -> gl_EQUAL 351 Equal -> GL_EQUAL
352 Gequal -> gl_GEQUAL 352 Gequal -> GL_GEQUAL
353 Greater -> gl_GREATER 353 Greater -> GL_GREATER
354 Lequal -> gl_LEQUAL 354 Lequal -> GL_LEQUAL
355 Less -> gl_LESS 355 Less -> GL_LESS
356 Never -> gl_NEVER 356 Never -> GL_NEVER
357 Notequal -> gl_NOTEQUAL 357 Notequal -> GL_NOTEQUAL
358 358
359logicOperationToGLType :: LogicOperation -> GLenum 359logicOperationToGLType :: LogicOperation -> GLenum
360logicOperationToGLType a = case a of 360logicOperationToGLType a = case a of
361 And -> gl_AND 361 And -> GL_AND
362 AndInverted -> gl_AND_INVERTED 362 AndInverted -> GL_AND_INVERTED
363 AndReverse -> gl_AND_REVERSE 363 AndReverse -> GL_AND_REVERSE
364 Clear -> gl_CLEAR 364 Clear -> GL_CLEAR
365 Copy -> gl_COPY 365 Copy -> GL_COPY
366 CopyInverted -> gl_COPY_INVERTED 366 CopyInverted -> GL_COPY_INVERTED
367 Equiv -> gl_EQUIV 367 Equiv -> GL_EQUIV
368 Invert -> gl_INVERT 368 Invert -> GL_INVERT
369 Nand -> gl_NAND 369 Nand -> GL_NAND
370 Noop -> gl_NOOP 370 Noop -> GL_NOOP
371 Nor -> gl_NOR 371 Nor -> GL_NOR
372 Or -> gl_OR 372 Or -> GL_OR
373 OrInverted -> gl_OR_INVERTED 373 OrInverted -> GL_OR_INVERTED
374 OrReverse -> gl_OR_REVERSE 374 OrReverse -> GL_OR_REVERSE
375 Set -> gl_SET 375 Set -> GL_SET
376 Xor -> gl_XOR 376 Xor -> GL_XOR
377 377
378blendEquationToGLType :: BlendEquation -> GLenum 378blendEquationToGLType :: BlendEquation -> GLenum
379blendEquationToGLType a = case a of 379blendEquationToGLType a = case a of
380 FuncAdd -> gl_FUNC_ADD 380 FuncAdd -> GL_FUNC_ADD
381 FuncReverseSubtract -> gl_FUNC_REVERSE_SUBTRACT 381 FuncReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT
382 FuncSubtract -> gl_FUNC_SUBTRACT 382 FuncSubtract -> GL_FUNC_SUBTRACT
383 Max -> gl_MAX 383 Max -> GL_MAX
384 Min -> gl_MIN 384 Min -> GL_MIN
385 385
386blendingFactorToGLType :: BlendingFactor -> GLenum 386blendingFactorToGLType :: BlendingFactor -> GLenum
387blendingFactorToGLType a = case a of 387blendingFactorToGLType a = case a of
388 ConstantAlpha -> gl_CONSTANT_ALPHA 388 ConstantAlpha -> GL_CONSTANT_ALPHA
389 ConstantColor -> gl_CONSTANT_COLOR 389 ConstantColor -> GL_CONSTANT_COLOR
390 DstAlpha -> gl_DST_ALPHA 390 DstAlpha -> GL_DST_ALPHA
391 DstColor -> gl_DST_COLOR 391 DstColor -> GL_DST_COLOR
392 One -> gl_ONE 392 One -> GL_ONE
393 OneMinusConstantAlpha -> gl_ONE_MINUS_CONSTANT_ALPHA 393 OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA
394 OneMinusConstantColor -> gl_ONE_MINUS_CONSTANT_COLOR 394 OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR
395 OneMinusDstAlpha -> gl_ONE_MINUS_DST_ALPHA 395 OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA
396 OneMinusDstColor -> gl_ONE_MINUS_DST_COLOR 396 OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR
397 OneMinusSrcAlpha -> gl_ONE_MINUS_SRC_ALPHA 397 OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA
398 OneMinusSrcColor -> gl_ONE_MINUS_SRC_COLOR 398 OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR
399 SrcAlpha -> gl_SRC_ALPHA 399 SrcAlpha -> GL_SRC_ALPHA
400 SrcAlphaSaturate -> gl_SRC_ALPHA_SATURATE 400 SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE
401 SrcColor -> gl_SRC_COLOR 401 SrcColor -> GL_SRC_COLOR
402 Zero -> gl_ZERO 402 Zero -> GL_ZERO
403 403
404textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum 404textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum
405textureDataTypeToGLType Color a = case a of 405textureDataTypeToGLType Color a = case a of
406 FloatT Red -> gl_R32F 406 FloatT Red -> GL_R32F
407 IntT Red -> gl_R32I 407 IntT Red -> GL_R32I
408 WordT Red -> gl_R32UI 408 WordT Red -> GL_R32UI
409 FloatT RG -> gl_RG32F 409 FloatT RG -> GL_RG32F
410 IntT RG -> gl_RG32I 410 IntT RG -> GL_RG32I
411 WordT RG -> gl_RG32UI 411 WordT RG -> GL_RG32UI
412 FloatT RGBA -> gl_RGBA32F 412 FloatT RGBA -> GL_RGBA32F
413 IntT RGBA -> gl_RGBA32I 413 IntT RGBA -> GL_RGBA32I
414 WordT RGBA -> gl_RGBA32UI 414 WordT RGBA -> GL_RGBA32UI
415 a -> error $ "FIXME: This texture format is not yet supported" ++ show a 415 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
416textureDataTypeToGLType Depth a = case a of 416textureDataTypeToGLType Depth a = case a of
417 FloatT Red -> gl_DEPTH_COMPONENT32F 417 FloatT Red -> GL_DEPTH_COMPONENT32F
418 WordT Red -> gl_DEPTH_COMPONENT32 418 WordT Red -> GL_DEPTH_COMPONENT32
419 a -> error $ "FIXME: This texture format is not yet supported" ++ show a 419 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
420textureDataTypeToGLType Stencil a = case a of 420textureDataTypeToGLType Stencil a = case a of
421 a -> error $ "FIXME: This texture format is not yet supported" ++ show a 421 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
422 422
423textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum 423textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum
424textureDataTypeToGLArityType Color a = case a of 424textureDataTypeToGLArityType Color a = case a of
425 FloatT Red -> gl_RED 425 FloatT Red -> GL_RED
426 IntT Red -> gl_RED 426 IntT Red -> GL_RED
427 WordT Red -> gl_RED 427 WordT Red -> GL_RED
428 FloatT RG -> gl_RG 428 FloatT RG -> GL_RG
429 IntT RG -> gl_RG 429 IntT RG -> GL_RG
430 WordT RG -> gl_RG 430 WordT RG -> GL_RG
431 FloatT RGBA -> gl_RGBA 431 FloatT RGBA -> GL_RGBA
432 IntT RGBA -> gl_RGBA 432 IntT RGBA -> GL_RGBA
433 WordT RGBA -> gl_RGBA 433 WordT RGBA -> GL_RGBA
434 a -> error $ "FIXME: This texture format is not yet supported" ++ show a 434 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
435textureDataTypeToGLArityType Depth a = case a of 435textureDataTypeToGLArityType Depth a = case a of
436 FloatT Red -> gl_DEPTH_COMPONENT 436 FloatT Red -> GL_DEPTH_COMPONENT
437 WordT Red -> gl_DEPTH_COMPONENT 437 WordT Red -> GL_DEPTH_COMPONENT
438 a -> error $ "FIXME: This texture format is not yet supported" ++ show a 438 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
439textureDataTypeToGLArityType Stencil a = case a of 439textureDataTypeToGLArityType Stencil a = case a of
440 a -> error $ "FIXME: This texture format is not yet supported" ++ show a 440 a -> error $ "FIXME: This texture format is not yet supported" ++ show a
@@ -481,49 +481,49 @@ glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi
481 481
482checkFBO :: IO ByteString 482checkFBO :: IO ByteString
483checkFBO = do 483checkFBO = do
484 let f e | e == gl_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED" 484 let f e | e == GL_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"
485 | e == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT" 485 | e == GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"
486 | e == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER" 486 | e == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"
487 | e == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER" 487 | e == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"
488 | e == gl_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED" 488 | e == GL_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"
489 | e == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE" 489 | e == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"
490 | e == gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS" 490 | e == GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"
491 | e == gl_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE" 491 | e == GL_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"
492 | otherwise = "Unknown error" 492 | otherwise = "Unknown error"
493 e <- glCheckFramebufferStatus gl_DRAW_FRAMEBUFFER 493 e <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER
494 return $ f e 494 return $ f e
495 495
496filterToGLType :: Filter -> GLenum 496filterToGLType :: Filter -> GLenum
497filterToGLType a = case a of 497filterToGLType a = case a of
498 Nearest -> gl_NEAREST 498 Nearest -> GL_NEAREST
499 Linear -> gl_LINEAR 499 Linear -> GL_LINEAR
500 NearestMipmapNearest -> gl_NEAREST_MIPMAP_NEAREST 500 NearestMipmapNearest -> GL_NEAREST_MIPMAP_NEAREST
501 NearestMipmapLinear -> gl_NEAREST_MIPMAP_LINEAR 501 NearestMipmapLinear -> GL_NEAREST_MIPMAP_LINEAR
502 LinearMipmapNearest -> gl_LINEAR_MIPMAP_NEAREST 502 LinearMipmapNearest -> GL_LINEAR_MIPMAP_NEAREST
503 LinearMipmapLinear -> gl_LINEAR_MIPMAP_LINEAR 503 LinearMipmapLinear -> GL_LINEAR_MIPMAP_LINEAR
504 504
505edgeModeToGLType :: EdgeMode -> GLenum 505edgeModeToGLType :: EdgeMode -> GLenum
506edgeModeToGLType a = case a of 506edgeModeToGLType a = case a of
507 Repeat -> gl_REPEAT 507 Repeat -> GL_REPEAT
508 MirroredRepeat -> gl_MIRRORED_REPEAT 508 MirroredRepeat -> GL_MIRRORED_REPEAT
509 ClampToEdge -> gl_CLAMP_TO_EDGE 509 ClampToEdge -> GL_CLAMP_TO_EDGE
510 ClampToBorder -> gl_CLAMP_TO_BORDER 510 ClampToBorder -> GL_CLAMP_TO_BORDER
511 511
512setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO () 512setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()
513setTextureSamplerParameters t s = do 513setTextureSamplerParameters t s = do
514 glTexParameteri t gl_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s 514 glTexParameteri t GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
515 case samplerWrapT s of 515 case samplerWrapT s of
516 Nothing -> return () 516 Nothing -> return ()
517 Just a -> glTexParameteri t gl_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a 517 Just a -> glTexParameteri t GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
518 case samplerWrapR s of 518 case samplerWrapR s of
519 Nothing -> return () 519 Nothing -> return ()
520 Just a -> glTexParameteri t gl_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a 520 Just a -> glTexParameteri t GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
521 glTexParameteri t gl_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s 521 glTexParameteri t GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
522 glTexParameteri t gl_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s 522 glTexParameteri t GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
523 523
524 let setBColorV4F a = with a $ \p -> glTexParameterfv t gl_TEXTURE_BORDER_COLOR $ castPtr p 524 let setBColorV4F a = with a $ \p -> glTexParameterfv t GL_TEXTURE_BORDER_COLOR $ castPtr p
525 setBColorV4I a = with a $ \p -> glTexParameterIiv t gl_TEXTURE_BORDER_COLOR $ castPtr p 525 setBColorV4I a = with a $ \p -> glTexParameterIiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
526 setBColorV4U a = with a $ \p -> glTexParameterIuiv t gl_TEXTURE_BORDER_COLOR $ castPtr p 526 setBColorV4U a = with a $ \p -> glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
527 case samplerBorderColor s of 527 case samplerBorderColor s of
528 -- float, word, int, red, rg, rgb, rgba 528 -- float, word, int, red, rg, rgb, rgba
529 VFloat a -> setBColorV4F $ V4 a 0 0 0 529 VFloat a -> setBColorV4F $ V4 a 0 0 0
@@ -544,16 +544,16 @@ setTextureSamplerParameters t s = do
544 544
545 case samplerMinLod s of 545 case samplerMinLod s of
546 Nothing -> return () 546 Nothing -> return ()
547 Just a -> glTexParameterf t gl_TEXTURE_MIN_LOD $ realToFrac a 547 Just a -> glTexParameterf t GL_TEXTURE_MIN_LOD $ realToFrac a
548 case samplerMaxLod s of 548 case samplerMaxLod s of
549 Nothing -> return () 549 Nothing -> return ()
550 Just a -> glTexParameterf t gl_TEXTURE_MAX_LOD $ realToFrac a 550 Just a -> glTexParameterf t GL_TEXTURE_MAX_LOD $ realToFrac a
551 glTexParameterf t gl_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s 551 glTexParameterf t GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
552 case samplerCompareFunc s of 552 case samplerCompareFunc s of
553 Nothing -> glTexParameteri t gl_TEXTURE_COMPARE_MODE $ fromIntegral gl_NONE 553 Nothing -> glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE
554 Just a -> do 554 Just a -> do
555 glTexParameteri t gl_TEXTURE_COMPARE_MODE $ fromIntegral gl_COMPARE_REF_TO_TEXTURE 555 glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE
556 glTexParameteri t gl_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a 556 glTexParameteri t GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
557 557
558compileTexture :: TextureDescriptor -> IO GLTexture 558compileTexture :: TextureDescriptor -> IO GLTexture
559compileTexture txDescriptor = do 559compileTexture txDescriptor = do
@@ -571,8 +571,8 @@ compileTexture txDescriptor = do
571 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy 571 let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy
572 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy 572 dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy
573 glBindTexture txTarget to 573 glBindTexture txTarget to
574 glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel 574 glTexParameteri txTarget GL_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel
575 glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel 575 glTexParameteri txTarget GL_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel
576 setTextureSamplerParameters txTarget txSampler 576 setTextureSamplerParameters txTarget txSampler
577 return (internalFormat,dataFormat) 577 return (internalFormat,dataFormat)
578 578
@@ -583,53 +583,53 @@ compileTexture txDescriptor = do
583 target <- case txType of 583 target <- case txType of
584 Texture1D dTy layerCnt -> do 584 Texture1D dTy layerCnt -> do
585 let VWord txW = txSize 585 let VWord txW = txSize
586 txTarget = if layerCnt > 1 then gl_TEXTURE_1D_ARRAY else gl_TEXTURE_1D 586 txTarget = if layerCnt > 1 then GL_TEXTURE_1D_ARRAY else GL_TEXTURE_1D
587 (internalFormat,dataFormat) <- txSetup txTarget dTy 587 (internalFormat,dataFormat) <- txSetup txTarget dTy
588 forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of 588 forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of
589 True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 589 True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
590 False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 590 False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
591 return txTarget 591 return txTarget
592 Texture2D dTy layerCnt -> do 592 Texture2D dTy layerCnt -> do
593 let VV2U (V2 txW txH) = txSize 593 let VV2U (V2 txW txH) = txSize
594 txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D 594 txTarget = if layerCnt > 1 then GL_TEXTURE_2D_ARRAY else GL_TEXTURE_2D
595 (internalFormat,dataFormat) <- txSetup txTarget dTy 595 (internalFormat,dataFormat) <- txSetup txTarget dTy
596 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of 596 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of
597 True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 597 True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
598 False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 598 False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
599 return txTarget 599 return txTarget
600 Texture3D dTy -> do 600 Texture3D dTy -> do
601 let VV3U (V3 txW txH txD) = txSize 601 let VV3U (V3 txW txH txD) = txSize
602 txTarget = gl_TEXTURE_3D 602 txTarget = GL_TEXTURE_3D
603 (internalFormat,dataFormat) <- txSetup txTarget dTy 603 (internalFormat,dataFormat) <- txSetup txTarget dTy
604 forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) -> 604 forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) ->
605 glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 605 glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
606 return txTarget 606 return txTarget
607 TextureCube dTy -> do 607 TextureCube dTy -> do
608 let VV2U (V2 txW txH) = txSize 608 let VV2U (V2 txW txH) = txSize
609 txTarget = gl_TEXTURE_CUBE_MAP 609 txTarget = GL_TEXTURE_CUBE_MAP
610 targets = 610 targets =
611 [ gl_TEXTURE_CUBE_MAP_POSITIVE_X 611 [ GL_TEXTURE_CUBE_MAP_POSITIVE_X
612 , gl_TEXTURE_CUBE_MAP_NEGATIVE_X 612 , GL_TEXTURE_CUBE_MAP_NEGATIVE_X
613 , gl_TEXTURE_CUBE_MAP_POSITIVE_Y 613 , GL_TEXTURE_CUBE_MAP_POSITIVE_Y
614 , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y 614 , GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
615 , gl_TEXTURE_CUBE_MAP_POSITIVE_Z 615 , GL_TEXTURE_CUBE_MAP_POSITIVE_Z
616 , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z 616 , GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
617 ] 617 ]
618 (internalFormat,dataFormat) <- txSetup txTarget dTy 618 (internalFormat,dataFormat) <- txSetup txTarget dTy
619 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> 619 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
620 forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 620 forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
621 return txTarget 621 return txTarget
622 TextureRect dTy -> do 622 TextureRect dTy -> do
623 let VV2U (V2 txW txH) = txSize 623 let VV2U (V2 txW txH) = txSize
624 txTarget = gl_TEXTURE_RECTANGLE 624 txTarget = GL_TEXTURE_RECTANGLE
625 (internalFormat,dataFormat) <- txSetup txTarget dTy 625 (internalFormat,dataFormat) <- txSetup txTarget dTy
626 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> 626 forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) ->
627 glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 627 glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
628 return txTarget 628 return txTarget
629 Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do 629 Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do
630 let VV2U (V2 w h) = txSize 630 let VV2U (V2 w h) = txSize
631 txTarget = if layerCnt > 1 then gl_TEXTURE_2D_MULTISAMPLE_ARRAY else gl_TEXTURE_2D_MULTISAMPLE 631 txTarget = if layerCnt > 1 then GL_TEXTURE_2D_MULTISAMPLE_ARRAY else GL_TEXTURE_2D_MULTISAMPLE
632 isFixed = fromIntegral $ if isFixedLocations then gl_TRUE else gl_FALSE 632 isFixed = fromIntegral $ if isFixedLocations then GL_TRUE else GL_FALSE
633 (internalFormat,dataFormat) <- txSetup txTarget dTy 633 (internalFormat,dataFormat) <- txSetup txTarget dTy
634 case layerCnt > 1 of 634 case layerCnt > 1 of
635 True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed 635 True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed
@@ -639,9 +639,9 @@ compileTexture txDescriptor = do
639 fail "internal error: buffer texture is not supported yet" 639 fail "internal error: buffer texture is not supported yet"
640 -- TODO 640 -- TODO
641 let VV2U (V2 w h) = txSize 641 let VV2U (V2 w h) = txSize
642 txTarget = gl_TEXTURE_2D 642 txTarget = GL_TEXTURE_2D
643 (internalFormat,dataFormat) <- txSetup txTarget dTy 643 (internalFormat,dataFormat) <- txSetup txTarget dTy
644 glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr 644 glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr
645 return txTarget 645 return txTarget
646 return $ GLTexture 646 return $ GLTexture
647 { glTextureObject = to 647 { glTextureObject = to
@@ -663,57 +663,57 @@ primitiveToFetchPrimitive prim = case prim of
663 663
664primitiveToGLType :: Primitive -> GLenum 664primitiveToGLType :: Primitive -> GLenum
665primitiveToGLType p = case p of 665primitiveToGLType p = case p of
666 TriangleStrip -> gl_TRIANGLE_STRIP 666 TriangleStrip -> GL_TRIANGLE_STRIP
667 TriangleList -> gl_TRIANGLES 667 TriangleList -> GL_TRIANGLES
668 TriangleFan -> gl_TRIANGLE_FAN 668 TriangleFan -> GL_TRIANGLE_FAN
669 LineStrip -> gl_LINE_STRIP 669 LineStrip -> GL_LINE_STRIP
670 LineList -> gl_LINES 670 LineList -> GL_LINES
671 PointList -> gl_POINTS 671 PointList -> GL_POINTS
672 TriangleStripAdjacency -> gl_TRIANGLE_STRIP_ADJACENCY 672 TriangleStripAdjacency -> GL_TRIANGLE_STRIP_ADJACENCY
673 TriangleListAdjacency -> gl_TRIANGLES_ADJACENCY 673 TriangleListAdjacency -> GL_TRIANGLES_ADJACENCY
674 LineStripAdjacency -> gl_LINE_STRIP_ADJACENCY 674 LineStripAdjacency -> GL_LINE_STRIP_ADJACENCY
675 LineListAdjacency -> gl_LINES_ADJACENCY 675 LineListAdjacency -> GL_LINES_ADJACENCY
676 676
677inputTypeToTextureTarget :: InputType -> GLenum 677inputTypeToTextureTarget :: InputType -> GLenum
678inputTypeToTextureTarget ty = case ty of 678inputTypeToTextureTarget ty = case ty of
679 STexture1D -> gl_TEXTURE_1D 679 STexture1D -> GL_TEXTURE_1D
680 STexture2D -> gl_TEXTURE_2D 680 STexture2D -> GL_TEXTURE_2D
681 STextureCube -> gl_TEXTURE_CUBE_MAP 681 STextureCube -> GL_TEXTURE_CUBE_MAP
682 STexture1DArray -> gl_TEXTURE_1D_ARRAY 682 STexture1DArray -> GL_TEXTURE_1D_ARRAY
683 STexture2DArray -> gl_TEXTURE_2D_ARRAY 683 STexture2DArray -> GL_TEXTURE_2D_ARRAY
684 STexture2DRect -> gl_TEXTURE_RECTANGLE 684 STexture2DRect -> GL_TEXTURE_RECTANGLE
685 685
686 FTexture1D -> gl_TEXTURE_1D 686 FTexture1D -> GL_TEXTURE_1D
687 FTexture2D -> gl_TEXTURE_2D 687 FTexture2D -> GL_TEXTURE_2D
688 FTexture3D -> gl_TEXTURE_3D 688 FTexture3D -> GL_TEXTURE_3D
689 FTextureCube -> gl_TEXTURE_CUBE_MAP 689 FTextureCube -> GL_TEXTURE_CUBE_MAP
690 FTexture1DArray -> gl_TEXTURE_1D_ARRAY 690 FTexture1DArray -> GL_TEXTURE_1D_ARRAY
691 FTexture2DArray -> gl_TEXTURE_2D_ARRAY 691 FTexture2DArray -> GL_TEXTURE_2D_ARRAY
692 FTexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE 692 FTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
693 FTexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY 693 FTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
694 FTextureBuffer -> gl_TEXTURE_BUFFER 694 FTextureBuffer -> GL_TEXTURE_BUFFER
695 FTexture2DRect -> gl_TEXTURE_RECTANGLE 695 FTexture2DRect -> GL_TEXTURE_RECTANGLE
696 696
697 ITexture1D -> gl_TEXTURE_1D 697 ITexture1D -> GL_TEXTURE_1D
698 ITexture2D -> gl_TEXTURE_2D 698 ITexture2D -> GL_TEXTURE_2D
699 ITexture3D -> gl_TEXTURE_3D 699 ITexture3D -> GL_TEXTURE_3D
700 ITextureCube -> gl_TEXTURE_CUBE_MAP 700 ITextureCube -> GL_TEXTURE_CUBE_MAP
701 ITexture1DArray -> gl_TEXTURE_1D_ARRAY 701 ITexture1DArray -> GL_TEXTURE_1D_ARRAY
702 ITexture2DArray -> gl_TEXTURE_2D_ARRAY 702 ITexture2DArray -> GL_TEXTURE_2D_ARRAY
703 ITexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE 703 ITexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
704 ITexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY 704 ITexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
705 ITextureBuffer -> gl_TEXTURE_BUFFER 705 ITextureBuffer -> GL_TEXTURE_BUFFER
706 ITexture2DRect -> gl_TEXTURE_RECTANGLE 706 ITexture2DRect -> GL_TEXTURE_RECTANGLE
707 707
708 UTexture1D -> gl_TEXTURE_1D 708 UTexture1D -> GL_TEXTURE_1D
709 UTexture2D -> gl_TEXTURE_2D 709 UTexture2D -> GL_TEXTURE_2D
710 UTexture3D -> gl_TEXTURE_3D 710 UTexture3D -> GL_TEXTURE_3D
711 UTextureCube -> gl_TEXTURE_CUBE_MAP 711 UTextureCube -> GL_TEXTURE_CUBE_MAP
712 UTexture1DArray -> gl_TEXTURE_1D_ARRAY 712 UTexture1DArray -> GL_TEXTURE_1D_ARRAY
713 UTexture2DArray -> gl_TEXTURE_2D_ARRAY 713 UTexture2DArray -> GL_TEXTURE_2D_ARRAY
714 UTexture2DMS -> gl_TEXTURE_2D_MULTISAMPLE 714 UTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE
715 UTexture2DMSArray -> gl_TEXTURE_2D_MULTISAMPLE_ARRAY 715 UTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY
716 UTextureBuffer -> gl_TEXTURE_BUFFER 716 UTextureBuffer -> GL_TEXTURE_BUFFER
717 UTexture2DRect -> gl_TEXTURE_RECTANGLE 717 UTexture2DRect -> GL_TEXTURE_RECTANGLE
718 718
719 _ -> error "internal error (inputTypeToTextureTarget)!" 719 _ -> error "internal error (inputTypeToTextureTarget)!"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 02:11:17 +0000