From 705842f6dbbec605d26cd2d7a167f85d18e8275f Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 11 Apr 2019 21:52:05 -0400 Subject: uploadCubeMapToGPU --- LambdaCube/GL/Data2.hs | 181 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 181 insertions(+) create mode 100644 LambdaCube/GL/Data2.hs diff --git a/LambdaCube/GL/Data2.hs b/LambdaCube/GL/Data2.hs new file mode 100644 index 0000000..dba7ab8 --- /dev/null +++ b/LambdaCube/GL/Data2.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE LambdaCase #-} +module LambdaCube.GL.Data2 where + +import Control.Applicative +import Control.Monad +import Data.IORef +import Data.List as L +import Data.Maybe +import Foreign +--import qualified Data.IntMap as IM +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as V +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 + +import LambdaCube.GL.Type +import LambdaCube.GL.Util + +-- Buffer +disposeBuffer :: Buffer -> IO () +disposeBuffer (Buffer _ bo) = withArray [bo] $ glDeleteBuffers 1 + +compileBuffer :: [Array] -> IO Buffer +compileBuffer arrs = do + let calcDesc (offset,setters,descs) (Array arrType cnt setter) = + let size = cnt * sizeOfArrayType arrType + in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs) + (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs + bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo + glBindBuffer GL_ARRAY_BUFFER bo + glBufferData GL_ARRAY_BUFFER (fromIntegral bufSize) nullPtr GL_STATIC_DRAW + forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) + glBindBuffer GL_ARRAY_BUFFER 0 + return $! Buffer (V.fromList $! reverse arrDescs) bo + +updateBuffer :: Buffer -> [(Int,Array)] -> IO () +updateBuffer (Buffer arrDescs bo) arrs = do + glBindBuffer GL_ARRAY_BUFFER bo + forM arrs $ \(i,Array arrType cnt setter) -> do + let ArrayDesc ty len offset size = arrDescs V.! i + when (ty == arrType && cnt == len) $ + setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) + glBindBuffer GL_ARRAY_BUFFER 0 + +bufferSize :: Buffer -> Int +bufferSize = V.length . bufArrays + +arraySize :: Buffer -> Int -> Int +arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx + +arrayType :: Buffer -> Int -> ArrayType +arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx + +-- Texture +disposeTexture :: TextureData -> IO () +disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1 + +-- FIXME: Temporary implemenation +uploadTexture2DToGPU :: DynamicImage -> IO TextureData +uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False + +uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> Bool -> DynamicImage -> IO TextureData +uploadTexture2DToGPU' isFiltered isSRGB isMip isClamped bitmap' = do + let 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 + + glPixelStorei GL_UNPACK_ALIGNMENT 1 + to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto + glBindTexture GL_TEXTURE_2D 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_2D GL_TEXTURE_WRAP_S $ fromIntegral wrapMode + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral wrapMode + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter + 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 $ 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 + _ -> 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 + + +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 TextureData +uploadCubeMapToGPU = uploadCubeMapToGPU' True False True True + + +uploadCubeMapToGPU' :: Bool -> Bool -> Bool -> Bool -> [DynamicImage] -> IO TextureData +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 $ TextureData to -- cgit v1.2.3