3 files changed, 85 insertions, 27 deletions

diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 324b3e6..0584a34 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -126,7 +126,7 @@ setupAccumulationContext (AccumulationContext n ops) = cvt ops
                 glDepthFunc $! comparisonFunctionToGLType df
                 glDepthMask (cvtBool dm)
         cvtC 0 xs
-    cvt xs = do 
+    cvt xs = do
         glDisable GL_DEPTH_TEST
         glDisable GL_STENCIL_TEST
         cvtC 0 xs
@@ -169,8 +169,8 @@ setupAccumulationContext (AccumulationContext n ops) = cvt ops
     cvtBool True  = 1
     cvtBool False = 0
 
-clearRenderTarget :: [ClearImage] -> IO ()
-clearRenderTarget values = do
+clearRenderTarget :: GLRenderTarget -> [ClearImage] -> IO ()
+clearRenderTarget GLRenderTarget{..} values = do
     let setClearValue (m,i) value = case value of
             ClearImage Depth (VFloat v) -> do
                 glDepthMask 1
@@ -180,20 +180,46 @@ clearRenderTarget values = do
                 glClearStencil $ fromIntegral v
                 return (m .|. GL_STENCIL_BUFFER_BIT, i)
             ClearImage Color c -> do
-                let (r,g,b,a) = case c of
-                        VFloat r            -> (realToFrac r, 0, 0, 1)
-                        VV2F (V2 r g)       -> (realToFrac r, realToFrac g, 0, 1)
-                        VV3F (V3 r g b)     -> (realToFrac r, realToFrac g, realToFrac b, 1)
-                        VV4F (V4 r g b a)   -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
-                        _                   -> (0,0,0,1)
                 glColorMask 1 1 1 1
-                glClearColor r g b a
-                return (m .|. GL_COLOR_BUFFER_BIT, i+1)
+                if framebufferObject == 0
+                then
+                  clearDefaultFB >>
+                  pure (m .|. GL_COLOR_BUFFER_BIT, i+1)
+                else
+                  clearFBColorAttachment >>
+                  pure (m, i+1)
+                where
+                  clearDefaultFB = do
+                    let (r,g,b,a) = case c of
+                          VFloat r            -> (realToFrac r, 0, 0, 1)
+                          VV2F (V2 r g)       -> (realToFrac r, realToFrac g, 0, 1)
+                          VV3F (V3 r g b)     -> (realToFrac r, realToFrac g, realToFrac b, 1)
+                          VV4F (V4 r g b a)   -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
+                          _                   -> (0,0,0,1)
+                    glClearColor r g b a
+                  clearFBColorAttachment = do
+                    let buf = GL_COLOR
+                    case c of -- there must be some clever way to extract the generality here, I'm sure..
+                      VFloat r            -> with (V4 r 0 0 1) $ glClearBufferfv buf i . castPtr
+                      VV2F (V2 r g)       -> with (V4 r g 0 1) $ glClearBufferfv buf i . castPtr
+                      VV3F (V3 r g b)     -> with (V4 r g b 1) $ glClearBufferfv buf i . castPtr
+                      VV4F (V4 r g b a)   -> with (V4 r g b a) $ glClearBufferfv buf i . castPtr
+                  
+                      VInt r              -> with (V4 r 0 0 1) $ glClearBufferiv buf i . castPtr
+                      VV2I (V2 r g)       -> with (V4 r g 0 1) $ glClearBufferiv buf i . castPtr
+                      VV3I (V3 r g b)     -> with (V4 r g b 1) $ glClearBufferiv buf i . castPtr
+                      VV4I (V4 r g b a)   -> with (V4 r g b a) $ glClearBufferiv buf i . castPtr
+                  
+                      VWord r             -> with (V4 r 0 0 1) $ glClearBufferiv buf i . castPtr
+                      VV2U (V2 r g)       -> with (V4 r g 0 1) $ glClearBufferiv buf i . castPtr
+                      VV3U (V3 r g b)     -> with (V4 r g b 1) $ glClearBufferiv buf i . castPtr
+                      VV4U (V4 r g b a)   -> with (V4 r g b a) $ glClearBufferiv buf i . castPtr
+                      _ -> error $ "internal error: unsupported color attachment format: " <> show c
+
             _ -> error "internal error (clearRenderTarget)"
     (mask,_) <- foldM setClearValue (0,0) values
     glClear $ fromIntegral mask
 
