caramia 0.4.0.0 → 0.5.0.0
raw patch · 9 files changed
+298/−1799 lines, 9 filesdep +lensdep +linear
Dependencies added: lens, linear
Files
- caramia.cabal +4/−3
- demos/smoke-test/Main.hs +10/−10
- src/Graphics/Caramia/Buffer.hs +80/−14
- src/Graphics/Caramia/Color.hs +1/−1
- src/Graphics/Caramia/Internal/Lens.hs +0/−22
- src/Graphics/Caramia/Internal/OpenGLCApi.hs +12/−0
- src/Graphics/Caramia/Math.hs +0/−1711
- src/Graphics/Caramia/Render.hs +49/−4
- src/Graphics/Caramia/Shader.hs +142/−34
caramia.cabal view
@@ -1,5 +1,5 @@ name: caramia-version: 0.4.0.0+version: 0.5.0.0 synopsis: Less painful OpenGL 3.3 rendering homepage: https://github.com/Noeda/caramia/ license: MIT@@ -113,11 +113,9 @@ Graphics.Caramia.ImageFormats.Internal Graphics.Caramia.Internal.ContextLocalData Graphics.Caramia.Internal.FlextGL- Graphics.Caramia.Internal.Lens Graphics.Caramia.Internal.OpenGLCApi Graphics.Caramia.Internal.OpenGLDebug Graphics.Caramia.Internal.TexStorage- Graphics.Caramia.Math Graphics.Caramia.Memory Graphics.Caramia.Prelude Graphics.Caramia.Query@@ -138,6 +136,8 @@ ,bytestring >=0.10 && <1.0 ,containers >=0.5 && <1.0 ,exceptions >=0.6 && <1.0+ ,lens >=4.6 && <5.0+ ,linear >=1.15 && <2.0 ,OpenGLRaw >=1.5 && <2.0 ,semigroups >=0.15 && <1.0 ,text >=0.9 && <2.0@@ -161,6 +161,7 @@ hs-source-dirs: demos/smoke-test if flag(build-toys) build-depends: base, caramia+ ,linear >=1.15 && <2.0 ,sdl2 ==1.2.* ,text >=0.9 && <2.0 else
demos/smoke-test/Main.hs view
@@ -2,16 +2,16 @@ module Main ( main ) where +import Control.Exception+import Data.Bits+import qualified Data.Text as T+import Foreign.C.String+import Foreign.C.Types import Graphics.Caramia.Prelude hiding ( init ) import Graphics.Caramia-import Graphics.Caramia.Math- import Graphics.UI.SDL import qualified Graphics.UI.SDL as SDL-import Foreign.C.String-import Control.Exception-import Data.Bits-import qualified Data.Text as T+import Linear.Matrix import System.Mem main :: IO ()@@ -66,16 +66,16 @@ sh1 <- newShader fragmentShaderSrc Fragment pipeline <- newPipeline [sh1] loc <- getUniformLocation "tutturuu" pipeline- setUniform (transpose44 identity44)+ setUniform (transpose eye4 :: M44 CFloat) loc pipeline- setUniform identity44+ setUniform (eye4 :: M44 CDouble) loc pipeline- setUniform identity33+ setUniform (eye3 :: M33 Float) loc pipeline- setUniform (transpose33 identity33)+ setUniform (transpose eye3 :: M33 Double) loc pipeline
src/Graphics/Caramia/Buffer.hs view
@@ -5,14 +5,15 @@ -- <https://www.opengl.org/wiki/Buffer_Object> -- --- TODO: Add glBufferStorage based implementation.--- OpenGLRaw (1.4.0.0) doesn't have this yet.- {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-} module Graphics.Caramia.Buffer ( -- * Creation newBuffer+ , newBufferFromBS+ , newBufferFromList+ , newBufferFromVector+ -- ** Types , Buffer() , AccessFrequency(..) , AccessNature(..)@@ -38,19 +39,18 @@ ) where -import Graphics.Caramia.Prelude hiding ( map )-import Graphics.Caramia.Buffer.Internal--import Graphics.Caramia.Resource-import Graphics.Caramia.Internal.OpenGLCApi--import qualified Data.Vector.Storable as V-import qualified Data.Set as S--import Data.Bits-import Foreign import Control.Monad.Catch import Control.Monad.IO.Class+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.Set as S+import qualified Data.Vector.Storable as V+import Foreign+import Graphics.Caramia.Buffer.Internal+import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.Prelude hiding ( map )+import Graphics.Caramia.Resource -- | The frequency of access to a buffer. --@@ -171,7 +171,21 @@ (usage, access) = accessHints creation createBuffer = do+ fancy_buffers <- has_GL_ARB_buffer_storage+ if fancy_buffers+ then createBufferByBufferStorage+ else createBufferOldWay++ createBufferByBufferStorage = do buf <- mglGenBuffer+ mglNamedBufferStorage buf+ safe_size+ (castPtr initial_data)+ (toConstantF $ accessFlags creation)+ return (Buffer_ buf)++ createBufferOldWay = do+ buf <- mglGenBuffer mglNamedBufferData buf safe_size (castPtr initial_data)@@ -181,6 +195,58 @@ assertNotNull ptr | ptr == nullPtr = error "newBuffer: initial data is a null pointer." | otherwise = ptr++-- | Creates a buffer from a storable vector.+--+-- This is a convenience function.+newBufferFromVector :: (Storable a, MonadIO m)+ => V.Vector a+ -> (BufferCreation -> BufferCreation)+ -- ^ A hook to modify `BufferCreation`. You can use `id`.+ -- By default all access is forbidden and buffer usage is+ -- static, draw. Don't shrink buffer size or this may+ -- crash.+ -> m Buffer+newBufferFromVector vec modifier = liftIO $+ V.unsafeWith vec $ \src_ptr ->+ newBuffer (modifier defaultBufferCreation {+ accessHints = (Static, Draw)+ , size = byte_size+ , initialData = Just $ castPtr src_ptr+ , accessFlags = NoAccess })+ where+ byte_size = V.length vec * sizeOf (undefined `asTypeOf` (vec V.! 0))++-- | Creates a buffer from a list.+--+-- The principle is the same as in `newBufferFromVector`.+newBufferFromList :: (Storable a, MonadIO m)+ => [a]+ -> (BufferCreation -> BufferCreation)+ -> m Buffer+newBufferFromList lst modifier = liftIO $+ withArrayLen lst $ \num_items ptr ->+ let byte_size = num_items*sizeOf (undefined `asTypeOf` (lst !! 0))+ in newBuffer (modifier defaultBufferCreation {+ accessHints = (Static, Draw)+ , size = byte_size+ , initialData = Just $ castPtr ptr+ , accessFlags = NoAccess })++-- | Creates a buffer from a strict bytestring.+--+-- The principle is the same as in `newBufferFromVector`.+newBufferFromBS :: MonadIO m+ => B.ByteString+ -> (BufferCreation -> BufferCreation)+ -> m Buffer+newBufferFromBS bs modifier = liftIO $+ B.unsafeUseAsCStringLen bs $ \(ptr, size) ->+ newBuffer (modifier defaultBufferCreation {+ accessHints = (Static, Draw)+ , size = size+ , initialData = Just $ castPtr ptr+ , accessFlags = NoAccess }) -- | Same as `bufferMap` but allows more control over mapping. --
src/Graphics/Caramia/Color.hs view
@@ -23,8 +23,8 @@ , viewAlpha ) where +import Control.Lens import Graphics.Caramia.Prelude-import Graphics.Caramia.Internal.Lens import Foreign.Storable import Foreign.Ptr
− src/Graphics/Caramia/Internal/Lens.hs
@@ -1,22 +0,0 @@--- | 'lens' package compatible Lens.------ This is used to avoid 'lens' dependency.-----{-# LANGUAGE RankNTypes, NoImplicitPrelude #-}--module Graphics.Caramia.Internal.Lens- ( Lens- , Lens'- , lens )- where--import Graphics.Caramia.Prelude--type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t-type Lens' s a = Lens s s a a--lens :: (s -> a) -> (s -> a -> s) -> Lens' s a-lens sa sbt afb s = sbt s `fmap` afb (sa s)-{-# INLINE lens #-}-
src/Graphics/Caramia/Internal/OpenGLCApi.hs view
@@ -34,6 +34,7 @@ , mglDeleteQuery , mglGenQuery , mglNamedBufferData+ , mglNamedBufferStorage , mglVertexArrayVertexAttribOffsetAndEnable , mglVertexArrayVertexAttribIOffsetAndEnable , mglVertexArrayVertexAttribDivisor@@ -183,6 +184,17 @@ glEnableVertexAttribArray index glVertexAttribIPointer index size dtype stride (intPtrToPtr $ fromIntegral offset)++mglNamedBufferStorage :: GLuint+ -> GLsizeiptr+ -> Ptr ()+ -> GLbitfield+ -> IO ()+mglNamedBufferStorage buf size ptr flags =+ whenExt has_GL_EXT_direct_state_access+ (glNamedBufferStorageEXT buf size ptr flags)+ (withBoundBuffer buf $+ glBufferStorage gl_ARRAY_BUFFER size ptr flags) mglNamedBufferData :: GLuint -> GLsizeiptr
− src/Graphics/Caramia/Math.hs
@@ -1,1711 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, BangPatterns, DeriveDataTypeable #-}-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}---- | Matrix, vector and quaternion math module. This module is concerned about--- common functions for graphics programming and the types from this module are--- used by the rest of Caramia.------ If you require more functionality or types, I suggest you look at a--- dedicated linear algebra package such as \'hmatrix\' or \'linear\'.------ #storable#--- `Matrix44`, `Matrix33`, `Quaternion` and `Vector3` are all `Storable`s.------ The matrices are stored as column vectors. That is, if a `Matrix4` is--- labelled like this:------ @--- Col.1 Col.2 Col.3 Col.4--- ------------------------------ Row 1 m11 m12 m13 m14--- Row 2 m21 m22 m23 m24--- Row 3 m31 m32 m33 m34--- Row 4 m41 m42 m43 m44--- ------------------------------ @------ The matrix would occupy memory (as a `Storable`) as follows:------ @--- m11, m21, m31, m41, m12, m22, m32, m42, m13 ...--- @------ where each value is a 32-bit floating point value. This is what OpenGL uses.------ (if the above matrix was a translation matrix, then m14, m24 and m34 would--- contain the x, y and z coordinates of a translation).------ The scheme is the same for a `Matrix33`, just drop the fourth row and--- column.------ `Vector3` is stored as three consecutive floating point values.------ @--- x, y, z--- @------ `Quaternion` first stores the `w` as the last element. So, the layout of a--- quaternion is:------ @--- x, y, z, w--- @------ This is also how `Caramia.Shader` maps quaternions to vectors in shaders.-----module Graphics.Caramia.Math- ( Matrix44(..)- , Matrix33(..)- , Vector3(..)- , Quaternion(..)-- -- * sizeOfs- , sizeOfMatrix44- , sizeOfMatrix33- , sizeOfVector3- , sizeOfQuaternion-- -- * 4x4 matrices- , matrix44- , withMatrix44Ptr- , inverse44- , identity44- , multiply44- , determinant44- , zero44- , perspective44- , distance44- , frustum44- , ortho44- , lookat44- , translate44- , transpose44- , scale44- , rotate44-- -- * 3x3 matrices- , matrix33- , withMatrix33Ptr- , inverse33- , identity33- , multiply33- , determinant33- , zero33- , distance33- , transpose33- , matrix33ToMatrix44- , matrix44ToMatrix33--- -- * quaternions- , quaternion- , identityq- , canonicalizeq- , distanceq- , lengthq- , normalizeq- , multiplyq- , zeroq- , axisAngleToQuaternion- , matrix44ToQuaternion- , quaternionToMatrix44-- , toTupleq- , fromTupleq-- -- * 3-component vectors- , vector3- , zero3- , distance3- , length3- , plus3- , minus3- , normalize3- , angle3- , cross3- , dot3- , negative3- , scalarMultiply3- , vector3_1ToQuaternion- , vector3Transform44- , toTuple3- , fromTuple3-- -- ** Lenses- , _x- , _y- , _z-- -- * Misc- , prettyShow )- where---- Hacking guide:------ All data types are unpacked and strict. (Almost) all functions use bang--- patterns to make sure everything is strict (mostly unneeded as they would be--- strict anyway but, for consistency, in this module, use them everywhere).------ Everything is also inlined.------ Matrix44 functions have 44 at the end.--- Matrix33 functions have 33 at the end.--- Vector3 functions have 3 at the end.--- Quaternion functions have q at the end.--------- Hlint likes to complain about this file, mostly about the repetitions.-----import Graphics.Caramia.Prelude--import Foreign.Ptr ( Ptr, castPtr )-import Foreign.Storable ( pokeElemOff, Storable(..) )-import Foreign.Marshal.Array ( allocaArray )-import Foreign.C.Types ( CFloat(..) )-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Generic.Mutable as M-import qualified Data.Vector.Unboxed as U-import Graphics.Caramia.Internal.Lens--{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}---- | A 4x4 matrix. Each mXX function accesses an individual element of the--- matrix.-data Matrix44 = Matrix44 { m11 :: {-# UNPACK #-} !Float- , m21 :: {-# UNPACK #-} !Float- , m31 :: {-# UNPACK #-} !Float- , m41 :: {-# UNPACK #-} !Float- , m12 :: {-# UNPACK #-} !Float- , m22 :: {-# UNPACK #-} !Float- , m32 :: {-# UNPACK #-} !Float- , m42 :: {-# UNPACK #-} !Float- , m13 :: {-# UNPACK #-} !Float- , m23 :: {-# UNPACK #-} !Float- , m33 :: {-# UNPACK #-} !Float- , m43 :: {-# UNPACK #-} !Float- , m14 :: {-# UNPACK #-} !Float- , m24 :: {-# UNPACK #-} !Float- , m34 :: {-# UNPACK #-} !Float- , m44 :: {-# UNPACK #-} !Float }- deriving ( Eq, Show, Read, Ord, Typeable )---- | A 3x3 matrix. Each nXX function accesses an individual element of the--- matrix.-data Matrix33 = Matrix33 { n11 :: {-# UNPACK #-} !Float- , n21 :: {-# UNPACK #-} !Float- , n31 :: {-# UNPACK #-} !Float- , n12 :: {-# UNPACK #-} !Float- , n22 :: {-# UNPACK #-} !Float- , n32 :: {-# UNPACK #-} !Float- , n13 :: {-# UNPACK #-} !Float- , n23 :: {-# UNPACK #-} !Float- , n33 :: {-# UNPACK #-} !Float }- deriving ( Eq, Show, Read, Ord, Typeable )---- | A 3-dimensional vector. `x`, `y` and `z` access each individual--- component.-data Vector3 = Vector3 { x :: {-# UNPACK #-} !Float- , y :: {-# UNPACK #-} !Float- , z :: {-# UNPACK #-} !Float }- deriving ( Eq, Show, Read, Ord, Typeable )--_x :: Lens' Vector3 Float-_x = lens x (\old_vec new_x -> old_vec { x = new_x })-_y :: Lens' Vector3 Float-_y = lens y (\old_vec new_y -> old_vec { y = new_y })-_z :: Lens' Vector3 Float-_z = lens z (\old_vec new_z -> old_vec { z = new_z })---- | A quaternion. It's composed of four values, `qx`, `qy`, `qz` and `qw`.------ In the context of Caramia, quaternions are used exclusively to represent--- rotations.-data Quaternion = Quaternion { qx :: {-# UNPACK #-} !Float- , qy :: {-# UNPACK #-} !Float- , qz :: {-# UNPACK #-} !Float- , qw :: {-# UNPACK #-} !Float }- deriving ( Eq, Show, Read, Ord, Typeable )---- | Returns the size of a `Vector3`. This is just a shortcut to calling--- `sizeOf` on a vector.-sizeOfVector3 :: Int-sizeOfVector3 = sizeOf (undefined :: Vector3)---- | Returns the size of a `Matrix3`. This is just a shortcut to calling--- `sizeOf` on a matrix.-sizeOfMatrix33 :: Int-sizeOfMatrix33 = sizeOf (undefined :: Matrix33)---- | Returns the size of a `Matrix4`. This is just a shortcut to calling--- `sizeOf` on a matrix.-sizeOfMatrix44 :: Int-sizeOfMatrix44 = sizeOf (undefined :: Matrix44)---- | Returns the size of a `Quaternion`. This is just a shortcut to calling--- `sizeOf` on a quaternion.-sizeOfQuaternion :: Int-sizeOfQuaternion = sizeOf (undefined :: Quaternion)--instance Storable Vector3 where- sizeOf _ = sizeOf (undefined :: Float) * 3- alignment _ = alignment (undefined :: Float)- peek ptr = {-# SCC "Vector3_peek" #-} do- x <- peekElemOff cptr 0- y <- peekElemOff cptr 1- z <- peekElemOff cptr 2- return $ Vector3 x y z- where- cptr = castPtr ptr-- poke ptr (Vector3 x y z) = {-# SCC "Vector3_poke" #-} do- pokeElemOff cptr 0 x- pokeElemOff cptr 1 y- pokeElemOff cptr 2 z- where- cptr = castPtr ptr--instance Storable Quaternion where- sizeOf _ = sizeOf (undefined :: Float) * 4- alignment _ = alignment (undefined :: Float)- peek ptr = {-# SCC "Quaternion_peek" #-} do- x <- peekElemOff cptr 0- y <- peekElemOff cptr 1- z <- peekElemOff cptr 2- w <- peekElemOff cptr 3- return $ Quaternion x y z w- where- cptr = castPtr ptr-- poke ptr (Quaternion x y z w) = {-# SCC "Quaternion_poke" #-} do- pokeElemOff cptr 0 x- pokeElemOff cptr 1 y- pokeElemOff cptr 2 z- pokeElemOff cptr 3 w- where- cptr = castPtr ptr--instance Storable Matrix44 where- sizeOf _ = sizeOf (undefined :: Float) * 16- alignment _ = alignment (undefined :: Float)- peek ptr = {-# SCC "Matrix44_peek" #-} do- r11 <- peekElemOff cptr 0- r21 <- peekElemOff cptr 1- r31 <- peekElemOff cptr 2- r41 <- peekElemOff cptr 3- r12 <- peekElemOff cptr 4- r22 <- peekElemOff cptr 5- r32 <- peekElemOff cptr 6- r42 <- peekElemOff cptr 7- r13 <- peekElemOff cptr 8- r23 <- peekElemOff cptr 9- r33 <- peekElemOff cptr 10- r43 <- peekElemOff cptr 11- r14 <- peekElemOff cptr 12- r24 <- peekElemOff cptr 13- r34 <- peekElemOff cptr 14- r44 <- peekElemOff cptr 15- return $ matrix44 r11 r12 r13 r14- r21 r22 r23 r24- r31 r32 r33 r34- r41 r42 r43 r44- where- cptr = castPtr ptr-- poke ptr mat = {-# SCC "Matrix44_poke" #-} do- pokeElemOff cptr 0 f11- pokeElemOff cptr 1 f21- pokeElemOff cptr 2 f31- pokeElemOff cptr 3 f41- pokeElemOff cptr 4 f12- pokeElemOff cptr 5 f22- pokeElemOff cptr 6 f32- pokeElemOff cptr 7 f42- pokeElemOff cptr 8 f13- pokeElemOff cptr 9 f23- pokeElemOff cptr 10 f33- pokeElemOff cptr 11 f43- pokeElemOff cptr 12 f14- pokeElemOff cptr 13 f24- pokeElemOff cptr 14 f34- pokeElemOff cptr 15 f44- where- cptr = castPtr ptr- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f41 = m41 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f42 = m42 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat- f43 = m43 mat- f14 = m14 mat- f24 = m24 mat- f34 = m34 mat- f44 = m44 mat--instance Storable Matrix33 where- sizeOf _ = sizeOf (undefined :: CFloat) * 9- alignment _ = alignment (undefined :: CFloat)- peek ptr = {-# SCC "Matrix33_peek" #-} do- r11 <- peekElemOff cptr 0- r21 <- peekElemOff cptr 1- r31 <- peekElemOff cptr 2- r12 <- peekElemOff cptr 3- r22 <- peekElemOff cptr 4- r32 <- peekElemOff cptr 5- r13 <- peekElemOff cptr 6- r23 <- peekElemOff cptr 7- r33 <- peekElemOff cptr 8- return $ matrix33 r11 r12 r13- r21 r22 r23- r31 r32 r33- where- cptr = castPtr ptr-- poke ptr mat = {-# SCC "Matrix33_poke" #-} do- pokeElemOff cptr 0 f11- pokeElemOff cptr 1 f21- pokeElemOff cptr 2 f31- pokeElemOff cptr 3 f12- pokeElemOff cptr 4 f22- pokeElemOff cptr 5 f32- pokeElemOff cptr 6 f13- pokeElemOff cptr 7 f23- pokeElemOff cptr 8 f33- where- cptr = castPtr ptr- f11 = n11 mat- f21 = n21 mat- f31 = n31 mat- f12 = n12 mat- f22 = n22 mat- f32 = n32 mat- f13 = n13 mat- f23 = n23 mat- f33 = n33 mat--newtype instance U.MVector s Vector3 = MV_Vector3 (U.MVector s (Float, Float, Float))-newtype instance U.Vector Vector3 = V_Vector3 (U.Vector (Float, Float, Float))--instance U.Unbox Vector3--instance M.MVector U.MVector Vector3 where- basicLength (MV_Vector3 v) = M.basicLength v- basicUnsafeSlice i n (MV_Vector3 v) = MV_Vector3 $ M.basicUnsafeSlice i n v- basicOverlaps (MV_Vector3 v1) (MV_Vector3 v2) = M.basicOverlaps v1 v2- basicUnsafeNew n = MV_Vector3 `liftM` M.basicUnsafeNew n- basicClear (MV_Vector3 v) = M.basicClear v- basicUnsafeCopy (MV_Vector3 v1) (MV_Vector3 v2) = M.basicUnsafeCopy v1 v2- basicUnsafeMove (MV_Vector3 v1) (MV_Vector3 v2) = M.basicUnsafeMove v1 v2- basicUnsafeGrow (MV_Vector3 v) n = MV_Vector3 `liftM` M.basicUnsafeGrow v n-- basicUnsafeReplicate n (Vector3 x y z) = MV_Vector3 `liftM` M.basicUnsafeReplicate n (x,y,z)- basicUnsafeRead (MV_Vector3 v) i = fromTuple3 `liftM` M.basicUnsafeRead v i- basicUnsafeWrite (MV_Vector3 v) i (Vector3 x y z) = M.basicUnsafeWrite v i (x,y,z)- basicSet (MV_Vector3 v) (Vector3 x y z) = M.basicSet v (x,y,z)--instance G.Vector U.Vector Vector3 where- basicUnsafeFreeze (MV_Vector3 v) = V_Vector3 `liftM` G.basicUnsafeFreeze v- basicUnsafeThaw (V_Vector3 v) = MV_Vector3 `liftM` G.basicUnsafeThaw v- basicLength (V_Vector3 v) = G.basicLength v- basicUnsafeSlice i n (V_Vector3 v) = V_Vector3 $ G.basicUnsafeSlice i n v- basicUnsafeCopy (MV_Vector3 mv) (V_Vector3 v) = G.basicUnsafeCopy mv v- elemseq _ = seq-- basicUnsafeIndexM (V_Vector3 v) i = fromTuple3 `liftM` G.basicUnsafeIndexM v i--newtype instance U.MVector s Quaternion = MV_Quaternion (U.MVector s (Float, Float, Float, Float))-newtype instance U.Vector Quaternion = V_Quaternion (U.Vector (Float, Float, Float, Float))--instance U.Unbox Quaternion--instance M.MVector U.MVector Quaternion where- basicLength (MV_Quaternion v) = M.basicLength v- basicUnsafeSlice i n (MV_Quaternion v) = MV_Quaternion $ M.basicUnsafeSlice i n v- basicOverlaps (MV_Quaternion v1) (MV_Quaternion v2) = M.basicOverlaps v1 v2- basicUnsafeNew n = MV_Quaternion `liftM` M.basicUnsafeNew n- basicClear (MV_Quaternion v) = M.basicClear v- basicUnsafeCopy (MV_Quaternion v1) (MV_Quaternion v2) = M.basicUnsafeCopy v1 v2- basicUnsafeMove (MV_Quaternion v1) (MV_Quaternion v2) = M.basicUnsafeMove v1 v2- basicUnsafeGrow (MV_Quaternion v) n = MV_Quaternion `liftM` M.basicUnsafeGrow v n-- basicUnsafeReplicate n (Quaternion x y z w) = MV_Quaternion `liftM` M.basicUnsafeReplicate n (x,y,z,w)- basicUnsafeRead (MV_Quaternion v) i = fromTupleq `liftM` M.basicUnsafeRead v i- basicUnsafeWrite (MV_Quaternion v) i (Quaternion x y z w) = M.basicUnsafeWrite v i (x,y,z,w)- basicSet (MV_Quaternion v) (Quaternion x y z w) = M.basicSet v (x,y,z,w)--instance G.Vector U.Vector Quaternion where- basicUnsafeFreeze (MV_Quaternion v) = V_Quaternion `liftM` G.basicUnsafeFreeze v- basicUnsafeThaw (V_Quaternion v) = MV_Quaternion `liftM` G.basicUnsafeThaw v- basicLength (V_Quaternion v) = G.basicLength v- basicUnsafeSlice i n (V_Quaternion v) = V_Quaternion $ G.basicUnsafeSlice i n v- basicUnsafeCopy (MV_Quaternion mv) (V_Quaternion v) = G.basicUnsafeCopy mv v- elemseq _ = seq-- basicUnsafeIndexM (V_Quaternion v) i = fromTupleq `liftM` G.basicUnsafeIndexM v i---- | Constructs a `Vector3` out of three values.-vector3 :: Float -- ^ X-coodinate.- -> Float -- ^ Y-coodinate.- -> Float -- ^ Z-coodinate.- -> Vector3-{-# INLINE vector3 #-}-vector3 !x !y !z = Vector3 { x = x, y = y, z = z }---- | Constructs a `Matrix44` out of 16 values.------ The order of the values is column-first. That is, in this order:------ @--- m11 m12 m13 m14 m21 m22 m23 m24 m31 ...--- @------ This allows you to write the matrix out this way:------ @--- let the_greatest_4x4_matrix_of_them_all =--- matrix4 m11 m12 m13 m14--- m21 m22 m23 m24--- m31 m32 m33 m34--- m41 m42 m43 m44--- in ...--- @-matrix44 :: Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Matrix44-{-# INLINE matrix44 #-}-matrix44 !m11 !m12 !m13 !m14- !m21 !m22 !m23 !m24- !m31 !m32 !m33 !m34- !m41 !m42 !m43 !m44 = {-# SCC "matrix44" #-}- Matrix44 { m11 = m11- , m21 = m21- , m31 = m31- , m41 = m41- , m12 = m12- , m22 = m22- , m32 = m32- , m42 = m42- , m13 = m13- , m23 = m23- , m33 = m33- , m43 = m43- , m14 = m14- , m24 = m24- , m34 = m34- , m44 = m44 }---- | Constructs a `Matrix3` out of 9 values.------ The order of the values is the same as for `matrix4`, just drop the fourth--- row and column.-matrix33 :: Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Float- -> Matrix33-{-# INLINE matrix33 #-}-matrix33 !m11 !m12 !m13- !m21 !m22 !m23- !m31 !m32 !m33 = {-# SCC "matrix33" #-}- Matrix33 { n11 = m11- , n21 = m21- , n31 = m31- , n12 = m12- , n22 = m22- , n32 = m32- , n13 = m13- , n23 = m23- , n33 = m33 }---- | Transforms a `Matrix33` into a `Matrix44`.------ If this is the original 3x3 matrix:------ @--- ------------------------ m11 m12 m13--- m21 m22 m23--- m31 m32 m33--- ------------------------ @------ Then this is the resulting matrix:------ @--- ---------------------------- m11 m12 m13 0--- m21 m22 m23 0--- m31 m32 m33 0--- 0 0 0 1--- ---------------------------- @-matrix33ToMatrix44 :: Matrix33 -> Matrix44-{-# INLINE matrix33ToMatrix44 #-}-matrix33ToMatrix44 !mat = {-# SCC "matrix33ToMatrix44" #-}- Matrix44 { m11 = f11- , m21 = f21- , m31 = f31- , m12 = f12- , m22 = f22- , m32 = f32- , m13 = f13- , m23 = f23- , m33 = f33-- , m41 = 0.0- , m42 = 0.0- , m43 = 0.0- , m44 = 1.0- , m14 = 0.0- , m24 = 0.0- , m34 = 0.0 }- where- f11 = n11 mat- f21 = n21 mat- f31 = n31 mat- f12 = n12 mat- f22 = n22 mat- f32 = n32 mat- f13 = n13 mat- f23 = n23 mat- f33 = n33 mat----- | Transforms a `Matrix44` into a `Matrix33`.------ If this is the original 4x4 matrix:------ @--- ------------------------------- m11 m12 m13 m14--- m21 m22 m23 m24--- m31 m32 m33 m34--- m41 m42 m43 m44--- ------------------------------- @------ Then this is the resulting 3x3 matrix:------ @--- ------------------------ m11 m12 m13--- m21 m22 m23--- m31 m32 m33--- ------------------------ @------ The fourth row and column are discarded.-matrix44ToMatrix33 :: Matrix44 -> Matrix33-{-# INLINE matrix44ToMatrix33 #-}-matrix44ToMatrix33 !mat = {-# SCC "matrix44ToMatrix33" #-}- Matrix33 { n11 = f11- , n21 = f21- , n31 = f31- , n12 = f12- , n22 = f22- , n32 = f32- , n13 = f13- , n23 = f23- , n33 = f33 }- where- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat---- | Runs an IO action with a pointer to a Matrix44. The pointer is valid only--- during the given IO action.------ The pointer points to an array of 16 floating point values. See--- "Caramia.Math#storable" for a description in which order the values appear.-withMatrix44Ptr :: Matrix44 -- ^ The matrix to marshal.- -> (Ptr CFloat -> IO a) -- ^ An IO action that receives a- -- pointer to floating point values- -- describing the matrix.- -> IO a-{-# INLINE withMatrix44Ptr #-}-withMatrix44Ptr mat action = {-# SCC "withMatrix44Ptr" #-}- allocaArray 16 $ \ptr -> do- pokeElemOff ptr 0 (CFloat $ m11 mat)- pokeElemOff ptr 1 (CFloat $ m21 mat)- pokeElemOff ptr 2 (CFloat $ m31 mat)- pokeElemOff ptr 3 (CFloat $ m41 mat)- pokeElemOff ptr 4 (CFloat $ m12 mat)- pokeElemOff ptr 5 (CFloat $ m22 mat)- pokeElemOff ptr 6 (CFloat $ m32 mat)- pokeElemOff ptr 7 (CFloat $ m42 mat)- pokeElemOff ptr 8 (CFloat $ m13 mat)- pokeElemOff ptr 9 (CFloat $ m23 mat)- pokeElemOff ptr 10 (CFloat $ m33 mat)- pokeElemOff ptr 11 (CFloat $ m43 mat)- pokeElemOff ptr 12 (CFloat $ m14 mat)- pokeElemOff ptr 13 (CFloat $ m24 mat)- pokeElemOff ptr 14 (CFloat $ m34 mat)- pokeElemOff ptr 15 (CFloat $ m44 mat)- action ptr---- | Same as `withMatrix44Ptr`, only with 9 floating values.-withMatrix33Ptr :: Matrix33 -> (Ptr CFloat -> IO a) -> IO a-{-# INLINE withMatrix33Ptr #-}-withMatrix33Ptr mat action = {-# SCC "withMatrix33Ptr" #-}- allocaArray 9 $ \ptr -> do- pokeElemOff ptr 0 (CFloat $ n11 mat)- pokeElemOff ptr 1 (CFloat $ n21 mat)- pokeElemOff ptr 2 (CFloat $ n31 mat)- pokeElemOff ptr 3 (CFloat $ n12 mat)- pokeElemOff ptr 4 (CFloat $ n22 mat)- pokeElemOff ptr 5 (CFloat $ n32 mat)- pokeElemOff ptr 6 (CFloat $ n13 mat)- pokeElemOff ptr 7 (CFloat $ n23 mat)- pokeElemOff ptr 8 (CFloat $ n33 mat)- action ptr---- | Returns the identity 3x3 matrix.-identity33 :: Matrix33-{-# INLINE identity33 #-}-identity33 = {-# SCC "identity33" #-}- Matrix33 { n11 = 1.0- , n21 = 0.0- , n31 = 0.0- , n12 = 0.0- , n22 = 1.0- , n32 = 0.0- , n13 = 0.0- , n23 = 0.0- , n33 = 1.0 }---- | Returns the 3x3 matrix where all components are zero.-zero33 :: Matrix33-{-# INLINE zero33 #-}-zero33 = {-# SCC "zero33" #-}- Matrix33 { n11 = 0.0- , n21 = 0.0- , n31 = 0.0- , n12 = 0.0- , n22 = 0.0- , n32 = 0.0- , n13 = 0.0- , n23 = 0.0- , n33 = 0.0 }---- | Returns the identity 4x4 matrix.-identity44 :: Matrix44-{-# INLINE identity44 #-}-identity44 = {-# SCC "identity44" #-}- Matrix44 { m11 = 1.0- , m21 = 0.0- , m31 = 0.0- , m41 = 0.0- , m12 = 0.0- , m22 = 1.0- , m32 = 0.0- , m42 = 0.0- , m13 = 0.0- , m23 = 0.0- , m33 = 1.0- , m43 = 0.0- , m14 = 0.0- , m24 = 0.0- , m34 = 0.0- , m44 = 1.0 }---- | Returns the 4x4 matrix where all components are zero.-zero44 :: Matrix44-{-# INLINE zero44 #-}-zero44 = {-# SCC "zero44" #-}- Matrix44 { m11 = 0.0- , m21 = 0.0- , m31 = 0.0- , m41 = 0.0- , m12 = 0.0- , m22 = 0.0- , m32 = 0.0- , m42 = 0.0- , m13 = 0.0- , m23 = 0.0- , m33 = 0.0- , m43 = 0.0- , m14 = 0.0- , m24 = 0.0- , m34 = 0.0- , m44 = 0.0 }---- | Calculates the inverse of a 4x4 matrix.------ A matrix doesn't always have an inverse. In this case, the matrix values--- will most likely end up being NaNs.-inverse44 :: Matrix44 -> Matrix44-{-# INLINE inverse44 #-}-inverse44 !mat4 = {-# SCC "inverse44" #-}- Matrix44 { m11 = (f11 * b11 - f12 * b10 + f13 * b9) * det- , m12 = (f02 * b10 - f01 * b11 - f03 * b9) * det- , m13 = (f31 * b5 - f32 * b4 + f33 * b3) * det- , m14 = (f22 * b4 - f21 * b5 - f23 * b3) * det- , m21 = (f12 * b8 - f10 * b11 - f13 * b7) * det- , m22 = (f00 * b11 - f02 * b8 + f03 * b7) * det- , m23 = (f32 * b2 - f30 * b5 - f33 * b1) * det- , m24 = (f20 * b5 - f22 * b2 + f23 * b1) * det- , m31 = (f10 * b10 - f11 * b8 + f13 * b6) * det- , m32 = (f01 * b8 - f00 * b10 - f03 * b6) * det- , m33 = (f30 * b4 - f31 * b2 + f33 * b0) * det- , m34 = (f21 * b2 - f20 * b4 - f23 * b0) * det- , m41 = (f11 * b7 - f10 * b9 - f12 * b6) * det- , m42 = (f00 * b9 - f01 * b7 + f02 * b6) * det- , m43 = (f31 * b1 - f30 * b3 - f32 * b0) * det- , m44 = (f20 * b3 - f21 * b1 + f22 * b0) * det }- where- f00 = m11 mat4- f10 = m21 mat4- f20 = m31 mat4- f30 = m41 mat4- f01 = m12 mat4- f11 = m22 mat4- f21 = m32 mat4- f31 = m42 mat4- f02 = m13 mat4- f12 = m23 mat4- f22 = m33 mat4- f32 = m43 mat4- f03 = m14 mat4- f13 = m24 mat4- f23 = m34 mat4- f33 = m44 mat4-- b0 = f00 * f11 - f01 * f10- b1 = f00 * f12 - f02 * f10- b2 = f00 * f13 - f03 * f10- b3 = f01 * f12 - f02 * f11- b4 = f01 * f13 - f03 * f11- b5 = f02 * f13 - f03 * f12- b6 = f20 * f31 - f21 * f30- b7 = f20 * f32 - f22 * f30- b8 = f20 * f33 - f23 * f30- b9 = f21 * f32 - f22 * f31- b10 = f21 * f33 - f23 * f31- b11 = f22 * f33 - f23 * f32-- det' = b0*b11 - b1*b10 + b2*b9 + b3*b8 - b4*b7 + b5*b6- det = 1.0 / det'---- | Calculates the determinant of a 3x3 matrix.-determinant33 :: Matrix33 -> Float-{-# INLINE determinant33 #-}-determinant33 !mat = {-# SCC "determinant33" #-} det'- where- det' = f11*f22*f33 + f12*f23*f31 + f13*f21*f32 -- f13*f22*f31 - f12*f21*f33 - f11*f23*f32- f11 = n11 mat- f21 = n21 mat- f31 = n31 mat- f12 = n12 mat- f22 = n22 mat- f32 = n32 mat- f13 = n13 mat- f23 = n23 mat- f33 = n33 mat---- | Calculats the inverse of a 3x3 matrix.------ A matrix doesn't always have an inverse. In this case, the matrix values--- will most likely end up being NaNs.-inverse33 :: Matrix33 -> Matrix33-{-# INLINE inverse33 #-}-inverse33 !mat = {-# SCC "inverse33" #-}- Matrix33 { n11 = (f22*f33-f23*f32)*det'- , n12 = (f13*f32-f12*f33)*det'- , n13 = (f12*f23-f13*f22)*det'- , n21 = (f23*f31-f21*f33)*det'- , n22 = (f11*f33-f13*f31)*det'- , n23 = (f13*f21-f11*f23)*det'- , n31 = (f21*f32-f22*f31)*det'- , n32 = (f12*f31-f11*f32)*det'- , n33 = (f11*f22-f12*f21)*det' }- where- det' = 1.0 /- (f11*f22*f33 + f12*f23*f31 + f13*f21*f32 -- f13*f22*f31 - f12*f21*f33 - f11*f23*f32)- f11 = n11 mat- f21 = n21 mat- f31 = n31 mat- f12 = n12 mat- f22 = n22 mat- f32 = n32 mat- f13 = n13 mat- f23 = n23 mat- f33 = n33 mat---- | Calculates the determinant of a 4x4 matrix.-determinant44 :: Matrix44 -> Float-{-# INLINE determinant44 #-}-determinant44 !mat = {-# SCC "determinant44" #-} det'- where- det' = b0*b11 - b1*b10 + b2*b9 + b3*b8 - b4*b7 + b5*b6-- f00 = m11 mat- f10 = m21 mat- f20 = m31 mat- f30 = m41 mat- f01 = m12 mat- f11 = m22 mat- f21 = m32 mat- f31 = m42 mat- f02 = m13 mat- f12 = m23 mat- f22 = m33 mat- f32 = m43 mat- f03 = m14 mat- f13 = m24 mat- f23 = m34 mat- f33 = m44 mat-- b0 = f00 * f11 - f01 * f10- b1 = f00 * f12 - f02 * f10- b2 = f00 * f13 - f03 * f10- b3 = f01 * f12 - f02 * f11- b4 = f01 * f13 - f03 * f11- b5 = f02 * f13 - f03 * f12- b6 = f20 * f31 - f21 * f30- b7 = f20 * f32 - f22 * f30- b8 = f20 * f33 - f23 * f30- b9 = f21 * f32 - f22 * f31- b10 = f21 * f33 - f23 * f31- b11 = f22 * f33 - f23 * f32---- | Multiplies two 3x3 matrices together.-multiply33 :: Matrix33 -> Matrix33 -> Matrix33-{-# INLINE multiply33 #-}-multiply33 !mat1 !mat2 = {-# SCC "multiply33" #-}- Matrix33 { n11 = s11*f11 + s21*f12 + s31*f13- , n21 = s11*f21 + s21*f22 + s31*f23- , n31 = s11*f31 + s21*f32 + s31*f33- , n12 = s12*f11 + s22*f12 + s32*f13- , n22 = s12*f21 + s22*f22 + s32*f23- , n32 = s12*f31 + s22*f32 + s32*f33- , n13 = s13*f11 + s23*f12 + s33*f13- , n23 = s13*f21 + s23*f22 + s33*f23- , n33 = s13*f31 + s23*f32 + s33*f33 }- where- f11 = n11 mat1- f21 = n21 mat1- f31 = n31 mat1- f12 = n12 mat1- f22 = n22 mat1- f32 = n32 mat1- f13 = n13 mat1- f23 = n23 mat1- f33 = n33 mat1- s11 = n11 mat2- s21 = n21 mat2- s31 = n31 mat2- s12 = n12 mat2- s22 = n22 mat2- s32 = n32 mat2- s13 = n13 mat2- s23 = n23 mat2- s33 = n33 mat2---- | Multiplies two 4x4 matrices together.-multiply44 :: Matrix44 -> Matrix44 -> Matrix44-{-# INLINE multiply44 #-}-multiply44 !mat1 !mat2 = {-# SCC "multiply44" #-}- Matrix44 { m11 = s11*f11 + s21*f12 + s31*f13 + s41*f14- , m21 = s11*f21 + s21*f22 + s31*f23 + s41*f24- , m31 = s11*f31 + s21*f32 + s31*f33 + s41*f34- , m41 = s11*f41 + s21*f42 + s31*f43 + s41*f44- , m12 = s12*f11 + s22*f12 + s32*f13 + s42*f14- , m22 = s12*f21 + s22*f22 + s32*f23 + s42*f24- , m32 = s12*f31 + s22*f32 + s32*f33 + s42*f34- , m42 = s12*f41 + s22*f42 + s32*f43 + s42*f44- , m13 = s13*f11 + s23*f12 + s33*f13 + s43*f14- , m23 = s13*f21 + s23*f22 + s33*f23 + s43*f24- , m33 = s13*f31 + s23*f32 + s33*f33 + s43*f34- , m43 = s13*f41 + s23*f42 + s33*f43 + s43*f44- , m14 = s14*f11 + s24*f12 + s34*f13 + s44*f14- , m24 = s14*f21 + s24*f22 + s34*f23 + s44*f24- , m34 = s14*f31 + s24*f32 + s34*f33 + s44*f34- , m44 = s14*f41 + s24*f42 + s34*f43 + s44*f44 }- where- f11 = m11 mat1- f21 = m21 mat1- f31 = m31 mat1- f41 = m41 mat1- f12 = m12 mat1- f22 = m22 mat1- f32 = m32 mat1- f42 = m42 mat1- f13 = m13 mat1- f23 = m23 mat1- f33 = m33 mat1- f43 = m43 mat1- f14 = m14 mat1- f24 = m24 mat1- f34 = m34 mat1- f44 = m44 mat1- s11 = m11 mat2- s21 = m21 mat2- s31 = m31 mat2- s41 = m41 mat2- s12 = m12 mat2- s22 = m22 mat2- s32 = m32 mat2- s42 = m42 mat2- s13 = m13 mat2- s23 = m23 mat2- s33 = m33 mat2- s43 = m43 mat2- s14 = m14 mat2- s24 = m24 mat2- s34 = m34 mat2- s44 = m44 mat2---- | Returns the Euclidean distance between two 3x3 matrices, where the--- matrices are taken to be 9-vectors.------ This can be used as a rough estimate how close, or similar two matrices are--- to each other.-distance33 :: Matrix33 -> Matrix33 -> Float-{-# INLINE distance33 #-}-distance33 !mat1 !mat2 = {-# SCC "distance33" #-}- sqrt $ (f11-s11)**2+- (f12-s12)**2+- (f13-s13)**2+- (f21-s21)**2+- (f22-s22)**2+- (f23-s23)**2+- (f31-s31)**2+- (f32-s32)**2+- (f33-s33)**2- where- f11 = n11 mat1- f21 = n21 mat1- f31 = n31 mat1- f12 = n12 mat1- f22 = n22 mat1- f32 = n32 mat1- f13 = n13 mat1- f23 = n23 mat1- f33 = n33 mat1- s11 = n11 mat2- s21 = n21 mat2- s31 = n31 mat2- s12 = n12 mat2- s22 = n22 mat2- s32 = n32 mat2- s13 = n13 mat2- s23 = n23 mat2- s33 = n33 mat2---- | Returns the Euclidean distance between two 4x4 matrices, where the--- matrices are taken to be 9-vectors.------ This can be used as a rough estimate how close, or similar two matrices are--- to each other.-distance44 :: Matrix44 -> Matrix44 -> Float-{-# INLINE distance44 #-}-distance44 !mat1 !mat2 = {-# SCC "distance44" #-}- sqrt $ (f11-s11)**2+- (f12-s12)**2+- (f13-s13)**2+- (f14-s14)**2+- (f21-s21)**2+- (f22-s22)**2+- (f23-s23)**2+- (f24-s24)**2+- (f31-s31)**2+- (f32-s32)**2+- (f33-s33)**2+- (f34-s34)**2+- (f41-s41)**2+- (f42-s42)**2+- (f43-s43)**2+- (f44-s44)**2- where- f11 = m11 mat1- f21 = m21 mat1- f31 = m31 mat1- f41 = m41 mat1- f12 = m12 mat1- f22 = m22 mat1- f32 = m32 mat1- f42 = m42 mat1- f13 = m13 mat1- f23 = m23 mat1- f33 = m33 mat1- f43 = m43 mat1- f14 = m14 mat1- f24 = m24 mat1- f34 = m34 mat1- f44 = m44 mat1- s11 = m11 mat2- s21 = m21 mat2- s31 = m31 mat2- s41 = m41 mat2- s12 = m12 mat2- s22 = m22 mat2- s32 = m32 mat2- s42 = m42 mat2- s13 = m13 mat2- s23 = m23 mat2- s33 = m33 mat2- s43 = m43 mat2- s14 = m14 mat2- s24 = m24 mat2- s34 = m34 mat2- s44 = m44 mat2---- | Constructs a perspective projection matrix.-perspective44 :: Float -- ^ Field of view in radians.- -> Float -- ^ Aspect ratio.- -> Float -- ^ Near plane distance.- -> Float -- ^ Far plane distance.- -> Matrix44-{-# INLINE perspective44 #-}-perspective44 !fov_y !aspect_ratio !near !far = {-# SCC "perspective44" #-}- frustum44 (-right) right (-top) top near far- where- top = near * tan fov_y- right = top * aspect_ratio----- | Constructs a perspective projection matrix by frustum planes.-frustum44 :: Float -- ^ Left plane.- -> Float -- ^ Right plane.- -> Float -- ^ Bottom plane.- -> Float -- ^ Top plane.- -> Float -- ^ Near plane.- -> Float -- ^ Far plane.- -> Matrix44-{-# INLINE frustum44 #-}-frustum44 !left !right !bottom !top !near !far = {-# SCC "frustum44" #-}- zero44 { m11 = n2 * rl- , m22 = n2 * tb- , m13 = (right + left) * rl- , m23 = (top + bottom) * tb- , m33 = (far + near) * nf- , m43 = -1.0- , m34 = far * n2 * nf }- where- rl = 1.0 / (right - left)- tb = 1.0 / (top - bottom)- nf = 1.0 / (near - far)- n2 = near * 2.0---- | Constructs an orthogonal projection matrix by planes.-ortho44 :: Float -- ^ Left plane.- -> Float -- ^ Right plane.- -> Float -- ^ Bottom plane.- -> Float -- ^ Top plane.- -> Float -- ^ Near plane.- -> Float -- ^ Far plane.- -> Matrix44-{-# INLINE ortho44 #-}-ortho44 !left !right !bottom !top !near !far = {-# SCC "ortho44" #-}- zero44 { m11 = (-2.0) * lr- , m22 = (-2.0) * bt- , m33 = 2.0 * nf- , m14 = (left + right) * lr- , m24 = (top + bottom) * bt- , m34 = (far + near) * nf- , m44 = 1.0 }- where- lr = 1.0 / (left - right)- bt = 1.0 / (bottom - top)- nf = 1.0 / (near - far)---- | Constructs a look-at view matrix.-lookat44 :: Vector3 -- ^ Eye position.- -> Vector3 -- ^ Center position (that is, the point we are going- -- to stare at).- -> Vector3 -- ^ Up vector. You probably want to normalize this.- -> Matrix44-{-# INLINE lookat44 #-}-lookat44 eye@(Vector3 !eyex !eyey !eyez) !center (Vector3 !ux !uy !uz)- | ec_len < 0.000001 = identity44- | otherwise = {-# SCC "lookat44" #-}- Matrix44 { m11 = xx, m21 = yx, m31 = ecx, m41 = 0.0- , m12 = xy, m22 = yy, m32 = ecy, m42 = 0.0- , m13 = xz, m23 = yz, m33 = ecz, m43 = 0.0- , m14 = -(xx * eyex + xy * eyey + xz * eyez)- , m24 = -(yx * eyex + yy * eyey + yz * eyez)- , m34 = -(ecx * eyex + ecy * eyey + ecz * eyez)- , m44 = 1.0 }- where- ec = eye `minus3` center- Vector3 ecx ecy ecz = normalize3 ec- ec_len = length3 ec-- yvec = Vector3 (ecy*xz - ecz*xy)- (ecz*xx - ecx*xz)- (ecx*xy - ecy*xx)- Vector3 yx yy yz =- if length3 yvec == 0.0- then Vector3 0 0 0- else normalize3 yvec-- xvec = Vector3 (uy*ecz - uz*ecy)- (uz*ecx - ux*ecz)- (ux*ecy - uy*ecx)- Vector3 xx xy xz =- if length3 xvec == 0.0- then Vector3 0 0 0- else normalize3 xvec---- | Normalizes a 3-vector to unit length.------ If the vector is a zero vector then this probably gives you a vector with--- NaNs as values.-normalize3 :: Vector3 -> Vector3-{-# INLINE normalize3 #-}-normalize3 v@(Vector3 !x !y !z) = {-# SCC "normalize3" #-}- Vector3 (x*ilen) (y*ilen) (z*ilen)- where- ilen = 1.0 / length3 v---- | Returns the Euclidean distance between to 3-vectors.-distance3 :: Vector3 -> Vector3 -> Float-{-# INLINE distance3 #-}-distance3 (Vector3 !x1 !y1 !z1) (Vector3 !x2 !y2 !z2) = {-# SCC "distance3" #-}- sqrt $ (x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2---- | Returns the length of a 3-vector.-length3 :: Vector3 -> Float-{-# INLINE length3 #-}-length3 (Vector3 !x !y !z) = {-# SCC "length3" #-} sqrt $ x**2 + y**2 + z**2---- | Sums two 3-vectors together.-plus3 :: Vector3 -> Vector3 -> Vector3-{-# INLINE plus3 #-}-plus3 (Vector3 !x1 !y1 !z1) (Vector3 !x2 !y2 !z2) = {-# SCC "plus3" #-}- Vector3 (x1+x2) (y1+y2) (z1+z2)---- | Subtracts the second 3-vector from the first.-minus3 :: Vector3 -> Vector3 -> Vector3-{-# INLINE minus3 #-}-minus3 (Vector3 !x1 !y1 !z1) (Vector3 !x2 !y2 !z2) = {-# SCC "minus3" #-}- Vector3 (x1-x2) (y1-y2) (z1-z2)---- | Negates all components of a 3-vector.-negative3 :: Vector3 -> Vector3-{-# INLINE negative3 #-}-negative3 (Vector3 !x !y !z) = {-# SCC "negative3" #-} Vector3 (-x) (-y) (-z)---- | Multiplies all components of a 3-vector with a scalar.-scalarMultiply3 :: Float -> Vector3 -> Vector3-{-# INLINE scalarMultiply3 #-}-scalarMultiply3 scalar (Vector3 !x !y !z) = {-# SCC "scalarMultiply3" #-}- Vector3 (x*scalar) (y*scalar) (z*scalar)---- | Modify a 4x4 matrix to scale everything by given vector.-scale44 :: Vector3 -- ^ The scale vector.- -> Matrix44 -- ^ The matrix to modify.- -> Matrix44-{-# INLINE scale44 #-}-scale44 (Vector3 !x !y !z) !mat = {-# SCC "scale44" #-}- mat { m11 = f11*x- , m21 = f21*x- , m31 = f31*x- , m41 = f41*x- , m12 = f12*y- , m22 = f22*y- , m32 = f32*y- , m42 = f42*y- , m13 = f13*z- , m23 = f23*z- , m33 = f33*z- , m43 = f43*z }- where- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f41 = m41 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f42 = m42 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat- f43 = m43 mat---- | Transposes a 3x3 matrix.-transpose33 :: Matrix33 -> Matrix33-{-# INLINE transpose33 #-}-transpose33 !mat = {-# SCC "transpose33" #-}- Matrix33 { n11 = f11- , n12 = f21- , n13 = f31- , n21 = f12- , n22 = f22- , n23 = f32- , n31 = f13- , n32 = f23- , n33 = f33 }- where- f11 = n11 mat- f21 = n21 mat- f31 = n31 mat- f12 = n12 mat- f22 = n22 mat- f32 = n32 mat- f13 = n13 mat- f23 = n23 mat- f33 = n33 mat---- | Transposes a 4x4 matrix.-transpose44 :: Matrix44 -> Matrix44-{-# INLINE transpose44 #-}-transpose44 !mat = {-# SCC "transpose44" #-}- Matrix44 { m11 = f11- , m12 = f21- , m13 = f31- , m14 = f41- , m21 = f12- , m22 = f22- , m23 = f32- , m24 = f42- , m31 = f13- , m32 = f23- , m33 = f33- , m34 = f43- , m41 = f14- , m42 = f24- , m43 = f34- , m44 = f44 }- where- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f41 = m41 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f42 = m42 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat- f43 = m43 mat- f14 = m14 mat- f24 = m24 mat- f34 = m34 mat- f44 = m44 mat---- | Modifies a 4x4 matrix to include translation.------ This is the same as multiplying a 4x4 matrix with a translation matrix.-translate44 :: Vector3 -- ^ The translation vector.- -> Matrix44 -- ^ The matrix to modify.- -> Matrix44-{-# INLINE translate44 #-}-translate44 (Vector3 !x !y !z) !mat = {-# SCC "translate44" #-}- mat { m14 = f11*x + f12*y + f13*z + f14- , m24 = f21*x + f22*y + f23*z + f24- , m34 = f31*x + f32*y + f33*z + f34- , m44 = f41*x + f42*y + f43*z + f44 }- where- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f41 = m41 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f42 = m42 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat- f43 = m43 mat- f14 = m14 mat- f24 = m24 mat- f34 = m34 mat- f44 = m44 mat---- | Modifies a 4x4 matrix to include rotation as specified by an axis-angle--- representation.------ This is the same as multiplying a matrix with a rotation matrix.-rotate44 :: Float -- ^ The angle, how much to rotate. In radians.- -> Vector3 -- ^ The rotation axis.- -> Matrix44 -- ^ The matrix to modify.- -> Matrix44-{-# INLINE rotate44 #-}-rotate44 !radians !axis !mat = {-# SCC "rotate44" #-}- mat { m11 = f11*r11 + f21*r12 + f31*r13- , m21 = f12*r11 + f21*r12 + f32*r13- , m31 = f13*r11 + f23*r12 + f33*r13- , m41 = f14*r11 + f24*r12 + f34*r13- , m12 = f11*r21 + f21*r22 + f31*r23- , m22 = f12*r21 + f22*r22 + f32*r23- , m32 = f13*r21 + f23*r22 + f33*r23- , m42 = f14*r21 + f24*r22 + f34*r23- , m13 = f11*r31 + f21*r32 + f31*r33- , m23 = f12*r31 + f22*r32 + f32*r33- , m33 = f13*r31 + f23*r32 + f33*r33- , m43 = f14*r31 + f24*r32 + f31*r33 }- where- r11 = x*x*t+cosf- r12 = y*x*t+z*sinf- r13 = z*x*t-y*sinf- r21 = x*y*t-z*sinf- r22 = y*y*t+cosf- r23 = z*y*t+x*sinf- r31 = x*z*t+y*sinf- r32 = y*z*t-x*sinf- r33 = z*z*t+cosf-- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat- f14 = m14 mat- f24 = m24 mat- f34 = m34 mat-- t = 1 - cosf- sinf = sin radians- cosf = cos radians- (Vector3 !x !y !z) = normalize3 axis---- | Transforms a 3-vector with a 4x4 matrix.------ This would be the same as transforming a 4-vector with a 4x4 matrix but the--- fourth component is taken to be 1 and is not returned.-vector3Transform44 :: Matrix44 -> Vector3 -> Vector3-{-# INLINE vector3Transform44 #-}-vector3Transform44 !mat (Vector3 !x !y !z) = {-# SCC "vector3Transform44" #-}- Vector3 { x = f11*x + f12*y + f13*z + f14- , y = f21*x + f22*y + f23*z + f24- , z = f31*x + f32*y + f33*z + f34 }- where- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat- f14 = m14 mat- f24 = m24 mat- f34 = m34 mat---- | Returns the cross product between two 3-vectors.-cross3 :: Vector3 -> Vector3 -> Vector3-{-# INLINE cross3 #-}-cross3 (Vector3 !x1 !y1 !z1) (Vector3 !x2 !y2 !z2) = {-# SCC "cross3" #-}- Vector3 { x = y1*z2 - z1*y2- , y = z1*x2 - x1*z2- , z = x1*y2 - y1*x2 }---- | Returns the angle, in radians, between two 3-vectors.------ The vectors are normalized by this function so you need not to do that--- yourself.-angle3 :: Vector3 -> Vector3 -> Float-{-# INLINE angle3 #-}-angle3 v1 v2 = {-# SCC "angle3" #-} acos $ n1 `dot3` n2- where- n1 = normalize3 v1- n2 = normalize3 v2---- | Returns the dot product between two 3-vectors.-dot3 :: Vector3 -> Vector3 -> Float-{-# INLINE dot3 #-}-dot3 (Vector3 !x1 !y1 !z1) (Vector3 !x2 !y2 !z2) = {-# SCC "dot3" #-}- x1*x2 + y1*y2 + z1*z2---- | Transforms a 3-vector into a tuple.-toTuple3 :: Vector3 -> (Float, Float, Float)-{-# INLINE toTuple3 #-}-toTuple3 (Vector3 !x !y !z) = {-# SCC "toTuple3" #-} (x, y, z)---- | Transforms a tuple into a 3-vector.-fromTuple3 :: (Float, Float, Float) -> Vector3-{-# INLINE fromTuple3 #-}-fromTuple3 (!x, !y, !z) = {-# SCC "fromTuple3" #-}- Vector3 { x = x, y = y, z = z }---- | Returns a vector where all components are 0.-zero3 :: Vector3-{-# INLINE zero3 #-}-zero3 = {-# SCC "zero3" #-} Vector3 { x = 0, y = 0, z = 0 }---- | Transforms a 4x4 matrix to a list of floats.------ The list follows the same order as the `Storable` instance does for--- `Matrix44` floating point values. The list will always have 16 elements.-toList4 :: Matrix44 -> [Float]-toList4 mat = {-# SCC "toList4" #-}- (\f -> f mat) <$>- [m11, m21, m31, m41- ,m12, m22, m32, m42- ,m13, m23, m33, m43- ,m14, m24, m34, m44]---- | Construct a quaternion out of 4 values.-quaternion :: Float -- ^ The x-component.- -> Float -- ^ The y-component.- -> Float -- ^ The z-component.- -> Float -- ^ The w-component.- -> Quaternion-{-# INLINE quaternion #-}-quaternion !x !y !z !w = {-# SCC "quaternion" #-}- Quaternion { qx = x, qy = y, qz = z, qw = w }---- | Turns a quaternion into a 4-tuple.-toTupleq :: Quaternion -> (Float, Float, Float, Float)-{-# INLINE toTupleq #-}-toTupleq (Quaternion !x !y !z !w) = {-# SCC "toTupleq" #-} (x, y, z, w)---- | Turns a 4-tuple into a quaternion.-fromTupleq :: (Float, Float, Float, Float) -> Quaternion-{-# INLINE fromTupleq #-}-fromTupleq (!x, !y, !z, !w) = {-# SCC "fromTupleq" #-} Quaternion x y z w---- | \"canonicalizes\" a quaternion.------ Some rotations have different representations as a quaternion. This function--- canonicalizes the quaternion so that those rotations are the same.------ Don't rely on this. This is used in some automatic tests to see that the--- quaternions work correctly.-canonicalizeq :: Quaternion -> Quaternion-{-# INLINE canonicalizeq #-}-canonicalizeq q@(Quaternion !x !y !z !w) = {-# SCC "canonicalizeq" #-}- canonicalizeq'- where- canonicalizeq'- | w > 0 = q- | otherwise = Quaternion (-x) (-y) (-z) (-w)---- | Normalizes a quaternion to unit length.-normalizeq :: Quaternion -> Quaternion-{-# INLINE normalizeq #-}-normalizeq (Quaternion !x !y !z !w) = {-# SCC "normalizeq" #-}- Quaternion (x*t) (y*t) (z*t) (w*t)- where- t = 1.0 / sqrt (x*x + y*y + z*z + w*w)---- | Returns the Euclidean distance between two quaternions.-distanceq :: Quaternion -> Quaternion -> Float-{-# INLINE distanceq #-}-distanceq (Quaternion !x1 !y1 !z1 !w1)- (Quaternion !x2 !y2 !z2 !w2) = {-# SCC "distanceq" #-}- sqrt $ (x1-x2)**2 + (y1-y2)**2 + (z1-z2)**2 + (w1-w2)**2---- | Returns the length of a quaternion.-lengthq :: Quaternion -> Float-{-# INLINE lengthq #-}-lengthq (Quaternion !x !y !z !w) = {-# SCC "lengthq" #-}- sqrt $ x*x + y*y + z*z + w*w---- | Turns an axis angle rotation into a quaternion.-axisAngleToQuaternion :: Float -- ^ The angle, in radians.- -> Vector3 -- ^ The rotation axis.- -> Quaternion-{-# INLINE axisAngleToQuaternion #-}-axisAngleToQuaternion !radians !vec = {-# SCC "axisAngleToQuaternion" #-}- Quaternion { qx = x * sin_angle- , qy = y * sin_angle- , qz = z * sin_angle- , qw = cos hangle }- where- Vector3 x y z = normalize3 vec- sin_angle = sin hangle- hangle = radians * 0.5---- | Returns a quaternion where all the elements are zero.-zeroq :: Quaternion-{-# INLINE zeroq #-}-zeroq = {-# SCC "zeroq" #-} Quaternion 0 0 0 0---- | Turns the quaternion into a 4x4 rotation matrix.-quaternionToMatrix44 :: Quaternion -> Matrix44-{-# INLINE quaternionToMatrix44 #-}-quaternionToMatrix44 !q = {-# SCC "quaternionToMatrix44" #-}- identity44 { m11 = 1 - yy2 - zz2- , m22 = 1 - xx2 - zz2- , m33 = 1 - xx2 - yy2-- , m32 = yz2 - wx2- , m23 = yz2 + wx2- , m21 = xy2 - wz2- , m12 = xy2 + wz2- , m13 = xz2 - wy2- , m31 = xz2 + wy2 }- where- Quaternion x y z w = normalizeq q- x2 = x+x- y2 = y+y- z2 = z+z- xx2 = x*x2- yy2 = y*y2- zz2 = z*z2- yz2 = y*z2- wx2 = w*x2- xy2 = x*y2- wz2 = w*z2- xz2 = x*z2- wy2 = w*y2---- | Extracts rotation from a 4x4 matrix and returns it as a quaternion.------ Note that------ @--- matrix44ToQuaternion . quaternionToMatrix44--- @------ may not be the identity function. The signs on the quaternion components may--- be different and because the floating point calculation is not completely--- precise, the values are often slightly different than they were originally.-matrix44ToQuaternion :: Matrix44 -> Quaternion-{-# INLINE matrix44ToQuaternion #-}-matrix44ToQuaternion !mat = {-# SCC "matrix44ToQuaternion" #-}- matrix44ToQuaternion'- where- matrix44ToQuaternion'- | trace > 0 =- let t = trace + 1- s = 0.5 * isqrt t- in Quaternion { qw = s * t- , qz = (f12 - f21) * s- , qy = (f31 - f13) * s- , qx = (f23 - f32) * s }-- | f11 > f22 && f11 > f33 =- let t = f11 - f22 - f33 + 1- s = 0.5 * isqrt t- in Quaternion { qx = s * t- , qy = (f12 + f21) * s- , qz = (f31 + f13) * s- , qw = (f23 - f32) * s }-- | f22 > f33 =- let t = (-f11) + f22 - f33 + 1- s = 0.5 * isqrt t- in Quaternion { qy = s * t- , qx = (f12 + f21) * s- , qw = (f31 - f13) * s- , qz = (f23 + f32) * s }-- | otherwise =- let t = (-f11) - f22 + f33 + 1- s = 0.5 * isqrt t- in Quaternion { qz = s * t- , qw = (f12 - f21) * s- , qx = (f31 + f13) * s- , qy = (f23 + f32) * s }-- trace = f11 + f22 + f33- isqrt = (1.0 /) . sqrt-- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat---- | Returns the identity quaternion. It won't rotate anything.-identityq :: Quaternion-{-# INLINE identityq #-}-identityq = {-# SCC "identityq" #-} quaternion 0 0 0 1--{-# ANN vector3_1ToQuaternion ("HLint: ignore Use camelCase" :: String) #-}--- | Turns a `Vector3` and an extra value to a quaternion.-vector3_1ToQuaternion :: Vector3 -> Float -> Quaternion-{-# INLINE vector3_1ToQuaternion #-}-vector3_1ToQuaternion (Vector3 x y z) = quaternion x y z---- | Multiplies two quaternions together.-multiplyq :: Quaternion -> Quaternion -> Quaternion-multiplyq (Quaternion !x1 !y1 !z1 !w1)- (Quaternion !x2 !y2 !z2 !w2) = {-# SCC "multiplyq" #-}- Quaternion { qw = w1*w2 - x1*x2 - y1*y2 - z1*z2- , qx = w1*x2 + x1*w2 + y1*z2 - z1*y2- , qy = w1*y2 - x1*z2 + y1*w2 + z1*x2- , qz = w1*z2 + x1*y2 - y1*x2 + z1*w2 }--pad :: Int -> String -> String-pad wanted_len str- | len < wanted_len = str ++ replicate (wanted_len - len) ' '- | otherwise = str- where- len = length str---- | Returns a \"pretty\" string that represents a 4x4 matrix.------ This could be useful for debugging (and has been used as such in the--- development of Caramia). The default `Show` instance for `Matrix44` is--- machine-readable but annoying for humans to read. This function returns a--- somewhat more human-readable string that you can display.------ The string will contain newlines.-prettyShow :: Matrix44 -> String-prettyShow mat =- lines [[f11,f12,f13,f14],[f21,f22,f23,f24],- [f31,f32,f33,f34],[f41,f42,f43,f44]]- where- lines = concatMap ((++ "\n") . line)- line marks =- "[ " ++ concatMap ((" " ++) . pad wanted_len . show) marks ++ " ]"- wanted_len = 1 + maximum (map (length . show) $ toList4 mat)-- f11 = m11 mat- f21 = m21 mat- f31 = m31 mat- f41 = m41 mat- f12 = m12 mat- f22 = m22 mat- f32 = m32 mat- f42 = m42 mat- f13 = m13 mat- f23 = m23 mat- f33 = m33 mat- f43 = m43 mat- f14 = m14 mat- f24 = m24 mat- f34 = m34 mat- f44 = m44 mat-
src/Graphics/Caramia/Render.hs view
@@ -14,12 +14,13 @@ , DrawT() , Draw , drawR- , setPipeline- , setTextureBindings , setBlending- , setTargetFramebuffer , setFragmentPassTests+ , setPipeline , setPolygonOffset+ , setPrimitiveRestart+ , setTargetFramebuffer+ , setTextureBindings -- * Specifying what to draw , DrawCommand(..) , drawCommand@@ -149,6 +150,13 @@ -- -- By default this is (0, 0) (that is, do nothing). See @ glPolygonOffset @ -- for the meaning of these values.+ , primitiveRestart :: !(Maybe Word32)+ -- ^ Use primitive restart?+ --+ -- <https://www.opengl.org/wiki/Vertex_Rendering#Primitive_Restart>+ --+ -- Is this is `Nothing` (the default) then primitive restart will not be+ -- used. } deriving ( Eq, Ord, Typeable ) @@ -160,6 +168,8 @@ -- -- Blending mode is premultiplied alpha. --+-- No primitive restart is used.+-- -- `targetFramebuffer` is the screen framebuffer. defaultDrawParams :: DrawParams defaultDrawParams = DrawParams {@@ -168,7 +178,8 @@ , blending = preMultipliedAlpha , bindTextures = IM.empty , targetFramebuffer = FBuf.screenFramebuffer- , polygonOffset = (0, 0) }+ , polygonOffset = (0, 0)+ , primitiveRestart = Nothing } -- | Contains a specification of what to draw. --@@ -277,6 +288,7 @@ , boundBlending :: !BlendSpec , boundFramebuffer :: !FBuf.Framebuffer , boundFragmentPassTests :: !FragmentPassTests+ , boundPrimitiveRestart :: !(Maybe Word32) , activeTexture :: !GLuint } deriving ( Eq, Ord, Typeable ) @@ -322,6 +334,7 @@ , boundBlending = blending params , boundFramebuffer = targetFramebuffer params , boundTextures = bindTextures params+ , boundPrimitiveRestart = primitiveRestart params , activeTexture = 0 } st `seq` return result@@ -334,6 +347,7 @@ withBlendings blending $ withBoundTextures bindTextures $ withBoundElementBuffer 0 $+ withPrimitiveRestart primitiveRestart $ withPolygonOffset polygonOffset $ do old_active <- gi gl_ACTIVE_TEXTURE -- Framebuffer may not restore the viewport so we have to do it here.@@ -350,6 +364,22 @@ glActiveTexture old_active glViewport ox oy ow oh +withPrimitiveRestart :: (MonadIO m, MonadMask m) => Maybe Word32 -> m a -> m a+withPrimitiveRestart pr action = do+ old_primitive_restart_enabled <- liftIO $ glIsEnabled gl_PRIMITIVE_RESTART+ old_i <- gi gl_PRIMITIVE_RESTART_INDEX+ finally (activate >> action)+ (do if old_primitive_restart_enabled /= 0+ then glEnable gl_PRIMITIVE_RESTART+ else glDisable gl_PRIMITIVE_RESTART+ glPrimitiveRestartIndex old_i)+ where+ activate = case pr of+ Nothing -> glDisable gl_PRIMITIVE_RESTART+ Just value -> do+ glEnable gl_PRIMITIVE_RESTART+ glPrimitiveRestartIndex (fromIntegral value)+ withPolygonOffset :: (MonadIO m, MonadMask m) => (Float, Float) -> m a -> m a withPolygonOffset (factor, units) action = do old_factor <- gf gl_POLYGON_OFFSET_FACTOR@@ -366,6 +396,21 @@ when (activeTexture state /= unit) $ glActiveTexture (gl_TEXTURE0 + unit) >> modify (\old -> old { activeTexture = unit })++-- | Sets new primitive restart mode.+setPrimitiveRestart :: MonadIO m => Maybe Word32 -> DrawT m ()+setPrimitiveRestart restart = DrawT $ do+ pr <- return . boundPrimitiveRestart =<< get+ liftIO $ case (pr, restart) of+ (Nothing, Just x) -> do+ glEnable gl_PRIMITIVE_RESTART+ glPrimitiveRestartIndex (fromIntegral x)+ (Just _, Nothing) -> do+ glDisable gl_PRIMITIVE_RESTART+ (Just y, Just x) | y /= x ->+ glPrimitiveRestartIndex (fromIntegral x)+ _ -> return ()+ modify (\old -> old { boundPrimitiveRestart = restart }) -- | Sets new texture bindings. setTextureBindings :: MonadIO m => IM.IntMap Texture -> DrawT m ()
src/Graphics/Caramia/Shader.hs view
@@ -61,10 +61,15 @@ import Graphics.Caramia.Color import Graphics.Caramia.Context import Graphics.Caramia.Internal.OpenGLCApi-import Graphics.Caramia.Math import Graphics.Caramia.Resource import Graphics.Caramia.Prelude import Graphics.Caramia.Shader.Internal+import Linear.Matrix+import Linear.Quaternion+import Linear.V1+import Linear.V2+import Linear.V3+import Linear.V4 type UniformLocation = Int @@ -490,52 +495,155 @@ (cdouble2CFloat f3) (cdouble2CFloat f4) -instance Uniformable Vector3 where- setUniform_ program loc (toTuple3 -> tuple) =- setUniform_ program loc tuple+double2FloatMap :: Functor a => a Double -> a Float+double2FloatMap = fmap double2Float+{-# INLINE double2FloatMap #-} -instance Uniformable Quaternion where- setUniform_ program loc (toTupleq -> tuple) =- setUniform_ program loc tuple+double2FloatMapMap :: (Functor a, Functor b) => a (b Double) -> a (b Float)+double2FloatMapMap = fmap (fmap double2Float)+{-# INLINE double2FloatMapMap #-} -instance Uniformable Matrix33 where- setUniform_ program loc m33 =- withMatrix33Ptr m33 $- mglProgramUniformMatrix3fv program loc 1- (fromIntegral gl_FALSE)+cfloatToFloatMap :: Functor a => a CFloat -> a Float+cfloatToFloatMap = fmap unwrap where+ unwrap (CFloat x) = x+{-# INLINE cfloatToFloatMap #-} -instance Uniformable Matrix44 where+cfloatToFloatMapMap :: (Functor a, Functor b) => a (b CFloat) -> a (b Float)+cfloatToFloatMapMap = fmap (fmap unwrap) where+ unwrap (CFloat x) = x+{-# INLINE cfloatToFloatMapMap #-}++cdoubleToDoubleMap :: Functor a => a CDouble -> a Double+cdoubleToDoubleMap = fmap unwrap where+ unwrap (CDouble x) = x+{-# INLINE cdoubleToDoubleMap #-}++cdoubleToDoubleMapMap :: (Functor a, Functor b) => a (b CDouble) -> a (b Double)+cdoubleToDoubleMapMap = fmap (fmap unwrap) where+ unwrap (CDouble x) = x+{-# INLINE cdoubleToDoubleMapMap #-}++instance Uniformable (Quaternion Float) where+ setUniform_ program loc (Quaternion w (V3 x y z)) =+ mglProgramUniform4f program loc (CFloat x) (CFloat y) (CFloat z) (CFloat w)++instance Uniformable (Quaternion Double) where+ setUniform_ program loc (double2FloatMap -> Quaternion w (V3 x y z)) =+ mglProgramUniform4f program loc (CFloat x) (CFloat y) (CFloat z) (CFloat w)++instance Uniformable (Quaternion CFloat) where+ setUniform_ program loc (Quaternion w (V3 x y z)) =+ mglProgramUniform4f program loc x y z w++instance Uniformable (Quaternion CDouble) where+ setUniform_ program loc (cdoubleToDoubleMap -> q) =+ setUniform_ program loc q++instance Uniformable (V1 CFloat) where+ setUniform_ program loc (cfloatToFloatMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (V2 CFloat) where+ setUniform_ program loc (cfloatToFloatMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (V3 CFloat) where+ setUniform_ program loc (cfloatToFloatMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (V4 CFloat) where+ setUniform_ program loc (cfloatToFloatMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (V1 CDouble) where+ setUniform_ program loc (cdoubleToDoubleMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (V2 CDouble) where+ setUniform_ program loc (cdoubleToDoubleMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (V3 CDouble) where+ setUniform_ program loc (cdoubleToDoubleMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (V4 CDouble) where+ setUniform_ program loc (cdoubleToDoubleMap -> vec) =+ setUniform_ program loc vec++instance Uniformable (M33 CFloat) where+ setUniform_ program loc (cfloatToFloatMapMap -> m33) =+ setUniform_ program loc m33++instance Uniformable (M44 CFloat) where+ setUniform_ program loc (cfloatToFloatMapMap -> m44) =+ setUniform_ program loc m44++instance Uniformable (M33 CDouble) where+ setUniform_ program loc (cdoubleToDoubleMapMap -> m33) =+ setUniform_ program loc m33++instance Uniformable (M44 CDouble) where+ setUniform_ program loc (cdoubleToDoubleMapMap -> m44) =+ setUniform_ program loc m44++instance Uniformable (V1 Double) where+ setUniform_ program loc (double2FloatMap -> V1 f1) =+ mglProgramUniform1f program loc (CFloat f1)++instance Uniformable (V2 Double) where+ setUniform_ program loc (double2FloatMap -> V2 f1 f2) =+ mglProgramUniform2f program loc (CFloat f1) (CFloat f2)++instance Uniformable (V3 Double) where+ setUniform_ program loc (double2FloatMap -> V3 f1 f2 f3) =+ mglProgramUniform3f program loc (CFloat f1) (CFloat f2) (CFloat f3)++instance Uniformable (V4 Double) where+ setUniform_ program loc (double2FloatMap -> V4 f1 f2 f3 f4) =+ mglProgramUniform4f program loc (CFloat f1) (CFloat f2) (CFloat f3) (CFloat f4)++instance Uniformable (M33 Double) where+ setUniform_ program loc (double2FloatMapMap -> m33) =+ with m33 $+ mglProgramUniformMatrix3fv program loc 1 (fromIntegral gl_FALSE) . castPtr++instance Uniformable (M44 Double) where setUniform_ program loc m44 =- withMatrix44Ptr m44 $ mglProgramUniformMatrix4fv program loc 1- (fromIntegral gl_FALSE)+ with (fmap (fmap double2Float) m44) $+ mglProgramUniformMatrix4fv program loc 1 (fromIntegral gl_FALSE) . castPtr --- these are for RULES firing-newtype Transpose33 = Transpose33 Matrix33-newtype Transpose44 = Transpose44 Matrix44+instance Uniformable (V1 Float) where+ setUniform_ program loc (V1 f1) =+ mglProgramUniform1f program loc (CFloat f1) -instance Uniformable Transpose33 where- setUniform_ program loc (Transpose33 m33) =- withMatrix33Ptr m33 $- mglProgramUniformMatrix3fv program loc 1 (fromIntegral gl_TRUE)+instance Uniformable (V2 Float) where+ setUniform_ program loc (V2 f1 f2) =+ mglProgramUniform2f program loc (CFloat f1) (CFloat f2) -instance Uniformable Transpose44 where- setUniform_ program loc (Transpose44 m44) =- withMatrix44Ptr m44 $ mglProgramUniformMatrix4fv program loc 1- (fromIntegral gl_TRUE)+instance Uniformable (V3 Float) where+ setUniform_ program loc (V3 f1 f2 f3) =+ mglProgramUniform3f program loc (CFloat f1) (CFloat f2) (CFloat f3) +instance Uniformable (V4 Float) where+ setUniform_ program loc (V4 f1 f2 f3 f4) =+ mglProgramUniform4f program loc (CFloat f1) (CFloat f2) (CFloat f3) (CFloat f4)++instance Uniformable (M33 Float) where+ setUniform_ program loc m33 =+ with m33 $+ mglProgramUniformMatrix3fv program loc 1 (fromIntegral gl_FALSE) . castPtr++instance Uniformable (M44 Float) where+ setUniform_ program loc m44 =+ with m44 $+ mglProgramUniformMatrix4fv program loc 1 (fromIntegral gl_FALSE) . castPtr+ double2CFloat :: Double -> CFloat double2CFloat dbl = CFloat $ double2Float dbl cdouble2CFloat :: CDouble -> CFloat cdouble2CFloat (CDouble dbl) = CFloat $ double2Float dbl--{-# RULES "transpose/glProgramUniformMatrix3fv" forall (a :: Matrix33) b c.- setUniform (transpose33 a) b c =- setUniform (Transpose33 a) b c #-}--{-# RULES "transpose/glProgramUniformMatrix4fv" forall (a :: Matrix44) b c.- setUniform (transpose44 a) b c =- setUniform (Transpose44 a) b c #-} -- | Returns a uniform location for a given name. --