summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL/Data.hs
blob: 952e14afedc6dedf8872e0b92429687e1e154ee6 (plain)
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
{-# 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

-- 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