-
 printGLStatus = checkGL >>= print
 printFBOStatus = checkFBO >>= print
 
@@ -283,6 +309,15 @@ compileProgram p = do
         , inputStreams          = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName]
         }
 
+renderTargetOutputs :: Vector GLTexture -> RenderTarget -> GLRenderTarget -> [GLOutput]
+renderTargetOutputs glTexs (RenderTarget targetItems) (GLRenderTarget fbo bufs) =
+    let isFB (Framebuffer _)    = True
+        isFB _                  = False
+        images = [img | TargetItem _ (Just img) <- V.toList targetItems]
+    in case all isFB images of
+         True  -> fromMaybe [] $ (GLOutputDrawBuffer fbo <$>) <$> bufs
+         False -> (\(TextureImage texIdx _ _)-> GLOutputRenderTexture fbo $ glTexs ! texIdx) <$> images
+
 compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
 compileRenderTarget texs glTexs (RenderTarget targets) = do
     let isFB (Framebuffer _)    = True
@@ -344,7 +379,7 @@ compileRenderTarget texs glTexs (RenderTarget targets) = do
                             | n > 1             -> attachArray
                             | otherwise         -> attach2D
                         TextureBuffer _         -> fail "internalError (compileRenderTarget/TextureBuffer)!"
-            
+
                 go a (TargetItem Stencil (Just img)) = do
                     fail "Stencil support is not implemented yet!"
                     return a
@@ -453,7 +488,7 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
 
     -- object attribute stream commands
     streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]
-      where 
+      where
         attrMap = inputStreams prg
         attrCmd i s = case s of
             Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
@@ -488,16 +523,25 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
             -- constant generic attribute
             constAttr -> GLSetVertexAttrib i constAttr
 
+outputIsRenderTexture :: GLOutput -> Bool
+outputIsRenderTexture GLOutputRenderTexture{..} = True
+outputIsRenderTexture _                         = False
+
 allocRenderer :: Pipeline -> IO GLRenderer
 allocRenderer p = do
     smps <- V.mapM compileSampler $ samplers p
     texs <- V.mapM compileTexture $ textures p
-    trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
+    let cmds                 = V.toList $ commands p
+        finalRenderTargetIdx = head [i | SetRenderTarget i <- reverse $ cmds]
+    trgs <- traverse (compileRenderTarget (textures p) texs) $ targets p
+    let finalRenderTarget   = targets p ! finalRenderTargetIdx
+        finalGLRenderTarget = trgs      ! finalRenderTargetIdx
+        outs                = renderTargetOutputs texs finalRenderTarget finalGLRenderTarget
     prgs <- V.mapM compileProgram $ programs p
     -- texture unit mapping ioref trie
     -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
     texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (Set.toList $ Set.fromList $ concat $ V.toList $ V.map (Map.keys . programInTextures) $ programs p)
-    let st = execState (mapM_ (compileCommand texUnitMapRefs smps texs trgs prgs) (V.toList $ commands p)) initCGState
+    let st = execState (mapM_ (compileCommand texUnitMapRefs smps texs trgs prgs) cmds) initCGState
     input <- newIORef Nothing
     -- default Vertex Array Object
     vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
@@ -515,6 +559,7 @@ allocRenderer p = do
         , glCommands        = reverse $ drawCommands st
         , glSlotPrograms    = V.map (V.toList . slotPrograms) $ IR.slots p
         , glInput           = input
+        , glOutputs         = outs
         , glSlotNames       = V.map slotName $ IR.slots p
         , glVAO             = vao
         , glTexUnitMapping  = texUnitMapRefs
@@ -573,7 +618,7 @@ isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a
             when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
                 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim  ++ " but got " ++ show prim
             let sType = fmap streamToStreamType attribs
