diff options
author | Joe Crayne <joe@jerkface.net> | 2019-04-11 21:52:05 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-04-11 21:52:05 -0400 |
commit | 705842f6dbbec605d26cd2d7a167f85d18e8275f (patch) | |
tree | e15ecaf8d801d43ff898e49dc21cdc8e50b4fcbf | |
parent | 5b8cf0fcb93c5d6e288e4426189a1564e318927a (diff) |
uploadCubeMapToGPU
-rw-r--r-- | LambdaCube/GL/Data2.hs | 181 |
1 files changed, 181 insertions, 0 deletions
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 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
2 | module LambdaCube.GL.Data2 where | ||
3 | |||
4 | import Control.Applicative | ||
5 | import Control.Monad | ||
6 | import Data.IORef | ||
7 | import Data.List as L | ||
8 | import Data.Maybe | ||
9 | import Foreign | ||
10 | --import qualified Data.IntMap as IM | ||
11 | import qualified Data.Map as Map | ||
12 | import qualified Data.Set as Set | ||
13 | import qualified Data.Vector as V | ||
14 | import qualified Data.Vector.Storable as SV | ||
15 | |||
16 | --import Control.DeepSeq | ||
17 | |||
18 | import Graphics.GL.Core33 | ||
19 | import Graphics.GL.EXT.TextureFilterAnisotropic | ||
20 | import Data.Word | ||
21 | import Codec.Picture | ||
22 | import Codec.Picture.Types | ||
23 | |||
24 | import LambdaCube.GL.Type | ||
25 | import LambdaCube.GL.Util | ||
26 | |||
27 | -- Buffer | ||
28 | disposeBuffer :: Buffer -> IO () | ||
29 | disposeBuffer (Buffer _ bo) = withArray [bo] $ glDeleteBuffers 1 | ||
30 | |||
31 | compileBuffer :: [Array] -> IO Buffer | ||
32 | compileBuffer arrs = do | ||
33 | let calcDesc (offset,setters,descs) (Array arrType cnt setter) = | ||
34 | let size = cnt * sizeOfArrayType arrType | ||
35 | in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs) | ||
36 | (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs | ||
37 | bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo | ||
38 | glBindBuffer GL_ARRAY_BUFFER bo | ||
39 | glBufferData GL_ARRAY_BUFFER (fromIntegral bufSize) nullPtr GL_STATIC_DRAW | ||
40 | forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) | ||
41 | glBindBuffer GL_ARRAY_BUFFER 0 | ||
42 | return $! Buffer (V.fromList $! reverse arrDescs) bo | ||
43 | |||
44 | updateBuffer :: Buffer -> [(Int,Array)] -> IO () | ||
45 | updateBuffer (Buffer arrDescs bo) arrs = do | ||
46 | glBindBuffer GL_ARRAY_BUFFER bo | ||
47 | forM arrs $ \(i,Array arrType cnt setter) -> do | ||
48 | let ArrayDesc ty len offset size = arrDescs V.! i | ||
49 | when (ty == arrType && cnt == len) $ | ||
50 | setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) | ||
51 | glBindBuffer GL_ARRAY_BUFFER 0 | ||
52 | |||
53 | bufferSize :: Buffer -> Int | ||
54 | bufferSize = V.length . bufArrays | ||
55 | |||
56 | arraySize :: Buffer -> Int -> Int | ||
57 | arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx | ||
58 | |||
59 | arrayType :: Buffer -> Int -> ArrayType | ||
60 | arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx | ||
61 | |||
62 | -- Texture | ||
63 | disposeTexture :: TextureData -> IO () | ||
64 | disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1 | ||
65 | |||
66 | -- FIXME: Temporary implemenation | ||
67 | uploadTexture2DToGPU :: DynamicImage -> IO TextureData | ||
68 | uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False | ||
69 | |||
70 | uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> Bool -> DynamicImage -> IO TextureData | ||
71 | uploadTexture2DToGPU' isFiltered isSRGB isMip isClamped bitmap' = do | ||
72 | let bitmap = case bitmap' of | ||
73 | ImageRGB8 i@(Image w h _) -> bitmap' | ||
74 | ImageRGBA8 i@(Image w h _) -> bitmap' | ||
75 | ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i | ||
76 | di -> ImageRGBA8 $ convertRGBA8 di | ||
77 | |||
78 | glPixelStorei GL_UNPACK_ALIGNMENT 1 | ||
79 | to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto | ||
80 | glBindTexture GL_TEXTURE_2D to | ||
81 | let (width,height) = bitmapSize bitmap | ||
82 | bitmapSize (ImageRGB8 (Image w h _)) = (w,h) | ||
83 | bitmapSize (ImageRGBA8 (Image w h _)) = (w,h) | ||
84 | bitmapSize _ = error "unsupported image type :(" | ||
85 | withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0 | ||
86 | withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0 | ||
87 | withBitmap _ _ = error "unsupported image type :(" | ||
88 | texFilter = if isFiltered then GL_LINEAR else GL_NEAREST | ||
89 | wrapMode = case isClamped of | ||
90 | True -> GL_CLAMP_TO_EDGE | ||
91 | False -> GL_REPEAT | ||
92 | (minFilter,maxLevel) = case isFiltered && isMip of | ||
93 | False -> (texFilter,0) | ||
94 | True -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2) | ||
95 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral wrapMode | ||
96 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral wrapMode | ||
97 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter | ||
98 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter | ||
99 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_BASE_LEVEL 0 | ||
100 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel | ||
101 | withBitmap bitmap $ \(w,h) nchn 0 ptr -> do | ||
102 | 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) | ||
103 | dataFormat = fromIntegral $ case nchn of | ||
104 | 3 -> GL_RGB | ||
105 | 4 -> GL_RGBA | ||
106 | _ -> error "unsupported texture format!" | ||
107 | glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr | ||
108 | when isMip $ glGenerateMipmap GL_TEXTURE_2D | ||
109 | return $ TextureData to | ||
110 | |||
111 | |||
112 | compatibleImage :: DynamicImage -> DynamicImage | ||
113 | compatibleImage bitmap' = case bitmap' of | ||
114 | ImageRGB8 i@(Image w h _) -> bitmap' | ||
115 | ImageRGBA8 i@(Image w h _) -> bitmap' | ||
116 | ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i | ||
117 | di -> ImageRGBA8 $ convertRGBA8 di | ||
118 | |||
119 | imageFormat :: Bool {- ^ is SRGB -} -> Int {- number of channels -} -> (GLenum,GLint) {- ^ dataFormat,internalFormat -} | ||
120 | imageFormat isSRGB 3 = (GL_RGB , fromIntegral $ if isSRGB then GL_SRGB8 else GL_RGB8) | ||
121 | imageFormat isSRGB 4 = (GL_RGBA, fromIntegral $ if isSRGB then GL_SRGB8_ALPHA8 else GL_RGBA8) | ||
122 | imageFormat isSRGB _ = error "unsupported texture format!" | ||
123 | |||
124 | uploadCubeMapToGPU :: [DynamicImage] -> IO TextureData | ||
125 | uploadCubeMapToGPU = uploadCubeMapToGPU' True False True True | ||
126 | |||
127 | |||
128 | uploadCubeMapToGPU' :: Bool -> Bool -> Bool -> Bool -> [DynamicImage] -> IO TextureData | ||
129 | uploadCubeMapToGPU' isFiltered isSRGB isMip isClamped (bitmap':bitmaps') = do | ||
130 | -- The six faces of the cube are represented by six subtextures that must be square and of the same size. | ||
131 | |||
132 | let (bitmap,side):bitmaps = | ||
133 | zip (map compatibleImage (bitmap':bitmaps')) | ||
134 | [GL_TEXTURE_CUBE_MAP_POSITIVE_X .. GL_TEXTURE_CUBE_MAP_NEGATIVE_Z] | ||
135 | |||
136 | glPixelStorei GL_UNPACK_ALIGNMENT 1 | ||
137 | to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto | ||
138 | glBindTexture GL_TEXTURE_CUBE_MAP to | ||
139 | let (width,height) = bitmapSize bitmap | ||
140 | bitmapSize (ImageRGB8 (Image w h _)) = (w,h) | ||
141 | bitmapSize (ImageRGBA8 (Image w h _)) = (w,h) | ||
142 | bitmapSize _ = error "unsupported image type :(" | ||
143 | withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0 | ||
144 | withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0 | ||
145 | withBitmap _ _ = error "unsupported image type :(" | ||
146 | texFilter = if isFiltered then GL_LINEAR else GL_NEAREST | ||
147 | wrapMode = case isClamped of | ||
148 | True -> GL_CLAMP_TO_EDGE | ||
149 | False -> GL_REPEAT | ||
150 | (minFilter,maxLevel) = case isFiltered && isMip of | ||
151 | False -> (texFilter,0) | ||
152 | True -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2) | ||
153 | |||
154 | glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter | ||
155 | glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter | ||
156 | glGetEXTTextureFilterAnisotropic >>= \case | ||
157 | False -> return () | ||
158 | True -> alloca $ \ptr -> do | ||
159 | poke ptr 0 | ||
160 | glGetIntegerv GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT ptr | ||
161 | max <- peek ptr | ||
162 | glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_ANISOTROPY_EXT max | ||
163 | glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S $ fromIntegral wrapMode | ||
164 | glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T $ fromIntegral wrapMode | ||
165 | |||
166 | glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_BASE_LEVEL 0 | ||
167 | glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel | ||
168 | fmt <- withBitmap bitmap $ \(w,h) nchn 0 ptr -> do | ||
169 | let fmt@(dataFormat,internalFormat) = imageFormat isSRGB nchn | ||
170 | -- Graphics.GL.Core42.glTexStorage2D GL_TEXTURE_CUBE_MAP (maxLevel + 1) internalFormat (fromIntegral w) (fromIntegral h) | ||
171 | -- glTexImage2D :: MonadIO m => GLenum -> GLint -> GLint -> GLsizei -> GLsizei -> GLint -> GLenum -> GLenum -> Ptr a -> m () | ||
172 | glTexImage2D side 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr | ||
173 | return (fmt,(w,h)) | ||
174 | forM_ bitmaps $ \(b,targ) -> withBitmap b $ \wh nchn 0 ptr -> do | ||
175 | let (dataFormat,internalFormat) = case imageFormat isSRGB nchn of { x | (x,wh)==fmt -> x; _ -> error "incompatible images" } | ||
176 | glTexImage2D targ 0 internalFormat (fromIntegral $ fst wh) (fromIntegral $ snd wh) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr | ||
177 | |||
178 | when isMip $ glGenerateMipmap GL_TEXTURE_CUBE_MAP | ||
179 | -- A GL_INVALID_OPERATION error will be generated if target is GL_TEXTURE_CUBE_MAP, | ||
180 | -- and not all cube-map faces are initialized and consistent. | ||
181 | return $ TextureData to | ||