1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
{-# LANGUAGE LambdaCase #-}
module LambdaCube.GL.Data 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 (Texture2DName to) = withArray [to] $ glDeleteTextures 1
disposeTextureCube :: TextureCubeData -> IO ()
disposeTextureCube (TextureCubeName to) = withArray [to] $ glDeleteTextures 1
disposeTextureBuffer :: TextureBufferData -> IO ()
disposeTextureBuffer TextureBufferData{ textureBufferName = to, textureBufferObject = bo } = do
withArray [to] $ glDeleteTextures 1
withArray [bo] $ glDeleteBuffers 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 $ 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
uploadTextureBufferToGPU :: Int -- ^ count of floats in buffer to allocate
-> IO TextureBufferData
uploadTextureBufferToGPU size = do
bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
glBindBuffer GL_TEXTURE_BUFFER bo
glBufferData GL_TEXTURE_BUFFER (4 * fromIntegral size) nullPtr GL_DYNAMIC_DRAW
to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
glBindTexture GL_TEXTURE_BUFFER to
glTexBuffer GL_TEXTURE_BUFFER GL_R32F bo -- GL_R32F Means 32-bit floats.
glBindBuffer GL_TEXTURE_BUFFER 0
return TextureBufferData { textureBufferName = to
, textureBufferObject = bo
}
updateTextureBuffer :: TextureBufferData
-> Int -- ^ index
-> Int -- ^ count
-> Ptr Float -- ^ source floats to copy
-> IO ()
updateTextureBuffer t off sz ptr = do
glBindBuffer GL_TEXTURE_BUFFER $ textureBufferObject t
glBufferSubData GL_TEXTURE_BUFFER (4*fromIntegral off) (4*fromIntegral sz) ptr
glBindBuffer GL_TEXTURE_BUFFER 0
readTextureBuffer :: TextureBufferData
-> Int -- ^ index
-> Int -- ^ count
-> (Ptr Float -> IO b)
-> IO b
readTextureBuffer t off sz f = do
glBindBuffer GL_TEXTURE_BUFFER $ textureBufferObject t
ptr <- glMapBufferRange GL_TEXTURE_BUFFER (4*fromIntegral off) (4*fromIntegral sz) GL_MAP_READ_BIT
b <- f ptr
glUnmapBuffer GL_TEXTURE_BUFFER
glBindBuffer GL_TEXTURE_BUFFER 0
return b
|
