diff options
author | Csaba Hruska <csaba.hruska@gmail.com> | 2016-01-08 12:01:39 +0100 |
---|---|---|
committer | Csaba Hruska <csaba.hruska@gmail.com> | 2016-01-08 12:01:39 +0100 |
commit | 64e13239772dae2a73e30bd0aa8ca2c70154987c (patch) | |
tree | d5f2e4d528fcf9b7815c2dcec255268413dfd61b /src/LambdaCube/GL/Data.hs | |
parent | 65c124310c6aad1fa7a97c547292f8b90a70e991 (diff) |
move to LambdaCube.GL, use more descriptive names, update for OpenGLRaw 3.0
Diffstat (limited to 'src/LambdaCube/GL/Data.hs')
-rw-r--r-- | src/LambdaCube/GL/Data.hs | 113 |
1 files changed, 113 insertions, 0 deletions
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs new file mode 100644 index 0000000..231da8b --- /dev/null +++ b/src/LambdaCube/GL/Data.hs | |||
@@ -0,0 +1,113 @@ | |||
1 | module LambdaCube.GL.Data where | ||
2 | |||
3 | import Control.Applicative | ||
4 | import Control.Monad | ||
5 | import Data.ByteString.Char8 (ByteString) | ||
6 | import Data.IORef | ||
7 | import Data.List as L | ||
8 | import Data.Maybe | ||
9 | import Data.Trie as T | ||
10 | import Foreign | ||
11 | --import qualified Data.IntMap as IM | ||
12 | import qualified Data.Map as Map | ||
13 | import qualified Data.Set as Set | ||
14 | import qualified Data.Vector as V | ||
15 | import qualified Data.Vector.Storable as SV | ||
16 | |||
17 | --import Control.DeepSeq | ||
18 | |||
19 | import Graphics.GL.Core33 | ||
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 | compileBuffer :: [Array] -> IO Buffer | ||
29 | compileBuffer arrs = do | ||
30 | let calcDesc (offset,setters,descs) (Array arrType cnt setter) = | ||
31 | let size = cnt * sizeOfArrayType arrType | ||
32 | in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs) | ||
33 | (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs | ||
34 | bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo | ||
35 | glBindBuffer GL_ARRAY_BUFFER bo | ||
36 | glBufferData GL_ARRAY_BUFFER (fromIntegral bufSize) nullPtr GL_STATIC_DRAW | ||
37 | forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) | ||
38 | glBindBuffer GL_ARRAY_BUFFER 0 | ||
39 | return $! Buffer (V.fromList $! reverse arrDescs) bo | ||
40 | |||
41 | updateBuffer :: Buffer -> [(Int,Array)] -> IO () | ||
42 | updateBuffer (Buffer arrDescs bo) arrs = do | ||
43 | glBindBuffer GL_ARRAY_BUFFER bo | ||
44 | forM arrs $ \(i,Array arrType cnt setter) -> do | ||
45 | let ArrayDesc ty len offset size = arrDescs V.! i | ||
46 | when (ty == arrType && cnt == len) $ | ||
47 | setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) | ||
48 | glBindBuffer GL_ARRAY_BUFFER 0 | ||
49 | |||
50 | bufferSize :: Buffer -> Int | ||
51 | bufferSize = V.length . bufArrays | ||
52 | |||
53 | arraySize :: Buffer -> Int -> Int | ||
54 | arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx | ||
55 | |||
56 | arrayType :: Buffer -> Int -> ArrayType | ||
57 | arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx | ||
58 | |||
59 | -- Texture | ||
60 | |||
61 | -- FIXME: Temporary implemenation | ||
62 | uploadTexture2DToGPU :: DynamicImage -> IO TextureData | ||
63 | uploadTexture2DToGPU = uploadTexture2DToGPU' False True False | ||
64 | |||
65 | uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData | ||
66 | uploadTexture2DToGPU' isSRGB isMip isClamped bitmap' = do | ||
67 | let bitmap = case bitmap' of | ||
68 | ImageRGB8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGB8 r g b) -> [PixelRGBA8 r g b maxBound]) i | ||
69 | ImageRGBA8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGBA8 r g b a) -> [PixelRGBA8 r g b a]) i | ||
70 | ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i -- $ Image w h $ SV.fromList $ pixelFoldMap (\p -> let PixelRGB8 r g b = convertPixel p in [PixelRGBA8 r g b maxBound]) i | ||
71 | ImageCMYK16 _ -> error "uploadTexture2DToGPU: ImageCMYK16" | ||
72 | ImageCMYK8 _ -> error "uploadTexture2DToGPU: ImageCMYK8" | ||
73 | ImageRGBA16 _ -> error "uploadTexture2DToGPU: ImageRGBA16" | ||
74 | ImageRGBF _ -> error "uploadTexture2DToGPU: ImageRGBF" | ||
75 | ImageRGB16 _ -> error "uploadTexture2DToGPU: ImageRGB16" | ||
76 | ImageYA16 _ -> error "uploadTexture2DToGPU: ImageYA16" | ||
77 | ImageYA8 _ -> error "uploadTexture2DToGPU: ImageYA8" | ||
78 | ImageYF _ -> error "uploadTexture2DToGPU: ImageYF" | ||
79 | ImageY16 _ -> error "uploadTexture2DToGPU: ImageY16" | ||
80 | ImageY8 _ -> error "uploadTexture2DToGPU: ImageY8" | ||
81 | _ -> error "uploadTexture2DToGPU: unknown image" | ||
82 | |||
83 | glPixelStorei GL_UNPACK_ALIGNMENT 1 | ||
84 | to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto | ||
85 | glBindTexture GL_TEXTURE_2D to | ||
86 | let (width,height) = bitmapSize bitmap | ||
87 | bitmapSize (ImageRGB8 (Image w h _)) = (w,h) | ||
88 | bitmapSize (ImageRGBA8 (Image w h _)) = (w,h) | ||
89 | bitmapSize _ = error "unsupported image type :(" | ||
90 | withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0 | ||
91 | withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0 | ||
92 | withBitmap _ _ = error "unsupported image type :(" | ||
93 | wrapMode = case isClamped of | ||
94 | True -> GL_CLAMP_TO_EDGE | ||
95 | False -> GL_REPEAT | ||
96 | (minFilter,maxLevel) = case isMip of | ||
97 | False -> (GL_LINEAR,0) | ||
98 | True -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2) | ||
99 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral wrapMode | ||
100 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral wrapMode | ||
101 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter | ||
102 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $ fromIntegral GL_LINEAR | ||
103 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_BASE_LEVEL 0 | ||
104 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel | ||
105 | withBitmap bitmap $ \(w,h) nchn 0 ptr -> do | ||
106 | 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) | ||
107 | dataFormat = fromIntegral $ case nchn of | ||
108 | 3 -> GL_RGB | ||
109 | 4 -> GL_RGBA | ||
110 | _ -> error "unsupported texture format!" | ||
111 | glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr | ||
112 | when isMip $ glGenerateMipmap GL_TEXTURE_2D | ||
113 | return $ TextureData to | ||