texture slot support

5 files changed, 60 insertions, 15 deletions

diff --git a/Backend/GL.hs b/Backend/GL.hs
index 6b27cd1..3edb4fa 100644
--- a/Backend/GL.hs
+++ b/Backend/GL.hs
@@ -23,6 +23,7 @@ module Backend.GL (
     arraySize,
     arrayType,
     compileTexture2DRGBAF,
+    compileTexture2DRGBAF',
 
     -- GL Pipeline Input, Object
     GLPipeline,
diff --git a/Backend/GL/Backend.hs b/Backend/GL/Backend.hs
index d3abfad..55ae443 100644
--- a/Backend/GL/Backend.hs
+++ b/Backend/GL/Backend.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns #-}
+{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-}
 module Backend.GL.Backend where
 
 import Control.Applicative
@@ -9,6 +9,7 @@ import Data.ByteString.Char8 (ByteString,pack)
 import Data.IORef
 import Data.IntMap (IntMap)
 import Data.Maybe (isNothing,fromJust)
+import Data.Map (Map)
 import Data.Set (Set)
 import Data.Trie as T
 import Data.Trie.Convenience as T
@@ -242,15 +243,29 @@ compileProgram uniTrie p = do
     unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)
     -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input
     let inUniNames = toTrie $ programUniforms p
-        (inUniforms,inTextures) = L.partition (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms
+        inUniforms = L.filter (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms
+        inTextureNames = toTrie $ programInTextures p
+        inTextures = L.filter (\(n,v) -> T.member n inTextureNames) $ T.toList $ uniforms
         texUnis = [n | (n,_) <- inTextures, T.member n uniTrie]
+    putStrLn $ "uniTrie: " ++ show (T.keys uniTrie)
+    putStrLn $ "inUniNames: " ++ show inUniNames
+    putStrLn $ "inUniforms: " ++ show inUniforms
+    putStrLn $ "inTextureNames: " ++ show inTextureNames
+    putStrLn $ "inTextures: " ++ show inTextures
+    putStrLn $ "texUnis: " ++ show texUnis
+    let valA = T.toList $ attributes
+        valB = T.toList $ toTrie $ programStreams p
+    putStrLn "------------"
+    print $ T.toList $ attributes
+    print $ T.toList $ toTrie $ programStreams p
+    let lcStreamName = fmap name (toTrie $ programStreams p)
     return $ GLProgram
         { shaderObjects         = objs
         , programObject         = po
         , inputUniforms         = T.fromList inUniforms
         , inputTextures         = T.fromList inTextures
         , inputTextureUniforms  = S.fromList $ texUnis
-        , inputStreams          = T.fromList [(n,(idx, pack attrName)) | ((n,idx),(_,(Parameter attrName _))) <- zip (T.toList $ attributes) (T.toList $ toTrie $ programStreams p)]
+        , inputStreams          = T.fromList [(n,(idx, pack attrName)) | (n,idx) <- T.toList $ attributes, let Just attrName = T.lookup n lcStreamName]
         }
 
 compileSampler :: SamplerDescriptor -> IO GLSampler
@@ -493,6 +508,7 @@ allocPipeline p = do
     trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
     prgs <- V.mapM (compileProgram uniTrie) $ programs p
     -- texture unit mapping ioref trie
+    -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)
     texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p)
     let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState
     input <- newIORef Nothing
@@ -702,11 +718,12 @@ renderSlot cmds = forM_ cmds $ \cmd -> do
                                                                 texUnit <- readIORef tuRef
                                                                 glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnit
                                                                 glBindTexture txTarget txObj
+                                                                putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
         GLSetVertexAttrib idx val                       -> do
                                                             glDisableVertexAttribArray idx
                                                             setVertexAttrib idx val
-    --isOk <- checkGL
-    --putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
+    isOk <- checkGL
+    putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
 
 renderPipeline :: GLPipeline -> IO ()
 renderPipeline glp = do
@@ -755,18 +772,20 @@ renderPipeline glp = do
             GLSaveImage
             GLLoadImage
             -}
-        --isOk <- checkGL
-        --putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
+        isOk <- checkGL
+        putStrLn $ SB.unpack isOk ++ " - " ++ show cmd
 
 data CGState
     = CGState
     { currentProgram    :: ProgramName
     , textureBinding    :: IntMap GLTexture
+    , samplerUniforms   :: Map UniformName TextureUnit
     }
 
 initCGState = CGState
     { currentProgram    = error "CGState: empty currentProgram"
     , textureBinding    = IM.empty
+    , samplerUniforms   = mempty
     }
 
 type CG a = State CGState a
@@ -780,11 +799,12 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
                                     modify (\s -> s {currentProgram = p})
                                     return $ GLSetProgram $ programObject $ programs ! p
     SetSamplerUniform n tu      -> do
+                                    modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms})
                                     p <- currentProgram <$> get
                                     case T.lookup (pack n) (inputTextures $ programs ! p) of
-                                        Nothing -> fail "internal error (SetSamplerUniform)!"
+                                        Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd
                                         Just i  -> case T.lookup (pack n) texUnitMap of
