TextureCube support.

6 files changed, 112 insertions, 28 deletions

diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs
index 5436125..47c97d8 100644
--- a/src/LambdaCube/GL.hs
+++ b/src/LambdaCube/GL.hs
@@ -16,6 +16,7 @@ module LambdaCube.GL (
     Primitive(..),
     SetterFun,
     TextureData,
+    TextureCubeData,
     InputSetter(..),
     fromStreamType,
     sizeOfArrayType,
@@ -29,6 +30,7 @@ module LambdaCube.GL (
     uploadTexture2DToGPU,
     uploadTexture2DToGPU',
     disposeTexture,
+    disposeTextureCube,
 
     -- GL: Renderer, Storage, Object
     GLUniformName,
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 08f10d4..f3bfe47 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -4,6 +4,7 @@ module LambdaCube.GL.Backend where
 import Control.Applicative
 import Control.Monad
 import Control.Monad.State.Strict
+import Data.Coerce
 import Data.Maybe
 import Data.Bits
 import Data.IORef
@@ -489,7 +490,7 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
                   , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
                   ]
         uniInputType (GLTypedUniform ty _) = unwitnessType ty
-        uniInputType (GLUniform ty _)      = ty
+        uniInputType (GLUniform r)         = objectType r
 
 
     -- object attribute stream commands
@@ -768,12 +769,10 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_
                                                             glDrawElements mode count typ indicesPtr
                                                             modifyIORef glDrawCallCounterRef succ
         GLSetUniform idx (GLTypedUniform ty ref)        -> setUniform idx ty (readIORef ref)
-        GLSetUniform idx (GLUniform ty ref)             -> return () -- putStrLn $ "TODO: setUniform FTexture2D"
-        GLBindTexture txTarget tuRef (GLUniform _ ref)  -> do
-                                                            txObjVal <- readIORef ref
-                                                            -- HINT: ugly and hacky
-                                                            with txObjVal $ \txObjPtr -> do
-                                                                txObj <- peek $ castPtr txObjPtr :: IO GLuint
+        GLSetUniform idx (GLUniform ref)                -> return () -- putStrLn $ "TODO: setUniform FTexture2D"
+        GLBindTexture txTarget tuRef (GLUniform ref)  -> do
+                                                            txObj <- coerce <$> readIORef ref
+                                                            do
                                                                 texUnit <- readIORef tuRef
                                                                 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
                                                                 glBindTexture txTarget txObj
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs
index 56955d1..952e14a 100644
--- a/src/LambdaCube/GL/Data.hs
+++ b/src/LambdaCube/GL/Data.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module LambdaCube.GL.Data where
 
 import Control.Applicative
@@ -15,6 +16,7 @@ import qualified Data.Vector.Storable as SV
 --import Control.DeepSeq
 
 import Graphics.GL.Core33
+import Graphics.GL.EXT.TextureFilterAnisotropic
 import Data.Word
 import Codec.Picture
 import Codec.Picture.Types
@@ -59,7 +61,10 @@ arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
 
 -- Texture
 disposeTexture :: TextureData -> IO ()
-disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1
+disposeTexture (Texture2DName to) = withArray [to] $ glDeleteTextures 1
+
+disposeTextureCube :: TextureCubeData -> IO ()
+disposeTextureCube (TextureCubeName to) = withArray [to] $ glDeleteTextures 1
 
 -- FIXME: Temporary implemenation
 uploadTexture2DToGPU :: DynamicImage -> IO TextureData
@@ -104,4 +109,76 @@ uploadTexture2DToGPU' isFiltered isSRGB isMip isClamped bitmap' = do
                 _   -> error "unsupported texture format!"
         glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
     when isMip $ glGenerateMipmap GL_TEXTURE_2D
-    return $ TextureData to
+    return $ Texture2DName to
+
+
+compatibleImage :: DynamicImage -> DynamicImage
+compatibleImage bitmap' = case bitmap' of
+          ImageRGB8 i@(Image w h _)   -> bitmap'
+          ImageRGBA8 i@(Image w h _)  -> bitmap'
+          ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i
+          di -> ImageRGBA8 $ convertRGBA8 di
+
+imageFormat :: Bool {- ^ is SRGB -} -> Int {- number of channels -} -> (GLenum,GLint) {- ^ dataFormat,internalFormat -}
+imageFormat isSRGB 3 = (GL_RGB , fromIntegral $ if isSRGB then GL_SRGB8        else GL_RGB8)
+imageFormat isSRGB 4 = (GL_RGBA, fromIntegral $ if isSRGB then GL_SRGB8_ALPHA8 else GL_RGBA8)
+imageFormat isSRGB _ = error "unsupported texture format!"
+
+uploadCubeMapToGPU :: [DynamicImage] -> IO TextureCubeData
+uploadCubeMapToGPU = uploadCubeMapToGPU' True False True True
+
+
+uploadCubeMapToGPU' :: Bool -> Bool -> Bool -> Bool -> [DynamicImage] -> IO TextureCubeData
+uploadCubeMapToGPU' isFiltered isSRGB isMip isClamped (bitmap':bitmaps') = do
+    -- The six faces of the cube are represented by six subtextures that must be square and of the same size.
+
+    let (bitmap,side):bitmaps =
+            zip (map compatibleImage (bitmap':bitmaps'))
+                [GL_TEXTURE_CUBE_MAP_POSITIVE_X .. GL_TEXTURE_CUBE_MAP_NEGATIVE_Z]
+
+    glPixelStorei GL_UNPACK_ALIGNMENT 1
+    to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
+    glBindTexture GL_TEXTURE_CUBE_MAP to
+    let (width,height) = bitmapSize bitmap
+        bitmapSize (ImageRGB8 (Image w h _)) = (w,h)
+        bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)
+        bitmapSize _ = error "unsupported image type :("
+        withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0
+        withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0
+        withBitmap _ _ = error "unsupported image type :("
+        texFilter = if isFiltered then GL_LINEAR else GL_NEAREST
+        wrapMode = case isClamped of
+            True    -> GL_CLAMP_TO_EDGE
+            False   -> GL_REPEAT
+        (minFilter,maxLevel) = case isFiltered && isMip of
+            False   -> (texFilter,0)
+            True    -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
+
+    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter
+    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter
+    glGetEXTTextureFilterAnisotropic >>= \case
+        False -> return ()
+        True  -> alloca $ \ptr -> do
+                    poke ptr 0
+                    glGetIntegerv GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT ptr
+                    max <- peek ptr
+                    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_ANISOTROPY_EXT max
+    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S $ fromIntegral wrapMode
+    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T $ fromIntegral wrapMode
+
+    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_BASE_LEVEL 0
+    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
+    fmt <- withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
+        let fmt@(dataFormat,internalFormat) = imageFormat isSRGB nchn
+        -- Graphics.GL.Core42.glTexStorage2D GL_TEXTURE_CUBE_MAP (maxLevel + 1) internalFormat (fromIntegral w) (fromIntegral h)
+        -- glTexImage2D :: MonadIO m => GLenum -> GLint -> GLint -> GLsizei -> GLsizei -> GLint -> GLenum -> GLenum -> Ptr a -> m ()
+        glTexImage2D side 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
+        return (fmt,(w,h))
+    forM_ bitmaps $ \(b,targ) -> withBitmap b $ \wh nchn 0 ptr -> do
+        let (dataFormat,internalFormat) = case imageFormat isSRGB nchn of { x | (x,wh)==fmt -> x; _ -> error "incompatible images" }
+        glTexImage2D targ 0 internalFormat (fromIntegral $ fst wh) (fromIntegral $ snd wh) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
+
+    when isMip $ glGenerateMipmap GL_TEXTURE_CUBE_MAP
+    -- A GL_INVALID_OPERATION error will be generated if target is GL_TEXTURE_CUBE_MAP,
+    -- and not all cube-map faces are initialized and consistent.
+    return $ TextureCubeName to
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index bd46fe0..d63fe69 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -226,7 +226,7 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
                   , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
                   ]
         uniInputType (GLTypedUniform ty _) = unwitnessType ty