-            when (sType /= sAttrs) $ throw $ userError $ unlines $ 
+            when (sType /= sAttrs) $ throw $ userError $ unlines $
                 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
                 , show sAttrs
                 , " but got "
@@ -790,7 +835,7 @@ renderFrame GLRenderer{..} = do
         case cmd of
             GLClearRenderTarget rt vals -> do
               setupRenderTarget glInput rt
-              clearRenderTarget vals
+              clearRenderTarget rt vals
               modifyIORef glDrawContextRef $ \ctx -> ctx {glRenderTarget = rt}
 
             GLRenderStream ctx streamIdx progIdx -> do
@@ -895,4 +940,4 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
                                     case IM.lookup tu tb of
                                         Nothing     -> fail "internal error (GenerateMipMap)!"
                                         Just tex    -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)
--}
\ No newline at end of file
+-}
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index 49491ed..bd3f827 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -152,6 +152,7 @@ data GLRenderer
     , glTextures        :: Vector GLTexture
     , glSamplers        :: Vector GLSampler
     , glTargets         :: Vector GLRenderTarget
+    , glOutputs         :: [GLOutput]
     , glCommands        :: [GLCommand]
     , glSlotPrograms    :: Vector [ProgramName] -- programs depend on a slot
     , glInput           :: IORef (Maybe InputConnection)
@@ -177,6 +178,16 @@ data GLRenderTarget
     , framebufferDrawbuffers    :: Maybe [GLenum]
     } deriving Eq
 
+data GLOutput
+    = GLOutputDrawBuffer
+      { glOutputFBO           :: GLuint
+      , glOutputDrawBuffer    :: GLenum
+      }
+    | GLOutputRenderTexture
+      { glOutputFBO           :: GLuint
+      , glOutputRenderTexture :: GLTexture
+      }
+
 type GLTextureUnit = Int
 type GLUniformBinding = GLint
 
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index bba322b..b267c7f 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -403,6 +403,8 @@ blendingFactorToGLType a = case a of
     SrcColor                -> GL_SRC_COLOR
     Zero                    -> GL_ZERO
 
+-- XXX: we need to extend IR.TextureDescriptor to carry component bit depth
+--      if we want to avoid making arbitrary decisions here
 textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum
 textureDataTypeToGLType Color a = case a of
     FloatT Red  -> GL_R32F
@@ -412,8 +414,8 @@ textureDataTypeToGLType Color a = case a of
     IntT   RG   -> GL_RG32I
     WordT  RG   -> GL_RG32UI
     FloatT RGBA -> GL_RGBA32F
-    IntT   RGBA -> GL_RGBA32I
-    WordT  RGBA -> GL_RGBA32UI
+    IntT   RGBA -> GL_RGBA8I
+    WordT  RGBA -> GL_RGBA8UI
     a           -> error $ "FIXME: This texture format is not yet supported" ++ show a
 textureDataTypeToGLType Depth a = case a of
     FloatT Red  -> GL_DEPTH_COMPONENT32F
@@ -425,14 +427,14 @@ textureDataTypeToGLType Stencil a = case a of
 textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum
 textureDataTypeToGLArityType Color a = case a of
     FloatT Red  -> GL_RED
-    IntT   Red  -> GL_RED
-    WordT  Red  -> GL_RED
+    IntT   Red  -> GL_RED_INTEGER
+    WordT  Red  -> GL_RED_INTEGER
     FloatT RG   -> GL_RG
-    IntT   RG   -> GL_RG
-    WordT  RG   -> GL_RG
+    IntT   RG   -> GL_RG_INTEGER
+    WordT  RG   -> GL_RG_INTEGER
     FloatT RGBA -> GL_RGBA
-    IntT   RGBA -> GL_RGBA
-    WordT  RGBA -> GL_RGBA
+    IntT   RGBA -> GL_RGBA_INTEGER
+    WordT  RGBA -> GL_RGBA_INTEGER
     a           -> error $ "FIXME: This texture format is not yet supported" ++ show a
 textureDataTypeToGLArityType Depth a = case a of
     FloatT Red  -> GL_DEPTH_COMPONENT