diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,4 @@ +[![Hackage](https://img.shields.io/hackage/v/caramia.svg)](https://hackage.haskell.org/package/caramia) [![Build Status](https://travis-ci.org/Noeda/caramia.svg?branch=master)](https://travis-ci.org/Noeda/caramia) This is a highish-level OpenGL bindings library for real-time graphics for diff --git a/caramia.cabal b/caramia.cabal --- a/caramia.cabal +++ b/caramia.cabal @@ -1,5 +1,5 @@ name: caramia -version: 0.7.0.1 +version: 0.7.1.0 synopsis: High-level OpenGL bindings homepage: https://github.com/Noeda/caramia/ license: MIT @@ -135,7 +135,7 @@ ,linear >=1.15 && <2.0 ,semigroups >=0.15 && <1.0 ,text >=0.9 && <2.0 - ,transformers >=0.4 && <1.0 + ,transformers >=0.3 && <1.0 ,vector >=0.10 && <1.0 ,gl >=0.6.2 && <0.7 @@ -143,9 +143,6 @@ cpp-options: -DFIXED_OPENGL_MAJOR_VERSION=2 -DFIXED_OPENGL_MINOR_VERSION=1 - if !os(windows) - build-depends: unix >=2.7 && <3.0 - hs-source-dirs: src default-language: Haskell2010 @@ -179,6 +176,17 @@ ,test-framework-hunit >=0.3.0.1 && <1.0 default-language: Haskell2010 +test-suite color + type: exitcode-stdio-1.0 + main-is: Main.hs + ghc-options: -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: tests/color + build-depends: base, caramia + ,linear >=1.15 && <2.0 + ,test-framework >=0.8.1 && <1.0 + ,test-framework-quickcheck2 >=0.3.0.3 && <1.0 + default-language: Haskell2010 + -- This is just a dumping ground test that does stupid things. It's used to -- check if things work at all. executable smoke-test @@ -227,7 +235,7 @@ build-depends: base, caramia ,sdl2 ==1.2.* ,text >=0.9 && <2.0 - ,transformers >=0.4 && <1.0 + ,transformers >=0.3 && <1.0 ,vector >=0.10 && <1.0 else buildable: False diff --git a/demos/query-objects/Main.hs b/demos/query-objects/Main.hs --- a/demos/query-objects/Main.hs +++ b/demos/query-objects/Main.hs @@ -32,6 +32,7 @@ giveContext $ do color_program <- newPipelineVF passThroughVertex2DShader coloredFragmentProgram + mempty color_loc <- getUniformLocation "color" color_program offset_loc <- getUniformLocation "offset" color_program vao <- newVAO @@ -124,7 +125,7 @@ let byte_size = sizeOf (undefined :: Float) * V.length vec newBuffer defaultBufferCreation { size = byte_size - , initialData = Just (castPtr ptr) + , initialData = Just $ castPtr ptr , accessHints = (Static, Draw) , accessFlags = NoAccess } diff --git a/demos/smoke-test/Main.hs b/demos/smoke-test/Main.hs --- a/demos/smoke-test/Main.hs +++ b/demos/smoke-test/Main.hs @@ -64,7 +64,7 @@ -- Compile a gazillion shaders sh1 <- newShader fragmentShaderSrc Fragment - pipeline <- newPipeline [sh1] + pipeline <- newPipeline [sh1] mempty loc <- getUniformLocation "tutturuu" pipeline setUniform (transpose eye4 :: M44 CFloat) loc diff --git a/src/Graphics/Caramia/Buffer.hs b/src/Graphics/Caramia/Buffer.hs --- a/src/Graphics/Caramia/Buffer.hs +++ b/src/Graphics/Caramia/Buffer.hs @@ -6,6 +6,7 @@ -- {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} module Graphics.Caramia.Buffer ( -- * Creation @@ -252,14 +253,14 @@ -- | Same as `bufferMap` but allows more control over mapping. -- --- @ bufferMap = bufferMap2 [] @ +-- @ bufferMap = bufferMap2 mempty @ bufferMap2 :: MonadIO m => S.Set MapFlag -> Int -> Int -> AccessFlags -> Buffer - -> m (Ptr ()) + -> m (Ptr a) bufferMap2 map_flags offset num_bytes access_flags buffer -- a lot of this implementation is just error checking... @@ -322,7 +323,7 @@ -> Int -- ^ How many bytes to map. -> AccessFlags -- ^ What access is allowed in the mapping. -> Buffer - -> m (Ptr ()) + -> m (Ptr a) bufferMap = bufferMap2 S.empty -- | Exception that is thrown from `bufferUnmap` when buffer corruption is detected. @@ -364,7 +365,7 @@ -> Int -> AccessFlags -> Buffer - -> (Ptr () -> m a) + -> (Ptr b -> m a) -> m a withMapping2 map_flags offset num_bytes access_flags buffer action = mask $ \restore -> do @@ -398,7 +399,7 @@ -> Int -> AccessFlags -> Buffer - -> (Ptr () -> m a) -- ^ The pointer is valid during this action. + -> (Ptr b -> m a) -- ^ The pointer is valid during this action. -> m a withMapping = withMapping2 S.empty diff --git a/src/Graphics/Caramia/Color.hs b/src/Graphics/Caramia/Color.hs --- a/src/Graphics/Caramia/Color.hs +++ b/src/Graphics/Caramia/Color.hs @@ -1,14 +1,19 @@ -- | Color handling. -- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-} module Graphics.Caramia.Color ( -- * Types Color() + , v4 -- * Constructing colors , rgba + -- * Conversion to `Word8` colors. + , floatToWord8 + , word8ToFloat -- * Lenses , rgbaL , redL @@ -26,75 +31,74 @@ import Control.Lens import Graphics.Caramia.Prelude import Foreign.Storable -import Foreign.Ptr +import Linear.V4 -- | The color data type. -- -- This data type says nothing about the color space these values are in. The -- color space depends on the usage; for example, a framebuffer with sRGB -- textures attached uses sRGB color space in these color values. -data Color = Color - { viewRed :: !Float - , viewGreen :: !Float - , viewBlue :: !Float - , viewAlpha :: !Float - } - deriving ( Eq, Ord, Show, Read, Typeable ) +-- +-- `Color`'s `Storable` instance is equal to `V4` `Float`'s +-- `Storable` instance, in the order \"r g b a\". +newtype Color = Color { toV4 :: (V4 Float) } + deriving ( Eq, Ord, Show, Read, Typeable, Storable ) +v4 :: Lens' Color (V4 Float) +v4 = lens toV4 (\_ new -> Color new) + +viewRed :: Color -> Float +viewRed (Color (V4 r _ _ _)) = r + +viewGreen :: Color -> Float +viewGreen (Color (V4 _ g _ _)) = g + +viewBlue :: Color -> Float +viewBlue (Color (V4 _ _ b _)) = b + +viewAlpha :: Color -> Float +viewAlpha (Color (V4 _ _ _ a)) = a + +-- | A convenience function to turn a `Float` color value to a `Word8`. +-- +-- The value is clamped between 0 and 255. +floatToWord8 :: Float -> Word8 +floatToWord8 f = round $ max 0 $ min 255 $ f * 255.0 +{-# INLINE floatToWord8 #-} + +-- | Maps a `Word8` to a `Float`, so that 255 is mapped to 1.0 and 0 is mapped +-- to 0. +word8ToFloat :: Word8 -> Float +word8ToFloat w = fromIntegral w / 255.0 +{-# INLINE word8ToFloat #-} + -- | Construct a color from rgba values. rgba :: Float -> Float -> Float -> Float -> Color -rgba = Color +rgba r g b a = Color $ V4 r g b a {-# INLINE rgba #-} -- | View rgba in a tuple. viewRgba :: Color -> (Float, Float, Float, Float) -viewRgba (Color r g b a) = (r, g, b, a) +viewRgba (Color (V4 r g b a)) = (r, g, b, a) {-# INLINE viewRgba #-} -- | Lens to all components. rgbaL :: Lens' Color (Float, Float, Float, Float) -rgbaL = lens viewRgba (\old (r, g, b, a) -> - old { viewRed = r - , viewGreen = g - , viewBlue = b - , viewAlpha = a }) +rgbaL = lens viewRgba (\_ (r, g, b, a) -> Color $ V4 r g b a) -- | Lens to red component. redL :: Lens' Color Float -redL = lens viewRed (\old new -> old { viewRed = new }) +redL = v4._x -- | Lens to green component. greenL :: Lens' Color Float -greenL = lens viewGreen (\old new -> old { viewGreen = new }) +greenL = v4._y -- | Lens to blue component. blueL :: Lens' Color Float -blueL = lens viewBlue (\old new -> old { viewBlue = new }) +blueL = v4._z -- | Lens to alpha component. alphaL :: Lens' Color Float -alphaL = lens viewAlpha (\old new -> old { viewAlpha = new }) - -instance Storable Color where - sizeOf _ = sizeOf (undefined :: Float) * 4 - alignment _ = alignment (undefined :: Float) * 4 - peek ptr = do - r <- peekElemOff cptr 0 :: IO Float - g <- peekElemOff cptr 1 :: IO Float - b <- peekElemOff cptr 2 :: IO Float - a <- peekElemOff cptr 3 :: IO Float - return $ Color r g b a - where - cptr = castPtr ptr :: Ptr Float - {-# INLINE peek #-} - - poke ptr (Color r g b a) = do - pokeElemOff cptr 0 r - pokeElemOff cptr 1 g - pokeElemOff cptr 2 b - pokeElemOff cptr 3 a - where - cptr = castPtr ptr :: Ptr Float - {-# INLINE poke #-} - +alphaL = v4._w diff --git a/src/Graphics/Caramia/Internal/OpenGLCApi.hs b/src/Graphics/Caramia/Internal/OpenGLCApi.hs --- a/src/Graphics/Caramia/Internal/OpenGLCApi.hs +++ b/src/Graphics/Caramia/Internal/OpenGLCApi.hs @@ -234,23 +234,23 @@ mglNamedBufferStorage :: GLuint -> GLsizeiptr - -> Ptr () + -> Ptr a -> GLbitfield -> IO () mglNamedBufferStorage buf size ptr flags = if gl_ARB_direct_state_access - then glNamedBufferStorage buf (fromIntegral size) ptr flags - else withBoundBuffer buf $ glBufferStorage GL_ARRAY_BUFFER size ptr flags + then glNamedBufferStorage buf (fromIntegral size) (castPtr ptr) flags + else withBoundBuffer buf $ glBufferStorage GL_ARRAY_BUFFER size (castPtr ptr) flags mglNamedBufferData :: GLuint -> GLsizeiptr - -> Ptr () + -> Ptr a -> GLenum -> IO () mglNamedBufferData buf size ptr usage = if gl_ARB_direct_state_access - then glNamedBufferData buf (fromIntegral size) ptr usage - else withBoundBuffer buf $ glBufferData GL_ARRAY_BUFFER size ptr usage + then glNamedBufferData buf (fromIntegral size) (castPtr ptr) usage + else withBoundBuffer buf $ glBufferData GL_ARRAY_BUFFER size (castPtr ptr) usage mglProgramUniform1ui :: GLuint -> GLint -> GLuint -> IO () mglProgramUniform1ui program loc v1 = @@ -366,8 +366,8 @@ else withBoundProgram program $ glUniformMatrix3fv loc count transpose m33 mglMapNamedBufferRange :: GLuint -> GLintptr - -> GLsizeiptr -> GLbitfield -> IO (Ptr ()) -mglMapNamedBufferRange buffer offset length access = + -> GLsizeiptr -> GLbitfield -> IO (Ptr a) +mglMapNamedBufferRange buffer offset length access = fmap castPtr $ withBoundBuffer buffer $ if | openGLVersion >= OpenGLVersion 3 0 || gl_ARB_map_buffer_range diff --git a/src/Graphics/Caramia/Render.hs b/src/Graphics/Caramia/Render.hs --- a/src/Graphics/Caramia/Render.hs +++ b/src/Graphics/Caramia/Render.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ViewPatterns, NoImplicitPrelude, DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Graphics.Caramia.Render @@ -23,6 +24,8 @@ , setPrimitiveRestart , setTargetFramebuffer , setTextureBindings + -- ** Hoisting + , hoistDrawT -- * Specifying what to draw , DrawCommand(..) , drawCommand @@ -331,6 +334,15 @@ instance MonadTrans DrawT where lift = DrawT . lift +-- | Use to hoist the base monad in a `DrawT`. +hoistDrawT :: Monad n => (forall a. m a -> n a) -> DrawT m a -> DrawT n a +hoistDrawT changer (DrawT action) = DrawT $ do + old_st <- get + (result, new_st) <- lift $ changer $ runStateT action old_st + put new_st + return result +{-# INLINEABLE hoistDrawT #-} + -- | Runs a drawing specification. -- -- You can think of this as running many `draw` commands with similar draw @@ -387,13 +399,15 @@ data PrimitiveRestartFuns = PrimitiveRestartFuns { prIndex :: !GLenum , prRestart :: !GLenum - , prPrimitiveRestartIndex :: !(GLuint -> IO ()) } + , prPrimitiveRestartIndex :: !(GLuint -> IO ()) + , prEnable :: !(GLenum -> IO ()) + , prDisable :: !(GLenum -> IO ()) } withPrimitiveRestartFuns :: (Monad m, MonadIO m) => Bool -> m a -> (PrimitiveRestartFuns -> m a) -> m a withPrimitiveRestartFuns do_backup backup_action action = - if | gl_NV_primitive_restart -> action nvfuns - | openGLVersion >= OpenGLVersion 3 1 -> action o31funs + if | openGLVersion >= OpenGLVersion 3 1 -> action o31funs + | gl_NV_primitive_restart -> action nvfuns | do_backup -> backup_action | otherwise -> liftIO $ throwM $ NoSupport "Primitive restart requires OpenGL 3.1 or GL_NV_primitive_restart." @@ -401,10 +415,14 @@ nvfuns = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX_NV GL_PRIMITIVE_RESTART_NV glPrimitiveRestartIndexNV + glEnableClientState + glDisableClientState o31funs = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX GL_PRIMITIVE_RESTART glPrimitiveRestartIndex + glEnable + glDisable withPrimitiveRestart :: (MonadIO m, MonadMask m) => Maybe Word32 -> m a -> m a withPrimitiveRestart pr action = @@ -412,16 +430,16 @@ old_primitive_restart_enabled <- liftIO $ glIsEnabled prRestart old_i <- gi prIndex finally (activate funs >> action) - (do if old_primitive_restart_enabled /= 0 - then glEnable prRestart - else glDisable prRestart - liftIO $ prPrimitiveRestartIndex old_i) + (liftIO $ do if old_primitive_restart_enabled /= 0 + then prEnable prRestart + else prDisable prRestart + prPrimitiveRestartIndex old_i) where - activate (PrimitiveRestartFuns{..}) = case pr of - Nothing -> glDisable prRestart + activate (PrimitiveRestartFuns{..}) = liftIO $ case pr of + Nothing -> prDisable prRestart Just value -> do - glEnable prRestart - liftIO $ prPrimitiveRestartIndex (fromIntegral value) + prEnable prRestart + prPrimitiveRestartIndex (fromIntegral value) withPolygonOffset :: (MonadIO m, MonadMask m) => (Float, Float) -> m a -> m a withPolygonOffset (factor, units) action = do @@ -447,10 +465,10 @@ pr <- return . boundPrimitiveRestart =<< get liftIO $ case (pr, restart) of (Nothing, Just x) -> do - glEnable prRestart + prEnable prRestart prPrimitiveRestartIndex (fromIntegral x) (Just _, Nothing) -> do - glDisable prRestart + prDisable prRestart (Just y, Just x) | y /= x -> prPrimitiveRestartIndex (fromIntegral x) _ -> return () diff --git a/tests/color/Main.hs b/tests/color/Main.hs new file mode 100644 --- /dev/null +++ b/tests/color/Main.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Main ( main ) where + +import Graphics.Caramia.Color +import Graphics.Caramia.Prelude +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = [ + testProperty "floatToWord8 . word8ToFloat = id" floatwordid + ] + +floatwordid :: Word8 -> Bool +floatwordid x = floatToWord8 (word8ToFloat x) == x +