initial commit

1 files changed, 145 insertions, 0 deletions

diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
new file mode 100644
index 0000000..bec796c
--- /dev/null
+++ b/Graphics/Glyph/GLMath.hs
@@ -0,0 +1,145 @@
+{-# 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))
+