implement sampler support

3 files changed, 57 insertions, 23 deletions

diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index a5507f3..7c2c3fb 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -267,9 +267,6 @@ compileProgram uniTrie p = do
         , inputStreams          = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let Just attrName = Map.lookup n lcStreamName]
         }
 
-compileSampler :: SamplerDescriptor -> IO GLSampler
-compileSampler s = return $ GLSampler {} -- TODO
-
 compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
 compileRenderTarget texs glTexs (RenderTarget targets) = do
     let isFB (Framebuffer _)    = True
@@ -514,6 +511,8 @@ disposeRenderer p = do
     withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
     let textures = glTextures p
     withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
+    let samplers = glSamplers p
+    withArray (map glSamplerObject $ V.toList samplers) $ (glDeleteSamplers . fromIntegral . V.length $ glSamplers p)
     with (glVAO p) $ (glDeleteVertexArrays 1)
 
 {-
@@ -730,6 +729,7 @@ renderFrame glp = do
             GLSetProgram p                  -> glUseProgram p
             GLSetSamplerUniform i tu ref    -> glUniform1i i tu >> writeIORef ref tu
             GLSetTexture tu target tx       -> glActiveTexture tu >> glBindTexture target tx
+            GLSetSampler tu s               -> glBindSampler tu s
             GLClearRenderTarget vals        -> clearRenderTarget vals
             GLGenerateMipMap tu target      -> glActiveTexture tu >> glGenerateMipmap target
             GLRenderStream streamIdx progIdx  -> do
@@ -790,10 +790,7 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
                                     let tex = textures ! t
                                     modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
                                     return $ GLSetTexture (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
-{-
-    SetSampler tu s             -> liftIO $ do
-                                        glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
--}
+    SetSampler tu s             -> return $ GLSetSampler (GL_TEXTURE0 + fromIntegral tu) (maybe 0 (glSamplerObject . (samplers !)) s)
     RenderSlot slot             -> do
                                     smpUnis <- samplerUniforms <$> get
                                     p <- currentProgram <$> get
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index 376fdf1..5a9117d 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -163,7 +163,7 @@ data GLRenderer
 
 data GLSampler
     = GLSampler
-    { samplerObject :: GLuint
+    { glSamplerObject :: GLuint
     }
 
 data GLRenderTarget
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index c5c6608..ab8350f 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 module LambdaCube.GL.Util (
     queryUniforms,
     queryStreams,
@@ -23,6 +24,7 @@ module LambdaCube.GL.Util (
     glGetIntegerv1,
     setSampler,
     checkFBO,
+    compileSampler,
     compileTexture,
     primitiveToFetchPrimitive,
     primitiveToGLType,
@@ -503,21 +505,48 @@ edgeModeToGLType a = case a of
     ClampToEdge     -> GL_CLAMP_TO_EDGE
     ClampToBorder   -> GL_CLAMP_TO_BORDER
 
+data ParameterSetup
+  = ParameterSetup
+  { setParameteri     :: GLenum -> GLint -> IO ()
+  , setParameterfv    :: GLenum -> Ptr GLfloat -> IO ()
+  , setParameterIiv   :: GLenum -> Ptr GLint -> IO ()
+  , setParameterIuiv  :: GLenum -> Ptr GLuint -> IO ()
+  , setParameterf     :: GLenum -> GLfloat -> IO ()
+  }
+
 setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()
-setTextureSamplerParameters t s = do
-    glTexParameteri t GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
+setTextureSamplerParameters target = setParameters $ ParameterSetup
+  { setParameteri     = glTexParameteri target
+  , setParameterfv    = glTexParameterfv target
+  , setParameterIiv   = glTexParameterIiv target
+  , setParameterIuiv  = glTexParameterIuiv target
+  , setParameterf     = glTexParameterf target
+  }
+
+setSamplerParameters :: GLuint -> SamplerDescriptor -> IO ()
+setSamplerParameters samplerObj = setParameters $ ParameterSetup
+  { setParameteri     = glSamplerParameteri samplerObj
+  , setParameterfv    = glSamplerParameterfv samplerObj
+  , setParameterIiv   = glSamplerParameterIiv samplerObj
+  , setParameterIuiv  = glSamplerParameterIuiv samplerObj
+  , setParameterf     = glSamplerParameterf samplerObj
+  }
+
+setParameters :: ParameterSetup -> SamplerDescriptor -> IO ()
+setParameters ParameterSetup{..} s = do
+    setParameteri GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s
     case samplerWrapT s of
         Nothing -> return ()
-        Just a  -> glTexParameteri t GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
+        Just a  -> setParameteri GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a
     case samplerWrapR s of
         Nothing -> return ()
-        Just a  -> glTexParameteri t GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
-    glTexParameteri t GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
-    glTexParameteri t GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
+        Just a  -> setParameteri GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a
+    setParameteri GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s
+    setParameteri GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s
 
-    let setBColorV4F a = with a $ \p -> glTexParameterfv t GL_TEXTURE_BORDER_COLOR $ castPtr p
-        setBColorV4I a = with a $ \p -> glTexParameterIiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
-        setBColorV4U a = with a $ \p -> glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR $ castPtr p
+    let setBColorV4F a = with a $ \p -> setParameterfv GL_TEXTURE_BORDER_COLOR $ castPtr p
+        setBColorV4I a = with a $ \p -> setParameterIiv GL_TEXTURE_BORDER_COLOR $ castPtr p
+        setBColorV4U a = with a $ \p -> setParameterIuiv GL_TEXTURE_BORDER_COLOR $ castPtr p
     case samplerBorderColor s of
         -- float, word, int, red, rg, rgb, rgba
         VFloat a        -> setBColorV4F $ V4 a 0 0 0
@@ -538,16 +567,24 @@ setTextureSamplerParameters t s = do
 
     case samplerMinLod s of
         Nothing -> return ()
-        Just a  -> glTexParameterf t GL_TEXTURE_MIN_LOD $ realToFrac a
+        Just a  -> setParameterf GL_TEXTURE_MIN_LOD $ realToFrac a
     case samplerMaxLod s of
         Nothing -> return ()
-        Just a  -> glTexParameterf t GL_TEXTURE_MAX_LOD $ realToFrac a
-    glTexParameterf t GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
+        Just a  -> setParameterf GL_TEXTURE_MAX_LOD $ realToFrac a
+    setParameterf GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s
     case samplerCompareFunc s of
-        Nothing -> glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE
+        Nothing -> setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE
         Just a  -> do
-            glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE
-            glTexParameteri t GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
+            setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE
+            setParameteri GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a
+
+compileSampler :: SamplerDescriptor -> IO GLSampler
+compileSampler s = do
+  so <- alloca $! \po -> glGenSamplers 1 po >> peek po
+  setSamplerParameters so s
+  return $ GLSampler
+    { glSamplerObject = so
+    }
 
 compileTexture :: TextureDescriptor -> IO GLTexture
 compileTexture txDescriptor = do