From fcf51c414e06ff24e7f2ec350ef0cef20b6238d2 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Tue, 30 Apr 2019 12:00:46 -0400 Subject: TextureCube support. --- src/LambdaCube/GL.hs | 2 ++ src/LambdaCube/GL/Backend.hs | 13 ++++--- src/LambdaCube/GL/Data.hs | 81 ++++++++++++++++++++++++++++++++++++++++++-- src/LambdaCube/GL/Input.hs | 16 ++++----- src/LambdaCube/GL/Type.hs | 20 +++++++---- src/LambdaCube/GL/Util.hs | 8 +++-- 6 files changed, 112 insertions(+), 28 deletions(-) (limited to 'src/LambdaCube') 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 -- cgit v1.2.3