aboutsummaryrefslogtreecommitdiff
path: root/Graphics
diff options
context:
space:
mode:
Diffstat (limited to 'Graphics')
-rw-r--r--Graphics/Glyph/BufferBuilder.hs231
-rw-r--r--Graphics/Glyph/GLMath.hs400
-rw-r--r--Graphics/Glyph/GlyphObject.hs196
-rw-r--r--Graphics/Glyph/Mat4.hs552
-rw-r--r--Graphics/Glyph/Shaders.hs58
-rw-r--r--Graphics/Glyph/Textures.hs52
-rw-r--r--Graphics/Glyph/Util.hs116
7 files changed, 987 insertions, 618 deletions
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index 4800d3d..5704875 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -1,22 +1,22 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
module Graphics.Glyph.BufferBuilder where
import Control.Monad
-import Graphics.Rendering.OpenGL
-import Foreign.Storable
-import Foreign.Ptr
import Data.Array.Storable
-import Debug.Trace
import qualified Data.Foldable as Fold
import Data.Sequence as Seq
-
+import Debug.Trace
+import Foreign.Ptr
+import Foreign.Storable
import Graphics.Glyph.Mat4
import Graphics.Glyph.Util
-
+import Graphics.Rendering.OpenGL
import System.IO.Unsafe
-data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End
+data BufferBuilder3D = Plot BufferBuilder3D (GLfloat, GLfloat, GLfloat) Int Int | End
+
bufferSize :: BufferBuilder3D -> Int
bufferSize End = 0
bufferSize (Plot _ _ l _) = l
@@ -30,30 +30,33 @@ sizeofGLfloat = 4
{- A state monad that keeps track of operations
- and will compile them into a buffer -}
-data Builder b a = Builder {
- bList :: Seq (BuildDatum b),
- bReturn :: a
-} | BuildError String
-
-data BuildDatum b =
- VertexLink (b,b,b) |
- NormalLink (b,b,b) |
- ColorLink (b,b,b,b) |
- TextureLink (b,b) deriving Show
-
-data CompiledBuild b = CompiledBuild {
- bStride :: Int,
- bEnabled :: (Bool,Bool,Bool),
- nElems :: Int,
+data Builder b a
+ = Builder
+ { bList :: Seq (BuildDatum b),
+ bReturn :: a
+ }
+ | BuildError String
+
+data BuildDatum b
+ = VertexLink (b, b, b)
+ | NormalLink (b, b, b)
+ | ColorLink (b, b, b, b)
+ | TextureLink (b, b)
+ deriving (Show)
+
+data CompiledBuild b = CompiledBuild
+ { bStride :: Int,
+ bEnabled :: (Bool, Bool, Bool),
+ nElems :: Int,
array :: StorableArray Int b
-}
+ }
bufferLength :: (Integral a) => CompiledBuild b -> a
bufferLength = fromIntegral . nElems
instance Show (CompiledBuild x) where
- show (CompiledBuild stride enabled n _) =
- "[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++"]"
+ show (CompiledBuild stride enabled n _) =
+ "[CompiledBuild stride=" ++! stride ++ " enabled" ++! enabled ++ " n=" ++! n ++ "]"
instance Functor (Builder t) where
fmap f b = b >>= (return . f)
@@ -66,106 +69,134 @@ instance Applicative (Builder t) where
return (fn a)
instance Monad (Builder t) where
- (Builder lst1 _) >> (Builder lst2 ret) = Builder (lst2 >< lst1) ret
- BuildError str >> _ = BuildError str
- _ >> BuildError str = BuildError str
+ (Builder lst1 _) >> (Builder lst2 ret) = Builder (lst2 >< lst1) ret
+ BuildError str >> _ = BuildError str
+ _ >> BuildError str = BuildError str
- b1@(Builder _ ret1) >>= func = b1 >> func ret1
- BuildError str >>= _ = BuildError str
+ b1@(Builder _ ret1) >>= func = b1 >> func ret1
+ BuildError str >>= _ = BuildError str
- return = Builder empty
+ return = Builder empty
{- Add a vertex to the current builder -}
-bVertex3 :: (a,a,a) -> Builder a ()
+bVertex3 :: (a, a, a) -> Builder a ()
bVertex3 vert = Builder (Seq.singleton $ VertexLink vert) ()
-bTexture2 :: (a,a) -> Builder a ()
+bTexture2 :: (a, a) -> Builder a ()
bTexture2 tex = Builder (Seq.singleton $ TextureLink tex) ()
-bNormal3 :: (a,a,a) -> Builder a ()
+bNormal3 :: (a, a, a) -> Builder a ()
bNormal3 norm = Builder (Seq.singleton $ NormalLink norm) ()
-bColor4 :: (a,a,a,a) -> Builder a ()
+bColor4 :: (a, a, a, a) -> Builder a ()
bColor4 col = Builder (Seq.singleton $ ColorLink col) ()
compilingBuilder :: (Storable b, Num b, Show b) => Builder b x -> IO (CompiledBuild b)
compilingBuilder (Builder lst _) = do
- -- Size of the elements
- let sizeof = sizeOf $ tmp (Seq.index lst 0)
- where tmp (VertexLink (a,_,_)) = a
- tmp _ = 0
- {- Simply figure out what types of elementse
- - exist in this buffer -}
- let en@(bn,bc,bt) = Fold.foldl' (\(bn,bc,bt) ele ->
- case ele of
- NormalLink _ -> (True,bc,bt)
- ColorLink _ -> (bn,True,bt)
- TextureLink _ -> (bn,bc,True)
- VertexLink _ -> (bn,bc,bt)) (False,False,False) lst
- {- Calculate the stride; number of floats per element -}
- let stride = (3 + (?)bn * 3 + (?)bc * 4 + (?)bt * 2) * sizeof
- where (?) True = 1
- (?) False = 0
- -- Cur color normal texture buffer
- let (nverts,_,_,_,buffer) =
- Fold.foldl' (\(num,cn,cc,ct,ll) ele ->
- -- trace ("foldl " ++! ele) $
- case ele of
- NormalLink nn -> (num,nn,cc,ct,ll)
- ColorLink nc -> (num,cn,nc,ct,ll)
- TextureLink nt -> (num,cn,cc,nt,ll)
- VertexLink vert ->
- (num+1,cn,cc,ct,
- ll >< (tp3 True vert >< tp3 bn cn >< tp4 bc cc >< tp2 bt ct)
- )) ( 0, (0,0,0), (0,0,0,0), (0,0), Seq.empty ) (Seq.reverse lst)
-
- let blst = (Fold.toList buffer)
- arr <- blst `seq` newListArray (0,Seq.length buffer) blst
- let compiledRet = CompiledBuild stride en nverts arr
- compiledRet `seq` putStrLn ("Compiled: " ++! compiledRet ) `seq` return compiledRet
+ -- Size of the elements
+ let sizeof = sizeOf $ tmp (Seq.index lst 0)
+ where
+ tmp (VertexLink (a, _, _)) = a
+ tmp _ = 0
+ {- Simply figure out what types of elementse
+ - exist in this buffer -}
+ let en@(bn, bc, bt) =
+ Fold.foldl'
+ ( \(bn, bc, bt) ele ->
+ case ele of
+ NormalLink _ -> (True, bc, bt)
+ ColorLink _ -> (bn, True, bt)
+ TextureLink _ -> (bn, bc, True)
+ VertexLink _ -> (bn, bc, bt)
+ )
+ (False, False, False)
+ lst
+ {- Calculate the stride; number of floats per element -}
+ let stride = (3 + (?) bn * 3 + (?) bc * 4 + (?) bt * 2) * sizeof
+ where
+ (?) True = 1
+ (?) False = 0
+ -- Cur color normal texture buffer
+ let (nverts, _, _, _, buffer) =
+ Fold.foldl'
+ ( \(num, cn, cc, ct, ll) ele ->
+ -- trace ("foldl " ++! ele) $
+ case ele of
+ NormalLink nn -> (num, nn, cc, ct, ll)
+ ColorLink nc -> (num, cn, nc, ct, ll)
+ TextureLink nt -> (num, cn, cc, nt, ll)
+ VertexLink vert ->
+ ( num + 1,
+ cn,
+ cc,
+ ct,
+ ll >< (tp3 True vert >< tp3 bn cn >< tp4 bc cc >< tp2 bt ct)
+ )
+ )
+ (0, (0, 0, 0), (0, 0, 0, 0), (0, 0), Seq.empty)
+ (Seq.reverse lst)
+
+ let blst = (Fold.toList buffer)
+ arr <- blst `seq` newListArray (0, Seq.length buffer) blst
+ let compiledRet = CompiledBuild stride en nverts arr
+ compiledRet `seq` putStrLn ("Compiled: " ++! compiledRet) `seq` return compiledRet
where
- tp2 True (a,b) = Seq.fromList [a,b]
- tp2 False _ = empty
-
- tp3 True (a,b,c) = Seq.fromList [a,b,c]
- tp3 False _ = empty
-
- tp4 True (a,b,c,d) = Seq.fromList [a,b,c,d]
- tp4 False _ = empty
+ tp2 True (a, b) = Seq.fromList [a, b]
+ tp2 False _ = empty
+
+ tp3 True (a, b, c) = Seq.fromList [a, b, c]
+ tp3 False _ = empty
+
+ tp4 True (a, b, c, d) = Seq.fromList [a, b, c, d]
+ tp4 False _ = empty
storableArrayToBuffer :: (Storable el) => BufferTarget -> StorableArray Int el -> IO BufferObject
storableArrayToBuffer target arr = do
- let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
- [buffer] <- genObjectNames 1
- bindBuffer target $= Just buffer
- len <- getBounds arr >>= (\(a,b) -> return $ (b - a) * sizeof )
- withStorableArray arr $ \ptr ->
- bufferData target $= (fromIntegral len, ptr, StaticDraw)
- return buffer
+ let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
+ [buffer] <- genObjectNames 1
+ bindBuffer target $= Just buffer
+ len <- getBounds arr >>= (\(a, b) -> return $ (b - a) * sizeof)
+ withStorableArray arr $ \ptr ->
+ bufferData target $= (fromIntegral len, ptr, StaticDraw)
+ return buffer
vertexArrayDescriptor :: CompiledBuild GLfloat -> VertexArrayDescriptor GLfloat
vertexArrayDescriptor (CompiledBuild stride _ _ _) = VertexArrayDescriptor 3 Float (fromIntegral stride) (wordPtrToPtr 0)
normalArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-normalArrayDescriptor (CompiledBuild stride (True,_,_) _ _) =
- Just $ VertexArrayDescriptor 3 Float
- (fromIntegral stride) (wordPtrToPtr (3*4))
-normalArrayDescriptor _ = Nothing
+normalArrayDescriptor (CompiledBuild stride (True, _, _) _ _) =
+ Just $
+ VertexArrayDescriptor
+ 3
+ Float
+ (fromIntegral stride)
+ (wordPtrToPtr (3 * 4))
+normalArrayDescriptor _ = Nothing
colorArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-colorArrayDescriptor (CompiledBuild stride tup@(_,True,_) _ _) =
- Just $ VertexArrayDescriptor 4 Float
- (fromIntegral stride) (wordPtrToPtr (offset tup))
- where offset (b1,_,_) = if b1 then (6*4) else (3*4)
-
-colorArrayDescriptor _ = Nothing
+colorArrayDescriptor (CompiledBuild stride tup@(_, True, _) _ _) =
+ Just $
+ VertexArrayDescriptor
+ 4
+ Float
+ (fromIntegral stride)
+ (wordPtrToPtr (offset tup))
+ where
+ offset (b1, _, _) = if b1 then (6 * 4) else (3 * 4)
+colorArrayDescriptor _ = Nothing
textureArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-textureArrayDescriptor (CompiledBuild stride tup@(_,_,True) _ _) =
- Just $ VertexArrayDescriptor 2 Float
- (fromIntegral stride) (wordPtrToPtr (offset tup))
- where offset (b1,b2,_) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
- ifp b x = if b then x else 0
-textureArrayDescriptor _ = Nothing
+textureArrayDescriptor (CompiledBuild stride tup@(_, _, True) _ _) =
+ Just $
+ VertexArrayDescriptor
+ 2
+ Float
+ (fromIntegral stride)
+ (wordPtrToPtr (offset tup))
+ where
+ offset (b1, b2, _) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
+ ifp b x = if b then x else 0
+textureArrayDescriptor _ = Nothing
+
createBufferObject :: BufferTarget -> CompiledBuild GLfloat -> IO BufferObject
createBufferObject target (CompiledBuild _ _ _ arr) = storableArrayToBuffer target arr
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
index bec796c..7cd4471 100644
--- a/Graphics/Glyph/GLMath.hs
+++ b/Graphics/Glyph/GLMath.hs
@@ -1,145 +1,259 @@
{-# LANGUAGE MultiParamTypeClasses #-}
+
module Graphics.Glyph.GLMath where
- import Graphics.Glyph.Mat4
- import qualified Graphics.Rendering.OpenGL as GL
- import Graphics.Rendering.OpenGL (GLfloat,Uniform,Vertex3(..),uniform,UniformComponent)
- import Data.Angle
- import Debug.Trace
-
- data Vec2 a = Vec2 (a,a) deriving Show
- data Vec3 a = Vec3 (a,a,a) deriving Show
- data Vec4 a = Vec4 (a,a,a,a) deriving Show
-
- instance UniformComponent a => Uniform (Vec3 a) where
- uniform loc = GL.makeStateVar
- (do
- (Vertex3 x y z) <-
- GL.get (uniform loc)
- return (Vec3 (x,y,z)) )
- (\(Vec3 (x,y,z)) -> uniform loc GL.$= Vertex3 x y z)
-
- class (Floating flT) => Vector flT b where
- (<+>) :: b flT -> b flT -> b flT
- (<->) :: b flT -> b flT -> b flT
- norm :: b flT -> flT
- normalize :: b flT -> b flT
- vDot :: b flT -> b flT -> flT
- vScale :: flT -> b flT -> b flT
-
-
- (<.>) :: (Vector a b) => b a -> b a -> a
- (<.>) = vDot
-
- (|||) :: (Vector a b) => b a -> a
- (|||) = norm
-
- instance (Floating flT) => Vector flT Vec2 where
- (<+>) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a+c,b+d)
- (<->) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a-c,b-d)
- vDot (Vec2 (a,b)) (Vec2 (c,d)) = a * c + b * d
- vScale c (Vec2 (a,b)) = Vec2 (a*c,b*c)
- norm (Vec2 (a,b)) = sqrt (a*a + b*b)
- normalize vec@(Vec2 (a,b)) =
- let n = norm vec in Vec2 (a/n,b/n)
-
- instance (Floating flT) => Vector flT Vec3 where
- (<+>) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a+d,b+e,c+f)
- (<->) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a-d,b-e,c-f)
- vDot (Vec3 (a,b,c)) (Vec3 (d,e,f)) = a * d + b * e + c * f
- vScale x (Vec3 (a,b,c)) = Vec3 (a*x,b*x,c*x)
- norm (Vec3 (a,b,c)) = sqrt (a*a + b*b + c*c)
- normalize vec@(Vec3 (a,b,c)) =
- let n = norm vec in Vec3 (a/n,b/n,c/n)
-
- instance (Floating flT) => Vector flT Vec4 where
- (<+>) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a+d,b+e,c+f,g+h)
- (<->) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a-d,b-e,c-f,g-h)
- vDot (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = a * d + b * e + c * f + g * h
- vScale x (Vec4 (a,b,c,d)) = Vec4 (a*x,b*x,c*x,d*x)
- norm (Vec4 (a,b,c,d)) = sqrt (a*a + b*b + c*c + d*d)
- normalize vec@(Vec4 (a,b,c,d)) =
- let n = norm vec in Vec4 (a/n,b/n,c/n,d/n)
-
- cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
- cross (Vec3 (u1,u2,u3)) (Vec3 (v1,v2,v3)) =
- Vec3 ( u2*v3 - u3*v2,
- u3*v1 - u1*v3,
- u1*v2 - u2*v1 )
- (×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
- (×) = cross
-
- lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
- lookAtMatrix e@(Vec3 (ex,ey,ez)) c u =
- let f@(Vec3 (fx,fy,fz)) = normalize (c <-> e)
- s@(Vec3 (sx,sy,sz)) = normalize (f × u)
- u'@(Vec3 (ux,uy,uz)) = s × f in
- Matrix (sx, ux, -fx, 0,
- sy, uy, -fy, 0,
- sz, uz, -fz, 0,
- -(s<.>e) , -(u'<.>e), (f<.>e), 1 )
-
- perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
- {- as close to copied from glm as possible -}
- perspectiveMatrix fov asp zn zf =
- let tanHalfFovy = tangent (Degrees fov/2)
- res00 = 1 / (asp * tanHalfFovy)
- res11 = 1 / tanHalfFovy
- res22 = - (zf + zn) / (zf - zn)
- res23 = - 1
- res32 = - (2 * zf * zn) / (zf - zn) in
- trace ("res22=" ++ (show res22)) $
- Matrix (res00, 0, 0, 0,
- 0, res11, 0, 0,
- 0, 0, res22, res23,
- 0, 0, res32, 0)
-
- class VectorMatrix vecT matT where
- vTranslate :: matT -> vecT -> matT
- (-*|) :: matT -> vecT -> vecT
-
- instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
- vTranslate (Matrix3 (a00,a01,a02,
- a10,a11,a12,
- a20,a21,a22)) (Vec3 (a,b,c)) =
- Matrix3 (a00,a01,a02+a,
- a10,a11,a12+b,
- a20,a21,a22+c)
-
- (Matrix3 (a00,a01,a02,
- a10,a11,a12,
- a20,a21,a22)) -*| (Vec3 (a,b,c)) =
- Vec3 (a00 * a + a01 * b + a02 * c,
- a10 * a + a11 * b + a12 * c,
- a20 * a + a21 * b + a22 * c )
-
-
-
-
- instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
- vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
- mat -*| tmp = glslMatMul mat tmp
-
- glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
- glslMatMul (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) (Vec4 (v0,v1,v2,v3)) =
- Vec4 ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
- v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
- v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
- v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33 )
-
- (==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
- (==>) = glslMatTranslate
- glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
- glslMatTranslate
- mat@(Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) vec =
- let (Vec4 (v0,v1,v2,v3)) = mat -*| vec in
- (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30+v0,m31+v1,m32+v2,m33+v3))
-
+
+import Data.Angle
+import Debug.Trace
+import Graphics.Glyph.Mat4
+import Graphics.Rendering.OpenGL (GLfloat, Uniform, UniformComponent, Vertex3 (..), uniform)
+import qualified Graphics.Rendering.OpenGL as GL
+
+data Vec2 a = Vec2 (a, a) deriving (Show)
+
+data Vec3 a = Vec3 (a, a, a) deriving (Show)
+
+data Vec4 a = Vec4 (a, a, a, a) deriving (Show)
+
+instance UniformComponent a => Uniform (Vec3 a) where
+ uniform loc =
+ GL.makeStateVar
+ ( do
+ (Vertex3 x y z) <-
+ GL.get (uniform loc)
+ return (Vec3 (x, y, z))
+ )
+ (\(Vec3 (x, y, z)) -> uniform loc GL.$= Vertex3 x y z)
+
+class (Floating flT) => Vector flT b where
+ (<+>) :: b flT -> b flT -> b flT
+ (<->) :: b flT -> b flT -> b flT
+ norm :: b flT -> flT
+ normalize :: b flT -> b flT
+ vDot :: b flT -> b flT -> flT
+ vScale :: flT -> b flT -> b flT
+
+(<.>) :: (Vector a b) => b a -> b a -> a
+(<.>) = vDot
+
+(|||) :: (Vector a b) => b a -> a
+(|||) = norm
+
+instance (Floating flT) => Vector flT Vec2 where
+ (<+>) (Vec2 (a, b)) (Vec2 (c, d)) = Vec2 (a + c, b + d)
+ (<->) (Vec2 (a, b)) (Vec2 (c, d)) = Vec2 (a - c, b - d)
+ vDot (Vec2 (a, b)) (Vec2 (c, d)) = a * c + b * d
+ vScale c (Vec2 (a, b)) = Vec2 (a * c, b * c)
+ norm (Vec2 (a, b)) = sqrt (a * a + b * b)
+ normalize vec@(Vec2 (a, b)) =
+ let n = norm vec in Vec2 (a / n, b / n)
+
+instance (Floating flT) => Vector flT Vec3 where
+ (<+>) (Vec3 (a, b, c)) (Vec3 (d, e, f)) = Vec3 (a + d, b + e, c + f)
+ (<->) (Vec3 (a, b, c)) (Vec3 (d, e, f)) = Vec3 (a - d, b - e, c - f)
+ vDot (Vec3 (a, b, c)) (Vec3 (d, e, f)) = a * d + b * e + c * f
+ vScale x (Vec3 (a, b, c)) = Vec3 (a * x, b * x, c * x)
+ norm (Vec3 (a, b, c)) = sqrt (a * a + b * b + c * c)
+ normalize vec@(Vec3 (a, b, c)) =
+ let n = norm vec in Vec3 (a / n, b / n, c / n)
+
+instance (Floating flT) => Vector flT Vec4 where
+ (<+>) (Vec4 (a, b, c, g)) (Vec4 (d, e, f, h)) = Vec4 (a + d, b + e, c + f, g + h)
+ (<->) (Vec4 (a, b, c, g)) (Vec4 (d, e, f, h)) = Vec4 (a - d, b - e, c - f, g - h)
+ vDot (Vec4 (a, b, c, g)) (Vec4 (d, e, f, h)) = a * d + b * e + c * f + g * h
+ vScale x (Vec4 (a, b, c, d)) = Vec4 (a * x, b * x, c * x, d * x)
+ norm (Vec4 (a, b, c, d)) = sqrt (a * a + b * b + c * c + d * d)
+ normalize vec@(Vec4 (a, b, c, d)) =
+ let n = norm vec in Vec4 (a / n, b / n, c / n, d / n)
+
+cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+cross (Vec3 (u1, u2, u3)) (Vec3 (v1, v2, v3)) =
+ Vec3
+ ( u2 * v3 - u3 * v2,
+ u3 * v1 - u1 * v3,
+ u1 * v2 - u2 * v1
+ )
+
+(×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+(×) = cross
+
+lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
+lookAtMatrix e@(Vec3 (ex, ey, ez)) c u =
+ let f@(Vec3 (fx, fy, fz)) = normalize (c <-> e)
+ s@(Vec3 (sx, sy, sz)) = normalize (f × u)
+ u'@(Vec3 (ux, uy, uz)) = s × f
+ in Matrix
+ ( sx,
+ ux,
+ - fx,
+ 0,
+ sy,
+ uy,
+ - fy,
+ 0,
+ sz,
+ uz,
+ - fz,
+ 0,
+ - (s <.> e),
+ - (u' <.> e),
+ (f <.> e),
+ 1
+ )
+
+perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
+{- as close to copied from glm as possible -}
+perspectiveMatrix fov asp zn zf =
+ let tanHalfFovy = tangent (Degrees fov / 2)
+ res00 = 1 / (asp * tanHalfFovy)
+ res11 = 1 / tanHalfFovy
+ res22 = - (zf + zn) / (zf - zn)
+ res23 = - 1
+ res32 = - (2 * zf * zn) / (zf - zn)
+ in trace ("res22=" ++ (show res22)) $
+ Matrix
+ ( res00,
+ 0,
+ 0,
+ 0,
+ 0,
+ res11,
+ 0,
+ 0,
+ 0,
+ 0,
+ res22,
+ res23,
+ 0,
+ 0,
+ res32,
+ 0
+ )
+
+class VectorMatrix vecT matT where
+ vTranslate :: matT -> vecT -> matT
+ (-*|) :: matT -> vecT -> vecT
+
+instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
+ vTranslate
+ ( Matrix3
+ ( a00,
+ a01,
+ a02,
+ a10,
+ a11,
+ a12,
+ a20,
+ a21,
+ a22
+ )
+ )
+ (Vec3 (a, b, c)) =
+ Matrix3
+ ( a00,
+ a01,
+ a02 + a,
+ a10,
+ a11,
+ a12 + b,
+ a20,
+ a21,
+ a22 + c
+ )
+
+ ( Matrix3
+ ( a00,
+ a01,
+ a02,
+ a10,
+ a11,
+ a12,
+ a20,
+ a21,
+ a22
+ )
+ )
+ -*| (Vec3 (a, b, c)) =
+ Vec3
+ ( a00 * a + a01 * b + a02 * c,
+ a10 * a + a11 * b + a12 * c,
+ a20 * a + a21 * b + a22 * c
+ )
+
+instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
+ vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
+ mat -*| tmp = glslMatMul mat tmp
+
+glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
+glslMatMul
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ (Vec4 (v0, v1, v2, v3)) =
+ Vec4
+ ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
+ v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
+ v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
+ v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33
+ )
+
+(==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+(==>) = glslMatTranslate
+
+glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+glslMatTranslate
+ mat@( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ vec =
+ let (Vec4 (v0, v1, v2, v3)) = mat -*| vec
+ in ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30 + v0,
+ m31 + v1,
+ m32 + v2,
+ m33 + v3
+ )
+ )
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
index 239007d..ef83cd8 100644
--- a/Graphics/Glyph/GlyphObject.hs
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -1,12 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
-module Graphics.Glyph.GlyphObject (
- GlyphObject(..),
+module Graphics.Glyph.GlyphObject
+ ( GlyphObject (..),
getBufferObject,
getCompiledData,
getVertexAttribute,
getNormalAttribute,
- getColorAttribute ,
+ getColorAttribute,
getTextureAttribute,
getResources,
getSetupRoutine,
@@ -16,41 +16,44 @@ module Graphics.Glyph.GlyphObject (
setCompiledData,
setVertexAttribute,
setNormalAttribute,
- setColorAttribute ,
+ setColorAttribute,
setTextureAttribute,
setResources,
setSetupRoutine,
setTeardownRoutine,
setPrimitiveMode,
- prepare, teardown,
- Drawable, draw, newGlyphObject,
- newDefaultGlyphObject
-) where
+ prepare,
+ teardown,
+ Drawable,
+ draw,
+ newGlyphObject,
+ newDefaultGlyphObject,
+ )
+where
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL
-import Control.Monad
-import Control.Applicative
-import Data.Maybe
-
class Drawable a where
- -- mvMat -> pMat -> obj -> IO ()
- draw :: a -> IO ()
+ -- mvMat -> pMat -> obj -> IO ()
+ draw :: a -> IO ()
-data GlyphObject a = GlyphObject {
- bufferObject :: BufferObject, -- buffer
+data GlyphObject a = GlyphObject
+ { bufferObject :: BufferObject, -- buffer
compiledData :: (CompiledBuild GLfloat), -- compiled data
vertexAttribute :: AttribLocation, -- vertex attribute
normalAttribute :: (Maybe AttribLocation), -- normal attrib
- colorAttribute :: (Maybe AttribLocation), -- color attrib
+ colorAttribute :: (Maybe AttribLocation), -- color attrib
textureAttribute :: (Maybe AttribLocation), -- texture attrib
resources :: a, -- Resources
setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
primitiveMode :: PrimitiveMode
-}
+ }
getBufferObject :: GlyphObject a -> BufferObject
getBufferObject = bufferObject
@@ -64,8 +67,8 @@ getVertexAttribute = vertexAttribute
getNormalAttribute :: GlyphObject a -> (Maybe AttribLocation)
getNormalAttribute = normalAttribute
-getColorAttribute :: GlyphObject a -> (Maybe AttribLocation)
-getColorAttribute = colorAttribute
+getColorAttribute :: GlyphObject a -> (Maybe AttribLocation)
+getColorAttribute = colorAttribute
getTextureAttribute :: GlyphObject a -> (Maybe AttribLocation)
getTextureAttribute = textureAttribute
@@ -83,104 +86,109 @@ getPrimitiveMode :: GlyphObject a -> PrimitiveMode
getPrimitiveMode = primitiveMode
setBufferObject :: GlyphObject a -> BufferObject -> GlyphObject a
-setBufferObject o a = o { bufferObject = a }
+setBufferObject o a = o {bufferObject = a}
setCompiledData :: GlyphObject a -> (CompiledBuild GLfloat) -> GlyphObject a
-setCompiledData o a = o { compiledData = a }
+setCompiledData o a = o {compiledData = a}
setVertexAttribute :: GlyphObject a -> AttribLocation -> GlyphObject a
-setVertexAttribute o a = o { vertexAttribute = a }
+setVertexAttribute o a = o {vertexAttribute = a}
setNormalAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setNormalAttribute o a = o { normalAttribute = a }
+setNormalAttribute o a = o {normalAttribute = a}
-setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setColorAttribute o a = o { colorAttribute = a }
+setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
+setColorAttribute o a = o {colorAttribute = a}
setTextureAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setTextureAttribute o a = o { textureAttribute = a }
+setTextureAttribute o a = o {textureAttribute = a}
setResources :: GlyphObject a -> a -> GlyphObject a
-setResources o a = o { resources = a }
+setResources o a = o {resources = a}
setSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
-setSetupRoutine o a = o { setupRoutine = a }
+setSetupRoutine o a = o {setupRoutine = a}
setTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
-setTeardownRoutine o a = o { teardownRoutine = a }
+setTeardownRoutine o a = o {teardownRoutine = a}
setPrimitiveMode :: GlyphObject a -> PrimitiveMode -> GlyphObject a
-setPrimitiveMode o a = o { primitiveMode = a }
-
-newGlyphObject :: Builder GLfloat x ->
- AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- a ->
- Maybe (GlyphObject a -> IO ()) ->
- Maybe (GlyphObject a -> IO ()) ->
- PrimitiveMode ->
- IO (GlyphObject a)
-
+setPrimitiveMode o a = o {primitiveMode = a}
+
+newGlyphObject ::
+ Builder GLfloat x ->
+ AttribLocation ->
+ Maybe AttribLocation ->
+ Maybe AttribLocation ->
+ Maybe AttribLocation ->
+ a ->
+ Maybe (GlyphObject a -> IO ()) ->
+ Maybe (GlyphObject a -> IO ()) ->
+ PrimitiveMode ->
+ IO (GlyphObject a)
newGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear mode = do
- compiled <- compilingBuilder builder
- buffer <- createBufferObject ArrayBuffer compiled
- return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup tear mode
+ compiled <- compilingBuilder builder
+ buffer <- createBufferObject ArrayBuffer compiled
+ return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup tear mode
-prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-prepare a b = a { setupRoutine = (Just b) }
+prepare :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
+prepare a b = a {setupRoutine = (Just b)}
-teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-teardown a b = a { teardownRoutine = Just b }
+teardown :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
+teardown a b = a {teardownRoutine = Just b}
instance Drawable (GlyphObject a) where
- draw obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown p) = do
- {- Setup whatever we need for the object to draw itself -}
- maybe (return ()) (apply obj) setup
-
- {- Get the array descriptors for the possible
- - parts -}
- let vad = vertexArrayDescriptor co
- let nad = normalArrayDescriptor co
- let cad = colorArrayDescriptor co
- let tad = textureArrayDescriptor co
-
- bindBuffer ArrayBuffer $= Just bo
- let enabled = catMaybes $
- map liftMaybe [(Just vAttr,Just vad), (nAttr, nad), (cAttr,cad), (tAttr,tad)]
-
- forM_ enabled $ \(attr, ad) -> do
- vertexAttribPointer attr $= (ToFloat, ad)
- vertexAttribArray attr $= Enabled
-
- drawArrays p 0 (bufferLength co)
-
- forM_ enabled $ \(attr, _) -> do
- vertexAttribArray attr $= Disabled
-
- {- Tear down whatever the object needs -}
- maybe (return ()) (apply obj) tearDown
- where liftMaybe (Just a, Just b) = Just (a,b)
- liftMaybe _ = Nothing
- apply obj' f = f obj'
+ draw obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown p) = do
+ {- Setup whatever we need for the object to draw itself -}
+ maybe (return ()) (apply obj) setup
+
+ {- Get the array descriptors for the possible
+ - parts -}
+ let vad = vertexArrayDescriptor co
+ let nad = normalArrayDescriptor co
+ let cad = colorArrayDescriptor co
+ let tad = textureArrayDescriptor co
+
+ bindBuffer ArrayBuffer $= Just bo
+ let enabled =
+ catMaybes $
+ map liftMaybe [(Just vAttr, Just vad), (nAttr, nad), (cAttr, cad), (tAttr, tad)]
+
+ forM_ enabled $ \(attr, ad) -> do
+ vertexAttribPointer attr $= (ToFloat, ad)
+ vertexAttribArray attr $= Enabled
+
+ drawArrays p 0 (bufferLength co)
+
+ forM_ enabled $ \(attr, _) -> do
+ vertexAttribArray attr $= Disabled
+
+ {- Tear down whatever the object needs -}
+ maybe (return ()) (apply obj) tearDown
+ where
+ liftMaybe (Just a, Just b) = Just (a, b)
+ liftMaybe _ = Nothing
+ apply obj' f = f obj'
instance (Show a) => Show (GlyphObject a) where
- show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ p) =
- "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++
- " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++"]"
-
+ show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ p) =
+ "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr
+ ++ " normalAttr=" ++! nAttr
+ ++ " colorAttr=" ++! cAttr
+ ++ " textureAttr=" ++! tAttr
+ ++ " res=" ++! res
+ ++ " PrimitiveMode=" ++! p
+ ++ "]"
newDefaultGlyphObject :: Builder GLfloat x -> a -> IO (GlyphObject a)
newDefaultGlyphObject builder resources =
- newGlyphObject builder
- (AttribLocation 0) -- vertex
- (Just $ AttribLocation 1) -- normal
- (Just $ AttribLocation 2) -- color
- (Just $ AttribLocation 3) -- texture
- resources
- Nothing -- setup
- Nothing -- teardown
- Triangles -- primitive
-
-
+ newGlyphObject
+ builder
+ (AttribLocation 0) -- vertex
+ (Just $ AttribLocation 1) -- normal
+ (Just $ AttribLocation 2) -- color
+ (Just $ AttribLocation 3) -- texture
+ resources
+ Nothing -- setup
+ Nothing -- teardown
+ Triangles -- primitive
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
index 6581126..9ef922f 100644
--- a/Graphics/Glyph/Mat4.hs
+++ b/Graphics/Glyph/Mat4.hs
@@ -1,224 +1,430 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
module Graphics.Glyph.Mat4 where
import Control.Monad
-
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
-
-import Graphics.Rendering.OpenGL
import Graphics.GL.Compatibility30
--- import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.Rendering.OpenGL
-data Mat4 a = Matrix (a,a,a,a,
- a,a,a,a,
- a,a,a,a,
- a,a,a,a) | IdentityMatrix
+-- import Graphics.Rendering.OpenGL.Raw.Core31
-data Mat3 a = Matrix3 ( a,a,a,
- a,a,a,
- a,a,a ) | IdentityMatrix3
+data Mat4 a
+ = Matrix
+ ( a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a
+ )
+ | IdentityMatrix
+
+data Mat3 a
+ = Matrix3
+ ( a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a
+ )
+ | IdentityMatrix3
class StorableMatrix t a where
- fromList :: [t] -> a t
- toPtr :: a t -> (Ptr t -> IO b) -> IO b
- fromPtr :: Ptr t -> (a t -> IO b) -> IO b
+ fromList :: [t] -> a t
+ toPtr :: a t -> (Ptr t -> IO b) -> IO b
+ fromPtr :: Ptr t -> (a t -> IO b) -> IO b
instance (Storable t) => StorableMatrix t Mat4 where
- fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:m10:m11:m12:m13:m14:m15:m16:_) =
- Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)
+ fromList (m1 : m2 : m3 : m4 : m5 : m6 : m7 : m8 : m9 : m10 : m11 : m12 : m13 : m14 : m15 : m16 : _) =
+ Matrix (m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14, m15, m16)
- toPtr (Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)) fun =
- allocaArray 16 $ \ptr -> do
- pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16]
- fun ptr
+ toPtr (Matrix (m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14, m15, m16)) fun =
+ allocaArray 16 $ \ptr -> do
+ pokeArray ptr [m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14, m15, m16]
+ fun ptr
- fromPtr ptr f = peekArray 16 ptr >>= f . fromList
+ fromPtr ptr f = peekArray 16 ptr >>= f . fromList
instance (Storable t) => StorableMatrix t Mat3 where
- fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:_) =
- Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)
+ fromList (m1 : m2 : m3 : m4 : m5 : m6 : m7 : m8 : m9 : _) =
+ Matrix3 (m1, m2, m3, m4, m5, m6, m7, m8, m9)
- toPtr (Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)) fun =
- allocaArray 9 $ \ptr -> do
- pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9]
- fun ptr
+ toPtr (Matrix3 (m1, m2, m3, m4, m5, m6, m7, m8, m9)) fun =
+ allocaArray 9 $ \ptr -> do
+ pokeArray ptr [m1, m2, m3, m4, m5, m6, m7, m8, m9]
+ fun ptr
- fromPtr ptr f = peekArray 9 ptr >>= f . fromList
+ fromPtr ptr f = peekArray 9 ptr >>= f . fromList
instance Uniform (Mat4 GLfloat) where
- uniform (UniformLocation loc) = makeStateVar getter setter
- where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix4fv loc 1 (fromIntegral GL_FALSE) ptr
- getter :: IO (Mat4 GLfloat)
- getter = do
- pid <- liftM fromIntegral getCurrentProgram
- ( allocaArray 16 $ \buf -> do
- glGetUniformfv pid loc buf
- fromPtr buf return )
+ uniform (UniformLocation loc) = makeStateVar getter setter
+ where
+ setter mat = toPtr mat $ \ptr ->
+ glUniformMatrix4fv loc 1 (fromIntegral GL_FALSE) ptr
+ getter :: IO (Mat4 GLfloat)
+ getter = do
+ pid <- liftM fromIntegral getCurrentProgram
+ ( allocaArray 16 $ \buf -> do
+ glGetUniformfv pid loc buf
+ fromPtr buf return
+ )
instance Uniform (Mat3 GLfloat) where
- uniform (UniformLocation loc) = makeStateVar getter setter
- where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix3fv loc 1 (fromIntegral GL_FALSE) ptr
- getter :: IO (Mat3 GLfloat)
- getter = do
- pid <- liftM fromIntegral getCurrentProgram
- ( allocaArray 9 $ \buf -> do
- glGetUniformfv pid loc buf
- fromPtr buf return )
+ uniform (UniformLocation loc) = makeStateVar getter setter
+ where
+ setter mat = toPtr mat $ \ptr ->
+ glUniformMatrix3fv loc 1 (fromIntegral GL_FALSE) ptr
+ getter :: IO (Mat3 GLfloat)
+ getter = do
+ pid <- liftM fromIntegral getCurrentProgram
+ ( allocaArray 9 $ \buf -> do
+ glGetUniformfv pid loc buf
+ fromPtr buf return
+ )
getCurrentProgram :: IO GLint
getCurrentProgram = alloca $ \ptr -> glGetIntegerv GL_CURRENT_PROGRAM ptr >> peek ptr
instance (Show a) => Show (Mat4 a) where
- show IdentityMatrix =
- "[ 1 0 0 0\n" ++
- " 0 1 0 0\n" ++
- " 0 0 1 0\n" ++
- " 0 0 0 1 ]\n"
- show (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) =
- "["++! m00 ++ " " ++! m01 ++ " " ++! m02 ++ " " ++! m03 ++ "\n" ++
- " "++! m10 ++ " " ++! m11 ++ " " ++! m12 ++ " " ++! m13 ++ "\n" ++
- " "++! m20 ++ " " ++! m21 ++ " " ++! m22 ++ " " ++! m23 ++ "\n" ++
- " "++! m30 ++ " " ++! m31 ++ " " ++! m32 ++ " " ++! m33 ++ "]"
- where (++!) a = (a++) . show
-
-
-
-
-translateMat4 :: (Num a) => Mat4 a -> (a,a,a,a) -> Mat4 a
-translateMat4 IdentityMatrix x = translateMat4 (Matrix (1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1)) x
-translateMat4 (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) (v0,v1,v2,v3) =
- Matrix (m00,m01,m02,m03+v0,
- m10,m11,m12,m13+v1,
- m20,m21,m22,m23+v2,
- m30,m31,m32,m33+v3)
-
-applyMatrix :: (Num a) => Mat4 a -> (a,a,a,a) -> (a,a,a,a)
-applyMatrix (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) (v0,v1,v2,v3) =
- ( v0 * m00 + v1 * m01 + v2 * m02 + v3 * m03,
- v0 * m10 + v1 * m11 + v2 * m12 + v3 * m13,
- v0 * m20 + v1 * m21 + v2 * m22 + v3 * m23,
- v0 * m30 + v1 * m31 + v2 * m32 + v3 * m33 )
-
+ show IdentityMatrix =
+ "[ 1 0 0 0\n"
+ ++ " 0 1 0 0\n"
+ ++ " 0 0 1 0\n"
+ ++ " 0 0 0 1 ]\n"
+ show (Matrix (m00, m01, m02, m03, m10, m11, m12, m13, m20, m21, m22, m23, m30, m31, m32, m33)) =
+ "[" ++! m00 ++ " " ++! m01 ++ " " ++! m02 ++ " " ++! m03 ++ "\n"
+ ++ " " ++! m10
+ ++ " " ++! m11
+ ++ " " ++! m12
+ ++ " " ++! m13
+ ++ "\n"
+ ++ " " ++! m20
+ ++ " " ++! m21
+ ++ " " ++! m22
+ ++ " " ++! m23
+ ++ "\n"
+ ++ " " ++! m30
+ ++ " " ++! m31
+ ++ " " ++! m32
+ ++ " " ++! m33
+ ++ "]"
+ where
+ (++!) a = (a ++) . show
+
+translateMat4 :: (Num a) => Mat4 a -> (a, a, a, a) -> Mat4 a
+translateMat4 IdentityMatrix x = translateMat4 (Matrix (1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1)) x
+translateMat4
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ (v0, v1, v2, v3) =
+ Matrix
+ ( m00,
+ m01,
+ m02,
+ m03 + v0,
+ m10,
+ m11,
+ m12,
+ m13 + v1,
+ m20,
+ m21,
+ m22,
+ m23 + v2,
+ m30,
+ m31,
+ m32,
+ m33 + v3
+ )
+
+applyMatrix :: (Num a) => Mat4 a -> (a, a, a, a) -> (a, a, a, a)
+applyMatrix
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ (v0, v1, v2, v3) =
+ ( v0 * m00 + v1 * m01 + v2 * m02 + v3 * m03,
+ v0 * m10 + v1 * m11 + v2 * m12 + v3 * m13,
+ v0 * m20 + v1 * m21 + v2 * m22 + v3 * m23,
+ v0 * m30 + v1 * m31 + v2 * m32 + v3 * m33
+ )
applyMatrix IdentityMatrix v = v
-scaleMatrix :: (Num a) => Mat4 a -> (a,a,a) -> Mat4 a
-scaleMatrix IdentityMatrix (a,b,c) = Matrix ( a,0,0,0,
- 0,b,0,0,
- 0,0,c,0,
- 0,0,0,1)
-
-scaleMatrix (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) (a,b,c)
- = Matrix ( m00*a,m01,m02,m03,
- m10,m11*b,m12,m13,
- m20,m21,m22*c,m23,
- m30,m31,m32,m33)
+scaleMatrix :: (Num a) => Mat4 a -> (a, a, a) -> Mat4 a
+scaleMatrix IdentityMatrix (a, b, c) =
+ Matrix
+ ( a,
+ 0,
+ 0,
+ 0,
+ 0,
+ b,
+ 0,
+ 0,
+ 0,
+ 0,
+ c,
+ 0,
+ 0,
+ 0,
+ 0,
+ 1
+ )
+scaleMatrix (Matrix (m00, m01, m02, m03, m10, m11, m12, m13, m20, m21, m22, m23, m30, m31, m32, m33)) (a, b, c) =
+ Matrix
+ ( m00 * a,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11 * b,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22 * c,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
applyMatrixToList :: (Num a) => Mat4 a -> [a] -> [a]
applyMatrixToList IdentityMatrix t = t
-applyMatrixToList mat (a:b:c:xs) =
- let (a',b',c',_) = applyMatrix mat (a,b,c,1) in
- (a':b':c':applyMatrixToList mat xs)
-
+applyMatrixToList mat (a : b : c : xs) =
+ let (a', b', c', _) = applyMatrix mat (a, b, c, 1)
+ in (a' : b' : c' : applyMatrixToList mat xs)
applyMatrixToList _ _ = []
mulMatrix4 :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
mulMatrix4 IdentityMatrix a = a
mulMatrix4 a IdentityMatrix = a
mulMatrix4
- (Matrix (a00,a01,a02,a03,
- a10,a11,a12,a13,
- a20,a21,a22,a23,
- a30,a31,a32,a33 ))
- (Matrix (b00,b01,b02,b03,
- b10,b11,b12,b13,
- b20,b21,b22,b23,
- b30,b31,b32,b33 )) =
- Matrix (b00*a00+b10*a01+b20*a02+b30*a03,
- b01*a00+b11*a01+b21*a02+b31*a03,
- b02*a00+b12*a01+b22*a02+b32*a03,
- b03*a00+b13*a01+b23*a02+b33*a03,
-
- b00*a10+b10*a11+b20*a12+b30*a13,
- b01*a10+b11*a11+b21*a12+b31*a13,
- b02*a10+b12*a11+b22*a12+b32*a13,
- b03*a10+b13*a11+b23*a12+b33*a13,
-
- b00*a20+b10*a21+b20*a22+b30*a23,
- b01*a20+b11*a21+b21*a22+b31*a23,
- b02*a20+b12*a21+b22*a22+b32*a23,
- b03*a20+b13*a21+b23*a22+b33*a23,
-
- b00*a30+b10*a31+b20*a32+b30*a33,
- b01*a30+b11*a31+b21*a32+b31*a33,
- b02*a30+b12*a31+b22*a32+b32*a33,
- b03*a30+b13*a31+b23*a32+b33*a33 )
+ ( Matrix
+ ( a00,
+ a01,
+ a02,
+ a03,
+ a10,
+ a11,
+ a12,
+ a13,
+ a20,
+ a21,
+ a22,
+ a23,
+ a30,
+ a31,
+ a32,
+ a33
+ )
+ )
+ ( Matrix
+ ( b00,
+ b01,
+ b02,
+ b03,
+ b10,
+ b11,
+ b12,
+ b13,
+ b20,
+ b21,
+ b22,
+ b23,
+ b30,
+ b31,
+ b32,
+ b33
+ )
+ ) =
+ Matrix
+ ( b00 * a00 + b10 * a01 + b20 * a02 + b30 * a03,
+ b01 * a00 + b11 * a01 + b21 * a02 + b31 * a03,
+ b02 * a00 + b12 * a01 + b22 * a02 + b32 * a03,
+ b03 * a00 + b13 * a01 + b23 * a02 + b33 * a03,
+ b00 * a10 + b10 * a11 + b20 * a12 + b30 * a13,
+ b01 * a10 + b11 * a11 + b21 * a12 + b31 * a13,
+ b02 * a10 + b12 * a11 + b22 * a12 + b32 * a13,
+ b03 * a10 + b13 * a11 + b23 * a12 + b33 * a13,
+ b00 * a20 + b10 * a21 + b20 * a22 + b30 * a23,
+ b01 * a20 + b11 * a21 + b21 * a22 + b31 * a23,
+ b02 * a20 + b12 * a21 + b22 * a22 + b32 * a23,
+ b03 * a20 + b13 * a21 + b23 * a22 + b33 * a23,
+ b00 * a30 + b10 * a31 + b20 * a32 + b30 * a33,
+ b01 * a30 + b11 * a31 + b21 * a32 + b31 * a33,
+ b02 * a30 + b12 * a31 + b22 * a32 + b32 * a33,
+ b03 * a30 + b13 * a31 + b23 * a32 + b33 * a33
+ )
(|*|) :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
(|*|) = mulMatrix4
transpose4 :: Mat4 a -> Mat4 a
-transpose4 (Matrix
- (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33 )) = (Matrix (m00, m10, m20, m30,
- m01, m11, m21, m31,
- m02, m12, m22, m32,
- m03, m13, m23, m33))
+transpose4
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ ) =
+ ( Matrix
+ ( m00,
+ m10,
+ m20,
+ m30,
+ m01,
+ m11,
+ m21,
+ m31,
+ m02,
+ m12,
+ m22,
+ m32,
+ m03,
+ m13,
+ m23,
+ m33
+ )
+ )
+
scale4 :: (Num a) => a -> Mat4 a -> Mat4 a
-scale4 n (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- Matrix (m11*n,m12*n,m13*n,m14*n,m21*n,m22*n,m23*n,m24*n,m31*n,m32*n,m33*n,m34*n,m41*n,m42*n,m43*n,m44*n)
+scale4 n (Matrix (m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, m41, m42, m43, m44)) =
+ Matrix (m11 * n, m12 * n, m13 * n, m14 * n, m21 * n, m22 * n, m23 * n, m24 * n, m31 * n, m32 * n, m33 * n, m34 * n, m41 * n, m42 * n, m43 * n, m44 * n)
det4 :: (Num a) => Mat4 a -> a
-det4 (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- m11*m22*m33*m44 + m11*m23*m34*m42 + m11*m24*m32*m43
- + m12*m21*m34*m43 + m12*m23*m31*m44 + m12*m24*m33*m41
- + m13*m21*m32*m44 + m13*m22*m34*m41 + m13*m24*m31*m42
- + m14*m21*m33*m42 + m14*m22*m31*m43 + m14*m23*m32*m41
- - m11*m22*m34*m43 - m11*m23*m32*m44 - m11*m24*m33*m42
- - m12*m21*m33*m44 - m12*m23*m34*m41 - m12*m24*m31*m43
- - m13*m21*m34*m42 - m13*m22*m31*m44 - m13*m24*m32*m41
- - m14*m21*m32*m43 - m14*m22*m33*m41 - m14*m23*m31*m42
-
-inv4 :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat4 a)
-inv4 mat@(Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- let b11 = m22*m33*m44 + m23*m34*m42 + m24*m32*m43 - m22*m34*m43 - m23*m32*m44 - m24*m33*m42
- b12 = m12*m34*m43 + m13*m32*m44 + m14*m33*m42 - m12*m33*m44 - m13*m34*m42 - m14*m32*m43
- b13 = m12*m23*m44 + m13*m24*m42 + m14*m22*m43 - m12*m24*m43 - m13*m22*m44 - m14*m23*m42
- b14 = m12*m24*m33 + m13*m22*m34 + m14*m23*m32 - m12*m23*m34 - m13*m24*m32 - m14*m22*m33
- b21 = m21*m34*m43 + m23*m31*m44 + m24*m33*m41 - m21*m33*m44 - m23*m34*m41 - m24*m31*m43
- b22 = m11*m33*m44 + m13*m34*m41 + m14*m31*m43 - m11*m34*m43 - m13*m31*m44 - m14*m33*m41
- b23 = m11*m24*m43 + m13*m21*m44 + m14*m23*m41 - m11*m23*m44 - m13*m24*m41 - m14*m21*m43
- b24 = m11*m23*m34 + m13*m24*m31 + m14*m21*m33 - m11*m24*m33 - m13*m21*m34 - m14*m23*m31
- b31 = m21*m32*m44 + m22*m34*m41 + m24*m31*m42 - m21*m34*m42 - m22*m31*m44 - m24*m32*m41
- b32 = m11*m34*m42 + m12*m31*m44 + m14*m32*m41 - m11*m32*m44 - m12*m34*m41 - m14*m31*m42
- b33 = m11*m22*m44 + m12*m24*m41 + m14*m21*m42 - m11*m24*m42 - m12*m21*m44 - m14*m22*m41
- b34 = m11*m24*m32 + m12*m21*m34 + m14*m22*m31 - m11*m22*m34 - m12*m24*m31 - m14*m21*m32
- b41 = m21*m33*m42 + m22*m31*m43 + m23*m32*m41 - m21*m32*m43 - m22*m33*m41 - m23*m31*m42
- b42 = m11*m32*m43 + m12*m33*m41 + m13*m31*m42 - m11*m33*m42 - m12*m31*m43 - m13*m32*m41
- b43 = m11*m23*m42 + m12*m21*m43 + m13*m22*m41 - m11*m22*m43 - m12*m23*m41 - m13*m21*m42
- b44 = m11*m22*m33 + m12*m23*m31 + m13*m21*m32 - m11*m23*m32 - m12*m21*m33 - m13*m22*m31 in
- case det4 mat of
- 0 -> Nothing
- det -> Just $ (1 / det) `scale4` Matrix (b11,b12,b13,b14,b21,b22,b23,b24,b31,b32,b33,b34,b41,b42,b43,b44)
+det4 (Matrix (m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, m41, m42, m43, m44)) =
+ m11 * m22 * m33 * m44 + m11 * m23 * m34 * m42 + m11 * m24 * m32 * m43
+ + m12 * m21 * m34 * m43
+ + m12 * m23 * m31 * m44
+ + m12 * m24 * m33 * m41
+ + m13 * m21 * m32 * m44
+ + m13 * m22 * m34 * m41
+ + m13 * m24 * m31 * m42
+ + m14 * m21 * m33 * m42
+ + m14 * m22 * m31 * m43
+ + m14 * m23 * m32 * m41
+ - m11 * m22 * m34 * m43
+ - m11 * m23 * m32 * m44
+ - m11 * m24 * m33 * m42
+ - m12 * m21 * m33 * m44
+ - m12 * m23 * m34 * m41
+ - m12 * m24 * m31 * m43
+ - m13 * m21 * m34 * m42
+ - m13 * m22 * m31 * m44
+ - m13 * m24 * m32 * m41
+ - m14 * m21 * m32 * m43
+ - m14 * m22 * m33 * m41
+ - m14 * m23 * m31 * m42
+
+inv4 :: (Floating a, Eq a) => Mat4 a -> Maybe (Mat4 a)
+inv4 mat@(Matrix (m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, m41, m42, m43, m44)) =
+ let b11 = m22 * m33 * m44 + m23 * m34 * m42 + m24 * m32 * m43 - m22 * m34 * m43 - m23 * m32 * m44 - m24 * m33 * m42
+ b12 = m12 * m34 * m43 + m13 * m32 * m44 + m14 * m33 * m42 - m12 * m33 * m44 - m13 * m34 * m42 - m14 * m32 * m43
+ b13 = m12 * m23 * m44 + m13 * m24 * m42 + m14 * m22 * m43 - m12 * m24 * m43 - m13 * m22 * m44 - m14 * m23 * m42
+ b14 = m12 * m24 * m33 + m13 * m22 * m34 + m14 * m23 * m32 - m12 * m23 * m34 - m13 * m24 * m32 - m14 * m22 * m33
+ b21 = m21 * m34 * m43 + m23 * m31 * m44 + m24 * m33 * m41 - m21 * m33 * m44 - m23 * m34 * m41 - m24 * m31 * m43
+ b22 = m11 * m33 * m44 + m13 * m34 * m41 + m14 * m31 * m43 - m11 * m34 * m43 - m13 * m31 * m44 - m14 * m33 * m41
+ b23 = m11 * m24 * m43 + m13 * m21 * m44 + m14 * m23 * m41 - m11 * m23 * m44 - m13 * m24 * m41 - m14 * m21 * m43
+ b24 = m11 * m23 * m34 + m13 * m24 * m31 + m14 * m21 * m33 - m11 * m24 * m33 - m13 * m21 * m34 - m14 * m23 * m31
+ b31 = m21 * m32 * m44 + m22 * m34 * m41 + m24 * m31 * m42 - m21 * m34 * m42 - m22 * m31 * m44 - m24 * m32 * m41
+ b32 = m11 * m34 * m42 + m12 * m31 * m44 + m14 * m32 * m41 - m11 * m32 * m44 - m12 * m34 * m41 - m14 * m31 * m42
+ b33 = m11 * m22 * m44 + m12 * m24 * m41 + m14 * m21 * m42 - m11 * m24 * m42 - m12 * m21 * m44 - m14 * m22 * m41
+ b34 = m11 * m24 * m32 + m12 * m21 * m34 + m14 * m22 * m31 - m11 * m22 * m34 - m12 * m24 * m31 - m14 * m21 * m32
+ b41 = m21 * m33 * m42 + m22 * m31 * m43 + m23 * m32 * m41 - m21 * m32 * m43 - m22 * m33 * m41 - m23 * m31 * m42
+ b42 = m11 * m32 * m43 + m12 * m33 * m41 + m13 * m31 * m42 - m11 * m33 * m42 - m12 * m31 * m43 - m13 * m32 * m41
+ b43 = m11 * m23 * m42 + m12 * m21 * m43 + m13 * m22 * m41 - m11 * m22 * m43 - m12 * m23 * m41 - m13 * m21 * m42
+ b44 = m11 * m22 * m33 + m12 * m23 * m31 + m13 * m21 * m32 - m11 * m23 * m32 - m12 * m21 * m33 - m13 * m22 * m31
+ in case det4 mat of
+ 0 -> Nothing
+ det -> Just $ (1 / det) `scale4` Matrix (b11, b12, b13, b14, b21, b22, b23, b24, b31, b32, b33, b34, b41, b42, b43, b44)
trunc4 :: Mat4 a -> Mat3 a
-trunc4 (Matrix
- (m11,m12,m13,_,
- m21,m22,m23,_,
- m31,m32,m33,_,
- _ , _ , _ ,_)) = Matrix3 (m11,m12,m13,m21,m22,m23,m31,m32,m33)
-
-toNormalMatrix :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat3 a)
+trunc4
+ ( Matrix
+ ( m11,
+ m12,
+ m13,
+ _,
+ m21,
+ m22,
+ m23,
+ _,
+ m31,
+ m32,
+ m33,
+ _,
+ _,
+ _,
+ _,
+ _
+ )
+ ) = Matrix3 (m11, m12, m13, m21, m22, m23, m31, m32, m33)
+
+toNormalMatrix :: (Floating a, Eq a) => Mat4 a -> Maybe (Mat3 a)
toNormalMatrix mat = inv4 mat >>= return . trunc4 . transpose4
diff --git a/Graphics/Glyph/Shaders.hs b/Graphics/Glyph/Shaders.hs
index 9a85e1a..9041f52 100644
--- a/Graphics/Glyph/Shaders.hs
+++ b/Graphics/Glyph/Shaders.hs
@@ -1,57 +1,61 @@
module Graphics.Glyph.Shaders where
-import Graphics.Rendering.OpenGL
-import qualified Data.ByteString as BS
import Control.Monad
+import qualified Data.ByteString as BS
import Data.Maybe
+import Graphics.Rendering.OpenGL
loadShader :: ShaderType -> FilePath -> IO (String, Maybe Shader)
loadShader typ path = do
- shader <- createShader typ
- ( shaderSourceBS shader $= ) =<< BS.readFile path
- compileShader shader
-
- ok <- get (compileStatus shader)
- infoLog <- get (shaderInfoLog shader)
+ shader <- createShader typ
+ (shaderSourceBS shader $=) =<< BS.readFile path
+ compileShader shader
- unless ok $
- deleteObjectNames [shader]
+ ok <- get (compileStatus shader)
+ infoLog <- get (shaderInfoLog shader)
- return ( infoLog, if not ok then Nothing else Just shader );
+ unless ok $
+ deleteObjectNames [shader]
+ return (infoLog, if not ok then Nothing else Just shader)
-loadShaders :: [(ShaderType,FilePath)] -> IO [(String, Maybe Shader)]
-loadShaders = mapM ( uncurry loadShader )
+loadShaders :: [(ShaderType, FilePath)] -> IO [(String, Maybe Shader)]
+loadShaders = mapM (uncurry loadShader)
workingShaders :: [(a, Maybe Shader)] -> [Shader]
workingShaders lst = map (fromJust . snd) (filter (isJust . snd) lst)
createShaderProgram :: [Shader] -> IO (String, Maybe Program)
createShaderProgram shaders = do
- p <- createProgram
- mapM_ (attachShader p) shaders
- linkProgram p
+ p <- createProgram
+ mapM_ (attachShader p) shaders
+ linkProgram p
- ok <- get $ linkStatus p
- info <- get $ programInfoLog p
+ ok <- get $ linkStatus p
+ info <- get $ programInfoLog p
- unless ok $
- deleteObjectNames [p]
+ unless ok $
+ deleteObjectNames [p]
- return ( info, if not ok then Nothing else Just p )
+ return (info, if not ok then Nothing else Just p)
getUniform :: Uniform a => String -> IO (Maybe (StateVar a))
getUniform name =
- get currentProgram >>= (\pr -> case pr of
+ get currentProgram
+ >>= ( \pr -> case pr of
Just p -> liftM (Just . uniform) (get $ uniformLocation p name)
- Nothing -> return Nothing )
+ Nothing -> return Nothing
+ )
getUniformForProgram :: Uniform a => String -> Program -> IO (StateVar a)
getUniformForProgram name prog =
- liftM uniform (get $ uniformLocation prog name)
-
+ liftM uniform (get $ uniformLocation prog name)
getUniformLocation :: String -> IO (Maybe UniformLocation)
getUniformLocation name =
- get currentProgram >>= maybe (return Nothing) (\prog ->
- liftM Just (get $ uniformLocation prog name) )
+ get currentProgram
+ >>= maybe
+ (return Nothing)
+ ( \prog ->
+ liftM Just (get $ uniformLocation prog name)
+ )
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
index 55b18fc..538c87a 100644
--- a/Graphics/Glyph/Textures.hs
+++ b/Graphics/Glyph/Textures.hs
@@ -1,39 +1,45 @@
module Graphics.Glyph.Textures where
+import Control.Monad
import Data.Array.Storable
import Data.Word
-
-import Graphics.Rendering.OpenGL
-import Control.Monad
import Graphics.GL.Compatibility30
+import Graphics.Rendering.OpenGL
-data Pixels =
- PixelsRGB (Int,Int) (StorableArray Int Word8) |
- PixelsRGBA (Int,Int) (StorableArray Int Word8)
+data Pixels
+ = PixelsRGB (Int, Int) (StorableArray Int Word8)
+ | PixelsRGBA (Int, Int) (StorableArray Int Word8)
pixelsArray :: Pixels -> StorableArray Int Word8
-pixelsArray (PixelsRGB _ a) = a
+pixelsArray (PixelsRGB _ a) = a
pixelsArray (PixelsRGBA _ a) = a
+
-- construct a new 2d array of pixels
makePixelsRGB :: (Int, Int) -> IO Pixels
-makePixelsRGB a@(w,h) = liftM (PixelsRGB a) (newArray_ (0,w*h-1))
+makePixelsRGB a@(w, h) = liftM (PixelsRGB a) (newArray_ (0, w * h -1))
-- convert a list of rgb values to an array
-newPixelsFromListRGB :: (Int, Int) -> [(Word8,Word8,Word8)] -> IO Pixels
-newPixelsFromListRGB a@(w,h) lst = liftM (PixelsRGB a) $ (newListArray (0,w*h*3) .
- concatMap (\(x,y,z)->[x,y,z])) lst
-
-newPixelsFromListRGBA :: (Int, Int) -> [(Word8,Word8,Word8,Word8)] -> IO Pixels
-newPixelsFromListRGBA a@(w,h) lst = liftM (PixelsRGBA a) $ newListArray (0,w*h*4)
- (concatMap (\(x,y,z,q)->[x,y,z,q]) lst)
+newPixelsFromListRGB :: (Int, Int) -> [(Word8, Word8, Word8)] -> IO Pixels
+newPixelsFromListRGB a@(w, h) lst =
+ liftM (PixelsRGB a) $
+ ( newListArray (0, w * h * 3)
+ . concatMap (\(x, y, z) -> [x, y, z])
+ )
+ lst
+
+newPixelsFromListRGBA :: (Int, Int) -> [(Word8, Word8, Word8, Word8)] -> IO Pixels
+newPixelsFromListRGBA a@(w, h) lst =
+ liftM (PixelsRGBA a) $
+ newListArray
+ (0, w * h * 4)
+ (concatMap (\(x, y, z, q) -> [x, y, z, q]) lst)
attachPixelsToTexture :: Pixels -> TextureObject -> IO ()
attachPixelsToTexture pixels tex =
- withStorableArray (pixelsArray pixels) $ \ptr -> do
- textureBinding Texture2D $= Just tex
- case pixels of
- PixelsRGB (w,h) _ -> glTexImage2D GL_TEXTURE_2D 0 3 (f w) (f h) 0 GL_RGB GL_UNSIGNED_BYTE ptr
- PixelsRGBA (w,h) _ -> glTexImage2D GL_TEXTURE_2D 0 4 (f w) (f h) 0 GL_RGBA GL_UNSIGNED_BYTE ptr
- where f = fromIntegral
-
-
+ withStorableArray (pixelsArray pixels) $ \ptr -> do
+ textureBinding Texture2D $= Just tex
+ case pixels of
+ PixelsRGB (w, h) _ -> glTexImage2D GL_TEXTURE_2D 0 3 (f w) (f h) 0 GL_RGB GL_UNSIGNED_BYTE ptr
+ PixelsRGBA (w, h) _ -> glTexImage2D GL_TEXTURE_2D 0 4 (f w) (f h) 0 GL_RGBA GL_UNSIGNED_BYTE ptr
+ where
+ f = fromIntegral
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
index d657aa3..a2257f6 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -4,22 +4,22 @@ import Data.Angle
import Graphics.Rendering.OpenGL
int :: (Integral a, Num b) => a -> b
-int = fromIntegral
+int = fromIntegral
-uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a,b,c,d,e,f,g) -> h
-uncurry7 func (a,b,c,d,e,f,g) = func a b c d e f g
+uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a, b, c, d, e, f, g) -> h
+uncurry7 func (a, b, c, d, e, f, g) = func a b c d e f g
-uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a,b,c,d,e,f) -> g
-uncurry6 func (a,b,c,d,e,f) = func a b c d e f
+uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
+uncurry6 func (a, b, c, d, e, f) = func a b c d e f
-uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
-uncurry5 func (a,b,c,d,e) = func a b c d e
+uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f
+uncurry5 func (a, b, c, d, e) = func a b c d e
-uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
-uncurry4 func (a,b,c,d) = func a b c d
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 func (a, b, c, d) = func a b c d
-uncurry3 :: (a -> b -> c -> e) -> (a,b,c) -> e
-uncurry3 func (a,b,c) = func a b c
+uncurry3 :: (a -> b -> c -> e) -> (a, b, c) -> e
+uncurry3 func (a, b, c) = func a b c
gsin :: (Floating a) => a -> a
gsin = sine . Degrees
@@ -28,73 +28,73 @@ gcos :: (Floating a) => a -> a
gcos = cosine . Degrees
toEuclidian :: (Floating a) => (a, a, a) -> (a, a, a)
-toEuclidian (r, th, ph) = (
- -r * gsin th * gcos ph,
- r * gsin ph,
- r * gcos th * gcos ph
- )
+toEuclidian (r, th, ph) =
+ ( - r * gsin th * gcos ph,
+ r * gsin ph,
+ r * gcos th * gcos ph
+ )
-mapT2 :: (a -> b) -> (a,a) -> (b,b)
+mapT2 :: (a -> b) -> (a, a) -> (b, b)
mapT2 f (a, b) = (f a, f b)
-mapT3 :: (a -> b) -> (a,a,a) -> (b,b,b)
+mapT3 :: (a -> b) -> (a, a, a) -> (b, b, b)
mapT3 f (a, b, c) = (f a, f b, f c)
-mapT4 :: (a -> b) -> (a,a,a,a) -> (b,b,b,b)
+mapT4 :: (a -> b) -> (a, a, a, a) -> (b, b, b, b)
mapT4 f (a, b, c, d) = (f a, f b, f c, f d)
-mapT5 :: (a -> b) -> (a,a,a,a,a) -> (b,b,b,b,b)
+mapT5 :: (a -> b) -> (a, a, a, a, a) -> (b, b, b, b, b)
mapT5 f (a, b, c, d, e) = (f a, f b, f c, f d, f e)
-mapT6 :: (a -> b) -> (a,a,a,a,a,a) -> (b,b,b,b,b,b)
+mapT6 :: (a -> b) -> (a, a, a, a, a, a) -> (b, b, b, b, b, b)
mapT6 f (a, b, c, d, e, _f) = (f a, f b, f c, f d, f e, f _f)
-mapT7 :: (a -> b) -> (a,a,a,a,a,a,a) -> (b,b,b,b,b,b,b)
+mapT7 :: (a -> b) -> (a, a, a, a, a, a, a) -> (b, b, b, b, b, b, b)
mapT7 f (a, b, c, d, e, _f, g) = (f a, f b, f c, f d, f e, f _f, f g)
-foldT2 :: (a -> b -> a) -> a -> (b,b) -> a
-foldT2 f ini (x,y) = ini `f` x `f` y
+foldT2 :: (a -> b -> a) -> a -> (b, b) -> a
+foldT2 f ini (x, y) = ini `f` x `f` y
-foldT3 :: (a -> b -> a) -> a -> (b,b,b) -> a
-foldT3 f ini (x,y,z) = ini `f` x `f` y `f` z
+foldT3 :: (a -> b -> a) -> a -> (b, b, b) -> a
+foldT3 f ini (x, y, z) = ini `f` x `f` y `f` z
-foldT4 :: (a -> b -> a) -> a -> (b,b,b,b) -> a
-foldT4 f ini (x,y,z,w) = ini `f` x `f` y `f` z `f` w
+foldT4 :: (a -> b -> a) -> a -> (b, b, b, b) -> a
+foldT4 f ini (x, y, z, w) = ini `f` x `f` y `f` z `f` w
-foldT5 :: (a -> b -> a) -> a -> (b,b,b,b,b) -> a
-foldT5 f ini (x,y,z,w,v) = ini `f` x `f` y `f` z `f` w `f` v
+foldT5 :: (a -> b -> a) -> a -> (b, b, b, b, b) -> a
+foldT5 f ini (x, y, z, w, v) = ini `f` x `f` y `f` z `f` w `f` v
-tup2Len :: (Real a,Floating b) => (a,a) -> b
-tup2Len = sqrt . foldT2 (+) 0 . mapT2 ((**2).toFloating)
+tup2Len :: (Real a, Floating b) => (a, a) -> b
+tup2Len = sqrt . foldT2 (+) 0 . mapT2 ((** 2) . toFloating)
-tup3Len :: (Real a,Floating b) => (a,a,a) -> b
-tup3Len = sqrt . foldT3 (+) 0 . mapT3 ((**2).toFloating)
+tup3Len :: (Real a, Floating b) => (a, a, a) -> b
+tup3Len = sqrt . foldT3 (+) 0 . mapT3 ((** 2) . toFloating)
-tup4Len :: (Real a,Floating b) => (a,a,a,a) -> b
-tup4Len = sqrt . foldT4 (+) 0 . mapT4 ((**2).toFloating)
+tup4Len :: (Real a, Floating b) => (a, a, a, a) -> b
+tup4Len = sqrt . foldT4 (+) 0 . mapT4 ((** 2) . toFloating)
-tup5Len :: (Real a,Floating b) => (a,a,a,a,a) -> b
-tup5Len = sqrt . foldT5 (+) 0 . mapT5 ((**2).toFloating)
+tup5Len :: (Real a, Floating b) => (a, a, a, a, a) -> b
+tup5Len = sqrt . foldT5 (+) 0 . mapT5 ((** 2) . toFloating)
-expand3 :: a -> (a,a,a)
-expand3 t = (t,t,t)
+expand3 :: a -> (a, a, a)
+expand3 t = (t, t, t)
-expand4 :: a -> (a,a,a,a)
-expand4 t = (t,t,t,t)
+expand4 :: a -> (a, a, a, a)
+expand4 t = (t, t, t, t)
-expand5 :: a -> (a,a,a,a,a)
-expand5 t = (t,t,t,t,t)
+expand5 :: a -> (a, a, a, a, a)
+expand5 t = (t, t, t, t, t)
-expand6 :: a -> (a,a,a,a,a)
-expand6 t = (t,t,t,t,t)
+expand6 :: a -> (a, a, a, a, a)
+expand6 t = (t, t, t, t, t)
-zipWithT2 :: (a -> b -> c) -> (a,a) -> (b,b) -> (c,c)
+zipWithT2 :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipWithT2 fu (a, b) (d, e) = (fu a d, fu b e)
-zipWithT3 :: (a -> b -> c) -> (a,a,a) -> (b,b,b) -> (c,c,c)
+zipWithT3 :: (a -> b -> c) -> (a, a, a) -> (b, b, b) -> (c, c, c)
zipWithT3 fu (a, b, c) (d, e, f) = (fu a d, fu b e, fu c f)
-zipWithT4 :: (a -> b -> c) -> (a,a,a,a) -> (b,b,b,b) -> (c,c,c,c)
+zipWithT4 :: (a -> b -> c) -> (a, a, a, a) -> (b, b, b, b) -> (c, c, c, c)
zipWithT4 fu (a, b, c, d) (e, f, g, h) = (fu a e, fu b f, fu c g, fu d h)
toFloating :: (Real a, Floating b) => a -> b
@@ -104,25 +104,25 @@ toFloating = fromRational . toRational
(!!%) lst idx = lst !! (idx `mod` length lst)
(++!) :: (Show a) => String -> a -> String
-(++!) str = (str++) . show
+(++!) str = (str ++) . show
-clamp :: (Ord a) => a -> (a, a) -> a
+clamp :: (Ord a) => a -> (a, a) -> a
clamp var (low, high) = min (max var low) high
-floatVertex :: (GLfloat,GLfloat,GLfloat) -> Vertex3 GLdouble
+floatVertex :: (GLfloat, GLfloat, GLfloat) -> Vertex3 GLdouble
floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup)
-floatVector :: (GLfloat,GLfloat,GLfloat) -> Vector3 GLdouble
+floatVector :: (GLfloat, GLfloat, GLfloat) -> Vector3 GLdouble
floatVector tup = uncurry3 Vector3 (mapT3 toFloating tup)
-- Maps a function across a list, except this function
-- can also be given a state variable like how foldl
-- works
-mapWith :: (s -> a -> (b,s)) -> s -> [a] -> ([b], s)
-mapWith func state (x:xs) =
- let (x',s') = func state x in
- let (l,s) = mapWith func s' xs in (x':l, s)
+mapWith :: (s -> a -> (b, s)) -> s -> [a] -> ([b], s)
+mapWith func state (x : xs) =
+ let (x', s') = func state x
+ in let (l, s) = mapWith func s' xs in (x' : l, s)
+mapWith _ s [] = ([], s)
-mapWith _ s [] = ([],s)
(>&>) :: (Monad m) => (a -> m b) -> (a -> m c) -> a -> m c
(>&>) f1 f2 a = f1 a >> f2 a
generated by cgit (git 2.34.1) at 2025-04-28 16:37:11 +0000