summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/LambdaCube/GL.hs2
-rw-r--r--src/LambdaCube/GL/Backend.hs13
-rw-r--r--src/LambdaCube/GL/Data.hs81
-rw-r--r--src/LambdaCube/GL/Input.hs16
-rw-r--r--src/LambdaCube/GL/Type.hs20
-rw-r--r--src/LambdaCube/GL/Util.hs8
6 files changed, 112 insertions, 28 deletions
diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs
index 5436125..47c97d8 100644
--- a/src/LambdaCube/GL.hs
+++ b/src/LambdaCube/GL.hs
@@ -16,6 +16,7 @@ module LambdaCube.GL (
16 Primitive(..), 16 Primitive(..),
17 SetterFun, 17 SetterFun,
18 TextureData, 18 TextureData,
19 TextureCubeData,
19 InputSetter(..), 20 InputSetter(..),
20 fromStreamType, 21 fromStreamType,
21 sizeOfArrayType, 22 sizeOfArrayType,
@@ -29,6 +30,7 @@ module LambdaCube.GL (
29 uploadTexture2DToGPU, 30 uploadTexture2DToGPU,
30 uploadTexture2DToGPU', 31 uploadTexture2DToGPU',
31 disposeTexture, 32 disposeTexture,
33 disposeTextureCube,
32 34
33 -- GL: Renderer, Storage, Object 35 -- GL: Renderer, Storage, Object
34 GLUniformName, 36 GLUniformName,
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 08f10d4..f3bfe47 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -4,6 +4,7 @@ module LambdaCube.GL.Backend where
4import Control.Applicative 4import Control.Applicative
5import Control.Monad 5import Control.Monad
6import Control.Monad.State.Strict 6import Control.Monad.State.Strict
7import Data.Coerce
7import Data.Maybe 8import Data.Maybe
8import Data.Bits 9import Data.Bits
9import Data.IORef 10import Data.IORef
@@ -489,7 +490,7 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
489 , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap 490 , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
490 ] 491 ]
491 uniInputType (GLTypedUniform ty _) = unwitnessType ty 492 uniInputType (GLTypedUniform ty _) = unwitnessType ty
492 uniInputType (GLUniform ty _) = ty 493 uniInputType (GLUniform r) = objectType r
493 494
494 495
495 -- object attribute stream commands 496 -- object attribute stream commands
@@ -768,12 +769,10 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_
768 glDrawElements mode count typ indicesPtr 769 glDrawElements mode count typ indicesPtr
769 modifyIORef glDrawCallCounterRef succ 770 modifyIORef glDrawCallCounterRef succ
770 GLSetUniform idx (GLTypedUniform ty ref) -> setUniform idx ty (readIORef ref) 771 GLSetUniform idx (GLTypedUniform ty ref) -> setUniform idx ty (readIORef ref)
771 GLSetUniform idx (GLUniform ty ref) -> return () -- putStrLn $ "TODO: setUniform FTexture2D" 772 GLSetUniform idx (GLUniform ref) -> return () -- putStrLn $ "TODO: setUniform FTexture2D"
772 GLBindTexture txTarget tuRef (GLUniform _ ref) -> do 773 GLBindTexture txTarget tuRef (GLUniform ref) -> do
773 txObjVal <- readIORef ref 774 txObj <- coerce <$> readIORef ref
774 -- HINT: ugly and hacky 775 do
775 with txObjVal $ \txObjPtr -> do
776 txObj <- peek $ castPtr txObjPtr :: IO GLuint
777 texUnit <- readIORef tuRef 776 texUnit <- readIORef tuRef
778 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit 777 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
779 glBindTexture txTarget txObj 778 glBindTexture txTarget txObj
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs
index 56955d1..952e14a 100644
--- a/src/LambdaCube/GL/Data.hs
+++ b/src/LambdaCube/GL/Data.hs
@@ -1,3 +1,4 @@
1{-# LANGUAGE LambdaCase #-}
1module LambdaCube.GL.Data where 2module LambdaCube.GL.Data where
2 3
3import Control.Applicative 4import Control.Applicative
@@ -15,6 +16,7 @@ import qualified Data.Vector.Storable as SV
15--import Control.DeepSeq 16--import Control.DeepSeq
16 17
17import Graphics.GL.Core33 18import Graphics.GL.Core33
19import Graphics.GL.EXT.TextureFilterAnisotropic
18import Data.Word 20import Data.Word
19import Codec.Picture 21import Codec.Picture
20import Codec.Picture.Types 22import Codec.Picture.Types
@@ -59,7 +61,10 @@ arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
59 61
60-- Texture 62-- Texture
61disposeTexture :: TextureData -> IO () 63disposeTexture :: TextureData -> IO ()
62disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1 64disposeTexture (Texture2DName to) = withArray [to] $ glDeleteTextures 1
65
66disposeTextureCube :: TextureCubeData -> IO ()
67disposeTextureCube (TextureCubeName to) = withArray [to] $ glDeleteTextures 1
63 68
64-- FIXME: Temporary implemenation 69-- FIXME: Temporary implemenation
65uploadTexture2DToGPU :: DynamicImage -> IO TextureData 70uploadTexture2DToGPU :: DynamicImage -> IO TextureData
@@ -104,4 +109,76 @@ uploadTexture2DToGPU' isFiltered isSRGB isMip isClamped bitmap' = do
104 _ -> error "unsupported texture format!" 109 _ -> error "unsupported texture format!"
105 glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr 110 glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
106 when isMip $ glGenerateMipmap GL_TEXTURE_2D 111 when isMip $ glGenerateMipmap GL_TEXTURE_2D
107 return $ TextureData to 112 return $ Texture2DName to
113
114
115compatibleImage :: DynamicImage -> DynamicImage
116compatibleImage bitmap' = case bitmap' of
117 ImageRGB8 i@(Image w h _) -> bitmap'
118 ImageRGBA8 i@(Image w h _) -> bitmap'
119 ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i
120 di -> ImageRGBA8 $ convertRGBA8 di
121
122imageFormat :: Bool {- ^ is SRGB -} -> Int {- number of channels -} -> (GLenum,GLint) {- ^ dataFormat,internalFormat -}
123imageFormat isSRGB 3 = (GL_RGB , fromIntegral $ if isSRGB then GL_SRGB8 else GL_RGB8)
124imageFormat isSRGB 4 = (GL_RGBA, fromIntegral $ if isSRGB then GL_SRGB8_ALPHA8 else GL_RGBA8)
125imageFormat isSRGB _ = error "unsupported texture format!"
126
127uploadCubeMapToGPU :: [DynamicImage] -> IO TextureCubeData
128uploadCubeMapToGPU = uploadCubeMapToGPU' True False True True
129
130
131uploadCubeMapToGPU' :: Bool -> Bool -> Bool -> Bool -> [DynamicImage] -> IO TextureCubeData
132uploadCubeMapToGPU' isFiltered isSRGB isMip isClamped (bitmap':bitmaps') = do
133 -- The six faces of the cube are represented by six subtextures that must be square and of the same size.
134
135 let (bitmap,side):bitmaps =
136 zip (map compatibleImage (bitmap':bitmaps'))
137 [GL_TEXTURE_CUBE_MAP_POSITIVE_X .. GL_TEXTURE_CUBE_MAP_NEGATIVE_Z]
138
139 glPixelStorei GL_UNPACK_ALIGNMENT 1
140 to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
141 glBindTexture GL_TEXTURE_CUBE_MAP to
142 let (width,height) = bitmapSize bitmap
143 bitmapSize (ImageRGB8 (Image w h _)) = (w,h)
144 bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)
145 bitmapSize _ = error "unsupported image type :("
146 withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0
147 withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0
148 withBitmap _ _ = error "unsupported image type :("
149 texFilter = if isFiltered then GL_LINEAR else GL_NEAREST
150 wrapMode = case isClamped of
151 True -> GL_CLAMP_TO_EDGE
152 False -> GL_REPEAT
153 (minFilter,maxLevel) = case isFiltered && isMip of
154 False -> (texFilter,0)
155 True -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
156
157 glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter
158 glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter
159 glGetEXTTextureFilterAnisotropic >>= \case
160 False -> return ()
161 True -> alloca $ \ptr -> do
162 poke ptr 0
163 glGetIntegerv GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT ptr
164 max <- peek ptr
165 glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_ANISOTROPY_EXT max
166 glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S $ fromIntegral wrapMode
167 glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T $ fromIntegral wrapMode
168
169 glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_BASE_LEVEL 0
170 glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
171 fmt <- withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
172 let fmt@(dataFormat,internalFormat) = imageFormat isSRGB nchn
173 -- Graphics.GL.Core42.glTexStorage2D GL_TEXTURE_CUBE_MAP (maxLevel + 1) internalFormat (fromIntegral w) (fromIntegral h)
174 -- glTexImage2D :: MonadIO m => GLenum -> GLint -> GLint -> GLsizei -> GLsizei -> GLint -> GLenum -> GLenum -> Ptr a -> m ()
175 glTexImage2D side 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
176 return (fmt,(w,h))
177 forM_ bitmaps $ \(b,targ) -> withBitmap b $ \wh nchn 0 ptr -> do
178 let (dataFormat,internalFormat) = case imageFormat isSRGB nchn of { x | (x,wh)==fmt -> x; _ -> error "incompatible images" }
179 glTexImage2D targ 0 internalFormat (fromIntegral $ fst wh) (fromIntegral $ snd wh) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
180
181 when isMip $ glGenerateMipmap GL_TEXTURE_CUBE_MAP
182 -- A GL_INVALID_OPERATION error will be generated if target is GL_TEXTURE_CUBE_MAP,
183 -- and not all cube-map faces are initialized and consistent.
184 return $ TextureCubeName to
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index bd46fe0..d63fe69 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -226,7 +226,7 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
226 , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap 226 , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
227 ] 227 ]
228 uniInputType (GLTypedUniform ty _) = unwitnessType ty 228 uniInputType (GLTypedUniform ty _) = unwitnessType ty
229 uniInputType (GLUniform ty _) = ty 229 uniInputType (GLUniform r) = objectType r
230 230
231 -- object attribute stream commands 231 -- object attribute stream commands
232 objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs] 232 objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs]
@@ -288,16 +288,14 @@ name @= val = do
288 Nothing -> do 288 Nothing -> do
289 tell [throwIO $ typeMismatch ty ref] 289 tell [throwIO $ typeMismatch ty ref]
290 290
291 GLUniform FTexture2D ref -> case withTypes val ref <$> eqT of 291 GLUniform ref -> case withTypes val ref <$> eqT of
292 Just Refl -> tell [val >>= writeIORef ref] 292 Just Refl -> tell [val >>= writeIORef ref]
293 Nothing -> tell [ Prelude.putStrLn $ "WARNING: Texture2D variable " 293 Nothing -> tell [ Prelude.putStrLn $ "WARNING: "++show (objectType ref)++" variable "
294 ++ show name 294 ++ show name
295 ++ " cannot recieve value " ++ show (typeRep val) 295 ++ " cannot recieve value " ++ show (typeRep val)
296 , throwIO $ typeMismatch ref val 296 , throwIO $ typeMismatch ref val
297 ] 297 ]
298 298
299 GLUniform ty _ -> tell [Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show name ++ " :: " ++ show ty]
300
301 299
302updateUniforms :: GLStorage -> UniM a -> IO () 300updateUniforms :: GLStorage -> UniM a -> IO ()
303updateUniforms storage (UniM m) = sequence_ l where 301updateUniforms storage (UniM m) = sequence_ l where
@@ -325,11 +323,11 @@ setGLUniform resolv name u val = case u of
325 , "to", show (typeOf val) 323 , "to", show (typeOf val)
326 , "value." ] 324 , "value." ]
327 325
328 GLUniform textureType ref -> case withTypes (Just val) ref <$> eqT of 326 GLUniform ref -> case withTypes (Just val) ref <$> eqT of
329 Just Refl -> writeIORef ref val 327 Just Refl -> writeIORef ref val
330 Nothing -> warn $ unwords [ show textureType 328 Nothing -> warn $ unwords [ "uniform", name
331 , "uniform", name 329 , "only accepts values of type"
332 , "only accepts values of type TextureData." ] 330 , show $ typeRep ref ]
333 where warn s = putStrLn $ "WARNING: " ++ s 331 where warn s = putStrLn $ "WARNING: " ++ s
334 332
335-- | Lookup and set a Uniform ref. 333-- | Lookup and set a Uniform ref.
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index 97b8e25..ce3a365 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -1,6 +1,8 @@
1{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 1{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2{-# LANGUAGE FlexibleContexts #-}
2module LambdaCube.GL.Type where 3module LambdaCube.GL.Type where
3 4
5import Data.Coerce
4import Data.IORef 6import Data.IORef
5import Data.Int 7import Data.Int
6import Data.IntMap.Strict (IntMap) 8import Data.IntMap.Strict (IntMap)
@@ -70,10 +72,13 @@ data ArrayDesc
70 - per object features: enable/disable visibility, set render ordering 72 - per object features: enable/disable visibility, set render ordering
71-} 73-}
72data GLUniform = forall c. Typeable c => GLTypedUniform (TypeTag c) (IORef (GLUniformValue c)) 74data GLUniform = forall c. Typeable c => GLTypedUniform (TypeTag c) (IORef (GLUniformValue c))
73 | GLUniform !InputType !(IORef TextureData) 75 | forall t. IsGLObject t => GLUniform (IORef t)
74 76
75data GLUniformValue c = forall a. GLData a c => GLUniformValue a 77data GLUniformValue c = forall a. GLData a c => GLUniformValue a
76 78
79class (Coercible t Word32, Typeable t) => IsGLObject t where
80 objectType :: p t -> InputType
81
77instance Show GLUniform where 82instance Show GLUniform where
78 showsPrec d (GLTypedUniform t _) = paren '(' 83 showsPrec d (GLTypedUniform t _) = paren '('
79 . mappend "GLUniform " 84 . mappend "GLUniform "
@@ -81,7 +86,7 @@ instance Show GLUniform where
81 . paren ')' 86 . paren ')'
82 where paren | d<=10 = (:) 87 where paren | d<=10 = (:)
83 | otherwise = \_ -> id 88 | otherwise = \_ -> id
84 showsPrec d (GLUniform t _) = paren '(' . mappend "GLUniform " . showsPrec (d+10) t . paren ')' 89 showsPrec d (GLUniform r) = paren '(' . mappend "GLUniform " . showsPrec (d+10) (objectType r) . paren ')'
85 where paren | d<=10 = (:) 90 where paren | d<=10 = (:)
86 | otherwise = \_ -> id 91 | otherwise = \_ -> id
87 92
@@ -396,11 +401,12 @@ data IndexStream b
396 , indexLength :: Int 401 , indexLength :: Int
397 } 402 }
398 403
399newtype TextureData 404newtype TextureData = Texture2DName GLuint
400 = TextureData 405instance IsGLObject TextureData where objectType _ = FTexture2D
401 { textureObject :: GLuint 406
402 } 407newtype TextureCubeData = TextureCubeName GLuint
403 deriving Storable 408instance IsGLObject TextureCubeData where objectType _ = FTextureCube
409
404 410
405data Primitive 411data Primitive
406 = TriangleStrip 412 = TriangleStrip
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index 071e86b..1320f7d 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -141,7 +141,8 @@ instance Uniformable (V3 V4F) where uniformContexts _ = contexts $ supports Type
141instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports TypeM44F 141instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports TypeM44F
142 142
143 143
144instance Uniformable TextureData where uniformContexts _ = DMap.empty -- TODO 144instance Uniformable TextureData where uniformContexts _ = DMap.empty
145instance Uniformable TextureCubeData where uniformContexts _ = DMap.empty
145 146
146mkU :: GLData a c => TypeTag c -> a -> IO GLUniform 147mkU :: GLData a c => TypeTag c -> a -> IO GLUniform
147mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a) 148mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a)
@@ -177,8 +178,9 @@ initializeUniform t = case witnessType t of
177 TypeM44F -> mkU ty (V4 z4 z4 z4 z4) 178 TypeM44F -> mkU ty (V4 z4 z4 z4 z4)
178 179
179 Nothing -> case t of 180 Nothing -> case t of
180 FTexture2D -> GLUniform t <$> newIORef (TextureData 0) 181 FTexture2D -> GLUniform <$> newIORef (Texture2DName 0)
181 _ -> fail $ "initializeUniform: " ++ show t 182 FTextureCube -> GLUniform <$> newIORef (TextureCubeName 0)
183 _ -> fail $ "initializeUniform: " ++ show t
182 184
183 185
184data TypeMismatch c a = TypeMismatch 186data TypeMismatch c a = TypeMismatch