Workaround for using LambdaCube.GL with Gtk.

1 files changed, 35 insertions, 6 deletions

diff --git a/LambdaHello.hs b/LambdaHello.hs
index ed04598..3c15a12 100644
--- a/LambdaHello.hs
+++ b/LambdaHello.hs
@@ -4,7 +4,7 @@ module LambdaHello where
 import GI.Gtk as Gtk
 import GI.Gdk.Objects
 
--- import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.Rendering.OpenGL as GL
 import Data.Function
 import Control.Concurrent
 import LambdaCube.GL as LambdaCubeGL
@@ -17,7 +17,12 @@ import System.IO.Error
 import qualified Data.Map as Map
 import qualified Data.Vector as V
 
-import qualified Backend as RF
+-- import qualified Backend as RF
+import LambdaCube.GL as RF
+import LambdaCube.GL.Type
+
+import Control.Monad.IO.Class
+import qualified Unsafe.Coerce
 
 data State = State
     { stConfig   :: Config
@@ -34,13 +39,36 @@ initState = do
         }
 
 
+-- | LambdaCube.GL assumes we are rendering to the default framebuffer #0 but
+-- Gtk.GLArea actually uses an unpredictable framebuffer object target.  As a
+-- workaround, we read the current framebuffer target and patch up the render
+-- commands to use it instead of 0.
+fixupRenderTarget :: MonadIO m => GLRenderer -> m GLRenderer
+fixupRenderTarget r = do
+    fbo0 <- GL.get $ GL.bindFramebuffer GL.DrawFramebuffer
+    let fbo = Unsafe.Coerce.unsafeCoerce fbo0 :: GL.GLuint -- XXX: Is there a better way to get this?
+        setFBO rt | framebufferObject rt == 0  = rt { framebufferObject = fbo }
+                  | otherwise                  = rt
+        updateDC dc = dc { glRenderTarget = rt' } where rt' = setFBO (glRenderTarget dc)
+        update (GLClearRenderTarget rt imgs) = GLClearRenderTarget (setFBO rt) imgs
+        update (GLRenderSlot dc s p)         = GLRenderSlot (updateDC dc) s p
+        update (GLRenderStream dc s p)       = GLRenderStream (updateDC dc) s p
+    return r { glCommands = map update (glCommands r) }
+
 render :: State -> GLArea -> GLContext -> IO Bool
-render st w _ = do -- gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e >> return False) me $ do
+render st w gl = do
     mr <- tryTakeMVar (stRealized st)
     maybe (\_ -> putStrLn "Not realized!") (&) mr $ \r -> do
+        renderer <- fixupRenderTarget (rRenderer r)
+
         -- Load input to pipeline.
         -- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
-        return (500,500) >>= \(w,h) -> LambdaCubeGL.setScreenSize (rStorage r) (fromIntegral w) (fromIntegral h)
+        (wd,ht) <- do Just win <- getGLContextWindow gl
+                      wd <- windowGetWidth win
+                      ht <- windowGetHeight win
+                      -- print (wd,ht)
+                      return (fromIntegral wd,fromIntegral ht)
+        LambdaCubeGL.setScreenSize (rStorage r) wd ht
         LambdaCubeGL.updateUniforms (rStorage r) $ do
           "diffuseTexture" @= return (rTexture r)
           "time" @= do
@@ -48,10 +76,10 @@ render st w _ = do -- gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe i
                       let t = 1.0 :: Double
                       return (realToFrac t :: Float)
 
-        putStrLn "render!"
+        -- putStrLn "render!"
         -- GL.clearColor GL.$= GL.Color4 0 255 0 1
         -- GL.clear [GL.ColorBuffer]
-        RF.renderFrame (rRenderer r)
+        RF.renderFrame renderer
         -- GL.flush
         putMVar (stRealized st) r
     return True
@@ -86,6 +114,7 @@ realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _
     putStrLn "realize!"
     maybe id (\e _ -> putStrLn e) compat $ return ()
 
+
 unrealize :: State -> GLArea -> IO ()
 unrealize _ _ = return ()