-        uniInputType (GLUniform ty _)      = ty
+        uniInputType (GLUniform r)         = objectType r
 
     -- object attribute stream commands
     objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs]
@@ -288,16 +288,14 @@ name @= val = do
                 Nothing -> do
                     tell [throwIO $ typeMismatch ty ref]
 
-        GLUniform FTexture2D ref -> case withTypes val ref <$> eqT of
+        GLUniform ref -> case withTypes val ref <$> eqT of
             Just Refl -> tell [val >>= writeIORef ref]
-            Nothing -> tell [ Prelude.putStrLn $ "WARNING: Texture2D variable "
+            Nothing -> tell [ Prelude.putStrLn $ "WARNING: "++show (objectType ref)++" variable "
                                                  ++ show name
                                                  ++ " cannot recieve value " ++ show (typeRep val)
                             , throwIO $ typeMismatch ref val
                             ]
 
-        GLUniform ty _ -> tell [Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show name ++ " :: " ++ show ty]
-
 
 updateUniforms :: GLStorage -> UniM a -> IO ()
 updateUniforms storage (UniM m) = sequence_ l where
@@ -325,11 +323,11 @@ setGLUniform resolv name u val = case u of
                                           , "to", show (typeOf val)
                                           , "value." ]
 
-        GLUniform textureType ref -> case withTypes (Just val) ref <$> eqT of
+        GLUniform ref -> case withTypes (Just val) ref <$> eqT of
             Just Refl -> writeIORef ref val
