aboutsummaryrefslogtreecommitdiff
path: root/Graphics/Glyph/Mat4.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Graphics/Glyph/Mat4.hs')
-rw-r--r--Graphics/Glyph/Mat4.hs223
1 files changed, 223 insertions, 0 deletions
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
new file mode 100644
index 0000000..546baa2
--- /dev/null
+++ b/Graphics/Glyph/Mat4.hs
@@ -0,0 +1,223 @@
+{-# 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.Rendering.OpenGL.Raw.Core31
+
+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
+
+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)
+
+ 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
+
+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)
+
+ 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
+
+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 )
+
+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 )
+
+getCurrentProgram :: IO GLint
+getCurrentProgram = alloca $ glGetIntegerv gl_CURRENT_PROGRAM >> peek
+
+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 )
+
+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)
+
+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 _ _ = []
+
+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 )
+
+(|*|) :: (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))
+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)
+
+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)
+
+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)
+toNormalMatrix mat = inv4 mat >>= return . trunc4 . transpose4
generated by cgit (git 2.34.1) at 2025-04-28 16:30:27 +0000