-                                            Nothing -> fail "internal error (SetSamplerUniform - IORef)!"
+                                            Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
                                             Just r  -> return $ GLSetSamplerUniform i (fromIntegral tu) r
     SetTexture tu t             -> do
                                     let tex = textures ! t
@@ -795,6 +815,7 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
                                         glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s)
 -}
     RenderSlot slot             -> do
+                                    smpUnis <- samplerUniforms <$> get
                                     p <- currentProgram <$> get
                                     return $ GLRenderSlot slot p
     RenderStream stream         -> do
diff --git a/Backend/GL/Data.hs b/Backend/GL/Data.hs
index 4eb3fa0..2c6e596 100644
--- a/Backend/GL/Data.hs
+++ b/Backend/GL/Data.hs
@@ -19,7 +19,7 @@ import qualified Data.Vector.Storable as SV
 import Graphics.Rendering.OpenGL.Raw.Core33
 import Data.Word
 import Codec.Picture
-import Codec.Picture.RGBA8
+import Codec.Picture.Types
 
 import Backend.GL.Type
 import Backend.GL.Util
@@ -60,8 +60,26 @@ arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
 
 -- FIXME: Temporary implemenation
 compileTexture2DRGBAF :: Bool -> Bool -> DynamicImage -> IO TextureData
-compileTexture2DRGBAF isMip isClamped bitmap' = do
-    let bitmap = ImageRGBA8 $ fromDynamicImage bitmap'
+compileTexture2DRGBAF = compileTexture2DRGBAF' False
+
+compileTexture2DRGBAF' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData
+compileTexture2DRGBAF' isSRGB isMip isClamped bitmap' = do
+    let bitmap = case bitmap' of
+          ImageRGB8 i@(Image w h _)   -> bitmap' -- pixelFoldMap (\(PixelRGB8 r g b) -> [PixelRGBA8 r g b maxBound]) i
+          ImageRGBA8 i@(Image w h _)  -> bitmap' -- pixelFoldMap (\(PixelRGBA8 r g b a) -> [PixelRGBA8 r g b a]) i
+          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
+          ImageCMYK16 _   -> error "compileTexture2DRGBAF: ImageCMYK16"
+          ImageCMYK8 _    -> error "compileTexture2DRGBAF: ImageCMYK8"
+          ImageRGBA16 _   -> error "compileTexture2DRGBAF: ImageRGBA16"
+          ImageRGBF _     -> error "compileTexture2DRGBAF: ImageRGBF"
+          ImageRGB16 _    -> error "compileTexture2DRGBAF: ImageRGB16"
+          ImageYA16 _     -> error "compileTexture2DRGBAF: ImageYA16"
+          ImageYA8 _      -> error "compileTexture2DRGBAF: ImageYA8"
+          ImageYF _       -> error "compileTexture2DRGBAF: ImageYF"
+          ImageY16 _      -> error "compileTexture2DRGBAF: ImageY16"
+          ImageY8 _       -> error "compileTexture2DRGBAF: ImageY8"
+          _ -> error "compileTexture2DRGBAF: unknown image"
+
     glPixelStorei gl_UNPACK_ALIGNMENT 1
     to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
     glBindTexture gl_TEXTURE_2D to
@@ -85,7 +103,7 @@ compileTexture2DRGBAF isMip isClamped bitmap' = do
     glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0
     glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
     withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
-        let internalFormat  = fromIntegral gl_RGBA8
+        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)
             dataFormat      = fromIntegral $ case nchn of
                 3   -> gl_RGB
                 4   -> gl_RGBA
diff --git a/Backend/GL/Input.hs b/Backend/GL/Input.hs
index e1d06b7..f92a9c9 100644
--- a/Backend/GL/Input.hs
+++ b/Backend/GL/Input.hs
@@ -31,7 +31,11 @@ import qualified IR as IR
 schemaFromPipeline :: IR.Pipeline -> PipelineSchema
 schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul)
   where
-    (sl,ul) = unzip [((pack n,SlotSchema p (fmap cvt (toTrie s))),toTrie u) | IR.Slot n u s p _ <- V.toList $ IR.slots a]
+    (sl,ul) = unzip [( (pack sName,SlotSchema sPrimitive (fmap cvt (toTrie sStreams)))
+                     , toTrie sUniforms
+                     )
+                    | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a
+                    ]
     cvt a = case toStreamType a of
         Just v  -> v
         Nothing -> error "internal error (schemaFromPipeline)"
diff --git a/Backend/GL/Util.hs b/Backend/GL/Util.hs
index 7a1adb0..75c2e3a 100644
--- a/Backend/GL/Util.hs
+++ b/Backend/GL/Util.hs
@@ -133,7 +133,8 @@ setUniform i ty ref = do
         M42F        -> glUniformMatrix4x2fv i 1 false (castPtr p)
         M43F        -> glUniformMatrix4x3fv i 1 false (castPtr p)
         M44F        -> glUniformMatrix4fv   i 1 false (castPtr p)
-        _   -> fail "internal error (setUniform)!"
+        FTexture2D  -> return () --putStrLn $ "TODO: setUniform FTexture2D"
+        _   -> fail $ "internal error (setUniform)! - " ++ show ty
 
 -- attribute functions
 queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)