-            Nothing -> warn $ unwords [ show textureType
-                                      , "uniform", name
-                                      , "only accepts values of type TextureData." ]
+            Nothing -> warn $ unwords [ "uniform", name
+                                      , "only accepts values of type"
+                                      , show $ typeRep ref ]
     where warn s = putStrLn $ "WARNING: " ++ s
 
 -- | Lookup and set a Uniform ref.
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index 97b8e25..ce3a365 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 module LambdaCube.GL.Type where
 
+import Data.Coerce
 import Data.IORef
 import Data.Int
 import Data.IntMap.Strict (IntMap)
@@ -70,10 +72,13 @@ data ArrayDesc
     - per object features: enable/disable visibility, set render ordering
 -}
 data GLUniform = forall c. Typeable c => GLTypedUniform (TypeTag c) (IORef (GLUniformValue c))
-               | GLUniform !InputType !(IORef TextureData)
+               | forall t. IsGLObject t => GLUniform (IORef t)
 
 data GLUniformValue c = forall a. GLData a c => GLUniformValue a
 
+class (Coercible t Word32, Typeable t) => IsGLObject t where
+    objectType :: p t -> InputType
+
 instance Show GLUniform where
     showsPrec d (GLTypedUniform t _) = paren '('
                                      . mappend "GLUniform "
@@ -81,7 +86,7 @@ instance Show GLUniform where
                                      . paren ')'
         where paren | d<=10     = (:)
                     | otherwise = \_ -> id
-    showsPrec d (GLUniform t _) = paren '(' . mappend "GLUniform " . showsPrec (d+10) t . paren ')'
+    showsPrec d (GLUniform r) = paren '(' . mappend "GLUniform " . showsPrec (d+10) (objectType r) . paren ')'
         where paren | d<=10     = (:)
                     | otherwise = \_ -> id
 
@@ -396,11 +401,12 @@ data IndexStream b
     , indexLength   :: Int
     }
 
-newtype TextureData
-    = TextureData
-    { textureObject :: GLuint
-    }
-    deriving Storable
+newtype TextureData = Texture2DName GLuint
+instance IsGLObject TextureData where objectType _ = FTexture2D
+
+newtype TextureCubeData = TextureCubeName GLuint
+instance IsGLObject TextureCubeData where objectType _ = FTextureCube
+
 
 data Primitive
     = TriangleStrip
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index 071e86b..1320f7d 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -141,7 +141,8 @@ instance Uniformable (V3 V4F) where uniformContexts _ = contexts $ supports Type
 instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports TypeM44F
 
 
-instance Uniformable TextureData where uniformContexts _ = DMap.empty -- TODO
+instance Uniformable TextureData where uniformContexts _ = DMap.empty
+instance Uniformable TextureCubeData where uniformContexts _ = DMap.empty
 
 mkU :: GLData a c => TypeTag c -> a -> IO GLUniform
 mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a)
@@ -177,8 +178,9 @@ initializeUniform t = case witnessType t of
         TypeM44F -> mkU ty (V4 z4 z4 z4 z4)
 
     Nothing -> case t of
-        FTexture2D -> GLUniform t <$> newIORef (TextureData 0)
-        _          -> fail $ "initializeUniform: " ++ show t
+        FTexture2D   -> GLUniform <$> newIORef (Texture2DName 0)
+        FTextureCube -> GLUniform <$> newIORef (TextureCubeName 0)
+        _            -> fail $ "initializeUniform: " ++ show t
 
 
 data TypeMismatch c a = TypeMismatch