initial commit

23 files changed, 1582 insertions, 0 deletions

diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
new file mode 100644
index 0000000..e43e48a
--- /dev/null
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Graphics.Glyph.BufferBuilder where
+
+import Control.Monad
+import Graphics.Rendering.OpenGL
+import Foreign.Storable
+import Foreign.Ptr
+import Data.Array.Storable
+import Data.Setters
+import Debug.Trace
+import qualified Data.Foldable as Fold
+import Data.Sequence as Seq
+
+import Graphics.Glyph.Mat4
+import Graphics.Glyph.Util
+
+import System.IO.Unsafe
+
+data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End
+bufferSize :: BufferBuilder3D -> Int
+bufferSize End = 0
+bufferSize (Plot _ _ l _) = l
+
+nelem :: BufferBuilder3D -> Int
+nelem End = 0
+nelem (Plot _ _ _ l) = l
+
+sizeofGLfloat :: Int
+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,
+    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++"]"
+
+instance (Num t) => Monad (Builder t) where
+    (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
+
+    return = Builder empty
+    fail = BuildError
+
+{- Add a vertex to the current builder -}
+bVertex3 :: (a,a,a) -> Builder a ()
+bVertex3 vert = Builder (Seq.singleton $ VertexLink vert) ()
+
+bTexture2 :: (a,a) -> Builder a ()
+bTexture2 tex = Builder (Seq.singleton $ TextureLink tex) ()
+
+bNormal3 :: (a,a,a) -> Builder a ()
+bNormal3 norm = Builder (Seq.singleton $ NormalLink norm) ()
+
+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 (_,_,_,buffer) =
+         Fold.foldl (\(cn,cc,ct,ll) ele ->
+                    -- trace ("foldl " ++! ele) $
+                    case ele of
+                        NormalLink nn -> (nn,cc,ct,ll)
+                        ColorLink nc -> (cn,nc,ct,ll)
+                        TextureLink nt -> (cn,cc,nt,ll)
+                        VertexLink vert ->
+                         (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), Seq.empty ) (Seq.reverse lst)
+
+    arr <- newListArray (0,Seq.length buffer) (Fold.toList buffer)
+    ((putStrLn.("Compiled: "++!))>&>return) $ CompiledBuild stride en (Seq.length buffer `div` stride * sizeof) arr
+
+                
+    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
+
+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
+
+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
+
+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
+
+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
+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
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))
+                    
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
diff --git a/Graphics/Glyph/Shaders.hs b/Graphics/Glyph/Shaders.hs
new file mode 100644
index 0000000..9a85e1a
--- /dev/null
+++ b/Graphics/Glyph/Shaders.hs
@@ -0,0 +1,57 @@
+module Graphics.Glyph.Shaders where
+
+import Graphics.Rendering.OpenGL
+import qualified Data.ByteString as BS
+import Control.Monad
+import Data.Maybe
+
+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)
+
+    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 )
+
+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
+
+    ok <- get $ linkStatus p
+    info <- get $ programInfoLog p
+
+    unless ok $
+        deleteObjectNames [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
+            Just p -> liftM (Just . uniform) (get $ uniformLocation p name)
+            Nothing -> return Nothing )
+
+getUniformForProgram :: Uniform a => String -> Program -> IO (StateVar a)
+getUniformForProgram name prog =
+    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) )
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
new file mode 100644
index 0000000..7e86d2a
--- /dev/null
+++ b/Graphics/Glyph/Textures.hs
@@ -0,0 +1,39 @@
+module Graphics.Glyph.Textures where
+
+import Data.Array.Storable
+import Data.Word
+
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.Rendering.OpenGL
+import Control.Monad
+
+data Pixels =
+    PixelsRGB  (Int,Int) (StorableArray Int Word8) |
+    PixelsRGBA (Int,Int) (StorableArray Int Word8)
+
+pixelsArray :: Pixels -> StorableArray Int Word8
+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))
+
+-- 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)
+
+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
+
+
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
new file mode 100644
index 0000000..550dd30
--- /dev/null
+++ b/Graphics/Glyph/Util.hs
@@ -0,0 +1,125 @@
+module Graphics.Glyph.Util where
+
+import Data.Angle
+import Graphics.Rendering.OpenGL
+
+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
+
+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
+
+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
+
+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
+    )
+
+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 f (a, b, c) = (f a, f b, f c)
+
+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 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 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 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
+
+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
+
+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)
+
+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)
+
+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)
+
+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)
+
+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 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 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 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
+toFloating = fromRational . toRational
+
+(!!%) :: [a] -> Int -> a
+(!!%) lst idx = lst !! (idx `mod` length lst)
+
+(++!) :: (Show a) => String -> a -> String
+(++!) str = (str++) . show
+
+clamp :: (Ord a) => a -> (a, a) -> a 
+clamp var (low, high) = min (max var low) high
+
+floatVertex :: (GLfloat,GLfloat,GLfloat) -> Vertex3 GLdouble
+floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup)
+
+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 [] = ([],s)
+(>&>) :: (Monad m) => (a -> m b) -> (a -> m c) -> a -> m c
+(>&>) f1 f2 a = f1 a >> f2 a
diff --git a/Hw8.hs b/Hw8.hs
new file mode 100644
index 0000000..83b970f
--- /dev/null
+++ b/Hw8.hs
@@ -0,0 +1,501 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where 
+
+import Control.Applicative
+import Control.Monad
+
+import Data.Setters
+import Data.Maybe
+import Data.Word
+
+import Debug.Trace
+
+import Graphics.Rendering.OpenGL
+import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.UI.SDL as SDL
+import Graphics.Glyph.GLMath
+import Graphics.Glyph.Mat4
+
+import Graphics.UI.SDL.Image
+import Graphics.Glyph.Textures
+import Graphics.Glyph.Shaders
+import Graphics.Glyph.Util
+import Graphics.Glyph.BufferBuilder
+
+import Control.DeepSeq
+import System.Exit
+import System.Random
+
+import Debug.Trace
+import Foreign.Storable
+import Foreign.Ptr
+
+class Drawable a where
+    -- mvMat -> pMat -> obj -> IO ()
+    draw :: a -> IO ()
+
+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
+    textureAttribute :: (Maybe AttribLocation), -- texture attrib
+    resources :: a, -- Resources
+    setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
+    teardownRoutine :: (Maybe (GlyphObject a -> IO ())) -- Tear down
+}
+
+$(declareSetters ''GlyphObject)
+makeGlyphObject :: Builder GLfloat x ->
+    AttribLocation ->
+    Maybe AttribLocation ->
+    Maybe AttribLocation ->
+    Maybe AttribLocation ->
+    a ->
+    Maybe (GlyphObject a -> IO ()) ->
+    Maybe (GlyphObject a -> IO ()) ->
+    IO (GlyphObject a)
+
+makeGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear = do
+    compiled <- compilingBuilder builder
+    buffer <- createBufferObject ArrayBuffer compiled
+    return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup tear
+
+glyphObjectPrepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+glyphObjectPrepare (GlyphObject a b c d e f g _ i) h = GlyphObject a b c d e f g (Just h) i
+
+glyphObjectTeardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
+glyphObjectTeardown (GlyphObject a b c d e f g h _) i = GlyphObject a b c d e f g h (Just i)
+
+instance (Show a) => Show (GlyphObject a) where
+    show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _) =
+        "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++
+            " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++"]"
+
+instance Drawable (GlyphObject a) where
+    draw obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown) = 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 Quads 0 (bufferLength co)
+            
+        forM_ enabled $ \(attr, _) -> do
+            vertexAttribArray attr $= Disabled
+            
+        {- Tear down whatever the object needs -}
+        maybe (return ()) (apply obj) tearDown
+        where liftMaybe t@(Just a, Just b) = Just (a,b)
+              liftMaybe _ = Nothing
+              apply obj f = f obj
+
+data Uniforms = Uniforms {
+    dxU :: UniformLocation,
+    dyU :: UniformLocation,
+
+    textureU :: UniformLocation,
+    earthU :: UniformLocation,
+    cloudsU :: UniformLocation,
+
+    timeU :: UniformLocation,
+    lightsU :: UniformLocation,
+
+    randomU :: UniformLocation,
+    winterU :: UniformLocation
+} deriving Show
+
+data TextureData = TextureData {
+    textureSize :: (Int,Int),
+    textureObject :: TextureObject } deriving Show
+ 
+data Resources = Resources {
+    object :: GlyphObject Uniforms,
+    backDrop :: GlyphObject (Program,UniformLocation),
+    moon :: GlyphObject (Program,
+                UniformLocation,
+                UniformLocation,
+                UniformLocation,
+                UniformLocation,
+                UniformLocation,
+                UniformLocation,
+                UniformLocation),
+    resTexture :: TextureData,
+    earthTex :: TextureData,
+    cloudsTex :: TextureData,
+    lightsTex :: TextureData,
+    winterTex :: TextureData,
+    spaceTex :: TextureData,
+    moonTex :: TextureData,
+    program :: Program,
+    lightU :: UniformLocation,
+    pU :: UniformLocation,
+    mvU :: UniformLocation,
+    normalMatU :: UniformLocation,
+    resTime :: GLfloat,
+    pMatrix :: Mat4 GLfloat,
+    eyeLocation :: (GLfloat,GLfloat,GLfloat),
+    difEyeLocation :: (GLfloat, GLfloat, GLfloat),
+    lightPos :: (GLfloat,GLfloat,GLfloat),
+    useNoise :: Bool,
+    dTime :: GLfloat
+} deriving (Show)
+
+$(declareSetters ''Resources)
+
+makeTexture :: IO TextureObject
+makeTexture = do
+    texobj <- liftM head $ genObjectNames 1
+    textureBinding Texture2D $= Just texobj
+    textureFilter Texture2D $= ((Linear', Nothing), Linear')
+    return texobj
+
+enumEq :: Enum a => a -> a -> Bool
+enumEq a = (fromEnum a ==) . fromEnum
+
+enumNeq :: Enum a => a -> a -> Bool
+enumNeq a = not . enumEq a
+
+loadProgram :: String -> String -> IO Program
+loadProgram vert frag = do
+    shaders <- loadShaders [
+        (VertexShader, vert),
+        (FragmentShader, frag) ]
+    mapM_ (putStrLn . fst) shaders
+    (linklog, maybeProg) <- createShaderProgram (workingShaders shaders)
+
+    when (isNothing maybeProg) $ do
+        putStrLn "Failed to link program"
+        putStrLn linklog
+        exitWith (ExitFailure 111)
+
+    (return . fromJust)  maybeProg
+
+loadBackdropProgram :: IO Program
+loadBackdropProgram = do
+    shaders <- loadShaders [
+        (VertexShader, "shaders/space.vert"),
+        (FragmentShader, "shaders/space.frag") ]
+    mapM_ (putStrLn . fst) shaders
+    (linklog, maybeProg) <- createShaderProgram (workingShaders shaders)
+
+    when (isNothing maybeProg) $ do
+        putStrLn "Failed to link program"
+        putStrLn linklog
+        exitWith (ExitFailure 111)
+
+    (return . fromJust)  maybeProg
+
+quad :: Builder GLfloat ()
+quad = do
+    forM_ [
+            (-1,-1,0.0),
+            (-1, 1,0.0),
+            ( 1, 1,0.0),
+            ( 1,-1,0.0)
+        ] $ \(a,b,c) -> do
+              bVertex3 (a,b,c)
+
+circle :: GLfloat -> GLfloat -> Builder GLfloat ()
+circle r step = do
+    let lst = concat [[(r,th-step,ph-step),
+                       (r,th+step,ph-step),
+                       (r,th+step,ph+step),
+                       (r,th-step,ph+step)]
+                       | th <- [0,step..359-step],
+                         ph <- [-90,-90+step..89-step]]
+    mapM_ ( doUv >&> ((bNormal3 >&> bVertex3) . toEuclidian) ) lst
+    where doUv (_,th,ph) = bTexture2 (1 - th / 360.0, 1 - (ph / 180.0 + 0.5))
+
+
+
+makeResources :: IO Resources
+makeResources =
+        let pMatrix' = perspectiveMatrix 50 1.8 0.1 100 in
+        loadProgram "shaders/normal.vert" "shaders/textured.frag" >>= (\prog -> do
+            glo <- makeGlyphObject
+                    <$> (pure $ circle 1 3)
+                    <*> get (attribLocation prog "in_position")
+                    <*> (get (attribLocation prog "in_normal") >>= return . Just)
+                    <*> pure Nothing
+                    <*> (get (attribLocation prog "in_texMapping") >>= return . Just)
+                    <*> do Uniforms
+                            <$> get (uniformLocation prog "dX")
+                            <*> get (uniformLocation prog "dY")
+                            <*> get (uniformLocation prog "texture")
+                            <*> get (uniformLocation prog "earth")
+                            <*> get (uniformLocation prog "clouds")
+                            <*> get (uniformLocation prog "time")
+                            <*> get (uniformLocation prog "lights")
+                            <*> get (uniformLocation prog "random")
+                            <*> get (uniformLocation prog "winter")
+                    <*> pure Nothing
+                    <*> pure Nothing
+                    
+            prog2 <- loadBackdropProgram
+            backDrop <- makeGlyphObject
+                            <$> pure quad
+                            <*> get (attribLocation prog "in_position")
+                            <*> pure Nothing
+                            <*> pure Nothing
+                            <*> pure Nothing
+                            <*> (get (uniformLocation prog2 "texture") >>= \x-> return (prog2,x))
+                            <*> pure Nothing
+                            <*> pure Nothing
+
+            moonProg <- loadProgram "shaders/moon.vert" "shaders/moon.frag"
+            moon <- makeGlyphObject
+                    <$> pure (circle 0.2 5)
+                    <*> get (attribLocation moonProg "in_position")
+                    <*> liftM Just (get (attribLocation moonProg "in_normal"))
+                    <*> pure Nothing
+                    <*> liftM Just (get (attribLocation moonProg "in_texMapping"))
+                    <*> do (,,,,,,,)
+                            <$> pure moonProg
+                            <*> get (uniformLocation moonProg "texture")
+                            <*> get (uniformLocation moonProg "lightPos")
+                            <*> get (uniformLocation moonProg "mvMat")
+                            <*> get (uniformLocation moonProg "pMat")
+                            <*> get (uniformLocation moonProg "time")
+                            <*> get (uniformLocation moonProg "dX")
+                            <*> get (uniformLocation moonProg "dY")
+                    <*> pure Nothing
+                    <*> pure Nothing
+
+            Resources
+                <$> glo
+                <*> backDrop
+                <*> moon
+                <*> (makeTexture >>= genRandomTexture)
+                <*> (load ("textures/earth.png") >>= textureFromSurface)
+                <*> (load ("textures/clouds.png") >>= textureFromSurface)
+                <*> (load ("textures/lights.png") >>= textureFromSurface)
+                <*> (load ("textures/winter.png") >>= textureFromSurface)
+                <*> (load ("textures/space.png") >>= textureFromSurface)
+                <*> (load ("textures/moon.png") >>= textureFromSurface)
+                <*> pure prog
+                <*> get (uniformLocation prog "light")
+                <*> get (uniformLocation prog "pMat")
+                <*> get (uniformLocation prog "mvMat")
+                <*> get (uniformLocation prog "normalMat")
+                <*> pure 0
+                <*> pure pMatrix'
+                <*> pure (5,45.1,0.1)
+                <*> pure (0,0,0)
+                <*> pure (20,0.1,0.1)
+                <*> pure False
+                <*> pure 1.0
+            )
+        
+printErrors :: String -> IO ()
+printErrors ctx =
+    get errors >>= mapM_ (putStrLn . (("GL["++ctx++"]: ")++) . show)
+
+setupMvp :: Mat4 GLfloat ->Resources -> IO ()
+setupMvp mvMatrix res =
+    do
+--        putStrLn ("lookAt: " ++! (Vec3 . toEuclidian $ eyeLocation res) ++ " "
+--                    ++! (Vec3 (0,0,0)) ++ " " ++! (Vec3 (0,1,0)))
+--        print mvMatrix
+        _ <- (uniform (pU res) $= pMatrix res)
+        t <- (uniform (mvU res) $= mvMatrix)
+        return t
+
+setupLighting :: Mat4 GLfloat -> Resources -> UniformLocation -> IO ()
+setupLighting mvMat res lu =
+    let (+++) = zipWithT3 (+)
+        (a,b,c) = (toEuclidian $ lightPos res)
+        Vec4 (x,y,z,_) = mvMat `glslMatMul` Vec4 (a,b,c,1)
+        normalMat = toNormalMatrix mvMat
+    in do
+      --  putStrLn $ "Multiply "++!(a,b,c)++" by\n"++!mvMat++"\nyeilds "++!(x,y,z)
+        uniform lu $= (Vertex3 x y z)
+        case normalMat of
+            Just mat -> uniform (normalMatU res) $= mat
+            _ -> putStrLn "Normal matrix could not be computed"
+
+
+setupTexturing :: TextureData -> UniformLocation -> Int -> IO ()
+setupTexturing (TextureData _ to) tu unit = do
+    texture Texture2D $= Enabled
+    activeTexture $= TextureUnit (fromIntegral unit)
+    textureBinding Texture2D $= Just to
+    uniform tu $= Index1 (fromIntegral unit::GLint)
+    printErrors "setupTexturing"
+
+
+display :: SDL.Surface -> Resources -> IO Resources
+display surf res = do
+    clear [ColorBuffer, DepthBuffer]
+    clearColor $= Color4 0.3 0.3 0.3 1.0
+    SDL.flip surf
+
+    depthFunc $= Nothing
+    draw $ glyphObjectPrepare (backDrop res) $ \obj -> do
+                let (prg,uni) = (resources obj)
+                currentProgram $= Just prg
+                setupTexturing (spaceTex res) uni 0
+
+    currentProgram $= Just (program res)
+    let (_,_,ph) = eyeLocation res
+    let up = if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0)
+            where ph' = (floor ph::Int) `mod` 360
+    let mvMatrix = lookAtMatrix (Vec3 . toEuclidian $ eyeLocation res) (Vec3 (0,0,0)) up
+    
+    vertexProgramPointSize $= Enabled
+    draw $ glyphObjectPrepare (object res) $ \glo -> do
+                depthFunc $= Just Less
+                let bumpMap = if useNoise res then resTexture else earthTex
+                let uniforms = resources glo
+                let (w,h) = mapT2 fromIntegral (textureSize $ bumpMap res)
+                uniform (dxU uniforms) $= Index1 (1.0/w::GLfloat)
+                uniform (dyU uniforms) $= Index1 (1.0/h::GLfloat)
+                uniform (timeU uniforms) $= Index1 (resTime res)
+                setupMvp mvMatrix res
+                setupLighting  mvMatrix res (lightU res)
+                setupTexturing (bumpMap res) (textureU uniforms) 0
+                setupTexturing (earthTex res) (earthU uniforms) 1
+                setupTexturing (cloudsTex res) (cloudsU uniforms) 2
+                setupTexturing (lightsTex res) (lightsU uniforms) 3
+                setupTexturing (resTexture res) (randomU uniforms) 4
+                setupTexturing (winterTex res) (winterU uniforms) 5
+
+    draw $ glyphObjectPrepare (moon res) $ \glo -> do
+            let (prog, texU, lU, mvMatU, pMatU, timeUn,dxUn,dyUn) = resources glo
+            let (w,h) = mapT2 fromIntegral (textureSize $ moonTex res)
+            let time = resTime res
+            currentProgram $= Just prog
+            uniform mvMatU $= (mvMatrix ==> Vec4 (10*gsin (time / 10),0,10*gcos (time / 10),0))
+            uniform pMatU $= (pMatrix res)
+            uniform timeUn $= Index1 time
+            uniform dxUn $= Index1 (1.0/w::GLfloat)
+            uniform dyUn $= Index1 (1.0/w::GLfloat)
+            setupTexturing (moonTex res) texU 0
+            setupLighting mvMatrix res lU
+
+    SDL.glSwapBuffers
+    return res
+
+digestEvents :: Resources -> IO Resources
+digestEvents args = do
+    ev <- SDL.pollEvent
+    case ev of
+        SDL.NoEvent -> return args
+        VideoResize w h -> reshape (w,h) args >>= digestEvents
+        KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess
+        KeyDown (Keysym SDLK_RIGHT _ _) -> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,1,0)) args
+        KeyDown (Keysym SDLK_LEFT _ _) -> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,-1,0)) args
+        KeyUp (Keysym SDLK_LEFT _ _)-> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,1,0)) args
+        KeyUp (Keysym SDLK_RIGHT _ _)-> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,-1,0)) args
+
+        KeyDown (Keysym SDLK_UP _ _) -> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0, 1)) args
+        KeyDown (Keysym SDLK_DOWN _ _) -> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0,-1)) args
+        KeyUp (Keysym SDLK_UP _ _)-> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0,-1)) args
+        KeyUp (Keysym SDLK_DOWN _ _)-> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0, 1)) args
+
+        KeyDown (Keysym SDLK_w _ _) -> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (-0.1,0,0)) args
+        KeyDown (Keysym SDLK_s _ _) -> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0.1,0,0)) args
+        KeyUp (Keysym SDLK_w _ _)-> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0.1,0,0)) args
+        KeyUp (Keysym SDLK_s _ _)-> 
+            digestEvents $ setDifEyeLocation (difEyeLocation args +++ (-0.1,0,0)) args
+
+        KeyDown (Keysym SDLK_n _ _) ->
+            digestEvents $ (Prelude.flip setUseNoise args.not.useNoise) args
+
+        KeyDown (Keysym SDLK_EQUALS _ _) ->
+            digestEvents $ setDTime (dTime args + 1.0) args
+
+        KeyDown (Keysym SDLK_MINUS _ _) ->
+            digestEvents $ setDTime (dTime args - 1.0) args
+
+        Quit -> exitSuccess
+        _ -> digestEvents args
+    where
+        (+++) = zipWithT3 (+)
+
+reshape :: (Int, Int) -> Resources -> IO Resources
+reshape (w, h) args = do
+    let size = Size (fromIntegral w) (fromIntegral h)
+    let pMatrix' = perspectiveMatrix 50 (fromIntegral w / fromIntegral h) 0.1 100
+    viewport $=(Position 0 0, size)
+    _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
+    return $ setPMatrix pMatrix' args
+
+bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
+bindSurfaceToTexture surf to = do
+    textureBinding Texture2D $= Just to
+    bbp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
+    ptr <- surfaceGetPixels surf
+    glTexImage2D gl_TEXTURE_2D 0 bbp (w surf) (h surf) 0 (if bbp == 3 then gl_RGB else gl_RGBA) gl_UNSIGNED_BYTE ptr
+    return $ TextureData (w surf, h surf) to
+    where 
+          w :: (Integral a) => SDL.Surface -> a
+          w = fromIntegral . surfaceGetWidth
+          h :: (Integral a) => SDL.Surface -> a
+          h = fromIntegral . surfaceGetHeight
+
+textureFromSurface :: SDL.Surface -> IO TextureData
+textureFromSurface surf = makeTexture >>= (bindSurfaceToTexture surf >=> return)
+
+genRandomTexture :: TextureObject -> IO TextureData
+genRandomTexture to =
+    -- putStrLn ("takeShot")
+    let nextColor gen =
+         let (g1, gen') = next gen in
+         let (g2, gen'') = next gen' in
+         let (g3, gen''') = next gen'' in
+         let (g4, gen'''') = next gen''' in
+         ((g1,g2,g3,g4),gen'''') in do
+
+    stgen <- newStdGen
+    mPix <- newPixelsFromListRGBA (1024,1024) (randomTup $ randoms stgen)
+
+    attachPixelsToTexture mPix to
+    return $ TextureData (1024,1024) to
+    where randomTup (a:b:c:d:xs) = (a,b,c,d):randomTup xs
+
+main :: IO ()
+main = do
+        let _printError = get errors >>= mapM_ (putStrLn . ("GL: "++) . show)
+        let size@(w,h) = (640, 480)
+    
+        SDL.init [SDL.InitEverything]
+
+        _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
+        screen <- SDL.getVideoSurface
+        resources <- makeResources
+        reshape size resources >>= mainloop screen
+
+    where mainloop screen resources =
+            digestEvents resources >>= display screen >>= (mainloop screen . updateResources)
+          (+++) = zipWithT3 (+)
+          updateResources res =
+            setEyeLocation (zipWithT3 (+) (eyeLocation res) (difEyeLocation res)) $
+            setResTime ( resTime res + (dTime res) ) res
+
+
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..825ce23
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,25 @@
+SHELL=/bin/bash
+
+all: test configure
+	cabal build
+	cp dist/build/jora2470_hw8/jora2470_hw8 .
+
+test:
+	if [[ "$$(which cabal)" == "" ]]; \
+	then \
+		echo cabal does not exist. Install it with \'sudo apt-get install cabal-install\'; \
+		exit 1;\
+	fi
+
+configure:
+#	cabal update
+	cabal install cabal
+	cabal install --only-dependencies
+	cabal configure
+
+clean:
+	cabal clean
+	- rm -f jora2470_hw8 *.hi *.o
+
+superclean: clean
+	- rm -f jora2470 $$(find . -name '.*sw*')
diff --git a/README b/README
new file mode 100644
index 0000000..bc6b340
--- /dev/null
+++ b/README
@@ -0,0 +1,10 @@
+This was a tough one to get to work with Haskell. Apparently pretty much all of the OpenCV Haskell bindings
+are broken/half-implemented, so I had to create my own with FFI.
+
+As usual, I have provided a statically linked binary just in case.
+
+This project took me about 8 to 10 hours to complete.
+
+make with make
+run with
+    ./jora2470_hw7
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/jora2470_hw8.cabal b/jora2470_hw8.cabal
new file mode 100644
index 0000000..1fc9ffc
--- /dev/null
+++ b/jora2470_hw8.cabal
@@ -0,0 +1,21 @@
+-- Initial jora2470_hw2.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                homework8
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+-- license:             
+license-file:        LICENSE
+author:              Josh Rahm
+maintainer:          joshuarahm@gmail.com
+-- copyright:           
+-- category:            
+build-type:          Simple
+cabal-version:       >=1.8
+
+executable jora2470_hw8
+  main-is: Hw8.hs
+  extensions: FlexibleInstances
+  -- other-modules:       
+  build-depends:       setters, base, OpenGL, bytestring, array, SDL, random, OpenGLRaw, AC-Angle, deepseq, containers, SDL-image
diff --git a/shaders/moon.frag b/shaders/moon.frag
new file mode 100644
index 0000000..b72005c
--- /dev/null
+++ b/shaders/moon.frag
@@ -0,0 +1,50 @@
+#version 150
+in vec2 texMapping ;
+in vec3 position ;
+in vec3 normal ;
+
+uniform sampler2D texture ;
+uniform vec3 lightPos ;
+uniform float dX ;
+uniform float dY ;
+
+out vec4 frag_color ;
+
+vec4 sample(float xc,float yc) {
+   return texture2D(texture,texMapping + vec2(xc,yc));
+}
+
+
+vec3 calNormChange( vec3 norm, vec3 down, vec3 right ) {
+    float x00 = length(sample(-dX, dY)) ; 
+    float x01 = length(sample(  0, dY)) ; 
+    float x02 = length(sample( dX, dY)) ; 
+
+    float x10 = length(sample(-dX, 0)) ; 
+    float x11 = length(sample(  0, 0)) ; 
+    float x12 = length(sample( dX, 0)) ; 
+
+    float x20 = length(sample(-dX,-dY)) ; 
+    float x21 = length(sample(  0,-dY)) ; 
+    float x22 = length(sample( dX,-dY)) ; 
+
+    down = ((x11 - x00) + (x11 - x01) + (x11 - x02) - (x11 - x20) - (x11 - x21) - (x11 - x22)) * down ;
+    right = ((x11 - x00) + (x11 - x10) + (x11 - x20) - (x11 - x02) - (x11 - x12) - (x11 - x22)) * right ;
+    
+    return (right + down + norm*3.0) / 5.0 ;
+}
+
+void main() {
+    vec3 down = vec3( 0, -1, 0 ) ;
+    vec3 right = normalize(cross( normal, down )) ;
+    down = normalize(cross( normal, right ) );
+
+    vec3 newNorm = calNormChange( normal, down, right ) ;
+    vec3 diff = lightPos - position ;
+    float intensity = max(dot( normalize(diff), normalize(newNorm) ),0.0) ;
+    intensity = sqrt(sqrt( intensity )) ;
+    
+    vec4 tmpcolor = texture2D(texture, texMapping) * intensity ;
+    tmpcolor *= pow(length(tmpcolor),4.0-min(length(position)/4.0,4.0)) ;
+    frag_color = tmpcolor ;
+}
diff --git a/shaders/moon.vert b/shaders/moon.vert
new file mode 100644
index 0000000..2e6a928
--- /dev/null
+++ b/shaders/moon.vert
@@ -0,0 +1,21 @@
+#version 150
+in vec3 in_position ;
+in vec3 in_normal ;
+in vec2 in_texMapping ;
+
+uniform mat4 mvMat ;
+uniform mat4 pMat ;
+uniform float time ;
+
+out vec2 texMapping ;
+out vec3 position ;
+out vec3 normal ;
+
+void main () {
+    vec4 tmp = mvMat * vec4(in_position, 1.0);
+    gl_Position = pMat * tmp ;
+    gl_PointSize = 4.0 ;
+    position = vec3( tmp ) ;
+    texMapping = in_texMapping ;
+    normal = inverse(transpose(mat3(mvMat))) * in_normal ;
+}
diff --git a/shaders/normal.vert b/shaders/normal.vert
new file mode 100644
index 0000000..34ddce3
--- /dev/null
+++ b/shaders/normal.vert
@@ -0,0 +1,27 @@
+#version 150
+in vec3 in_position ;
+in vec3 in_normal ;
+in vec2 in_texMapping ;
+
+uniform mat4 pMat ;
+uniform mat4 mvMat ;
+uniform vec3 light ;
+
+out vec3 trueNormal ;
+out vec2 texCoord ;
+out float intensity ;
+out vec4 location ;
+out vec3 light2 ;
+out vec2 texMapping ;
+out mat3 normalMat ;
+
+// (-4.330127,5.0,7.4999995)
+void main() {
+    light2 = light ; //multMat(mvMat * vec4(light,1)).xyz ;
+
+    location = mvMat * vec4(in_position, 1.0) ;
+    gl_Position = pMat * location;
+    texCoord = vec2(in_position) * vec2(0.5) + vec2(0.5);
+    texMapping = in_texMapping ;
+    trueNormal = inverse(transpose(mat3(mvMat))) * (-in_normal) ;
+}
diff --git a/shaders/space.frag b/shaders/space.frag
new file mode 100644
index 0000000..13e134b
--- /dev/null
+++ b/shaders/space.frag
@@ -0,0 +1,9 @@
+#version 150
+uniform sampler2D texture ;
+in vec2 texMap ;
+
+out vec4 frag_color ; 
+
+void main() {
+    frag_color = texture2D( texture, texMap ) ;   
+}
diff --git a/shaders/space.vert b/shaders/space.vert
new file mode 100644
index 0000000..fdfec59
--- /dev/null
+++ b/shaders/space.vert
@@ -0,0 +1,8 @@
+#version 150
+in vec3 in_position ;
+out vec2 texMap ;
+
+void main() {
+    texMap = (in_position.xy + 1.0) / 2.0 ;
+    gl_Position = vec4(in_position,1.0) ;
+}
diff --git a/shaders/textured.frag b/shaders/textured.frag
new file mode 100644
index 0000000..266bf31
--- /dev/null
+++ b/shaders/textured.frag
@@ -0,0 +1,156 @@
+#version 150
+uniform sampler2D texture ;
+uniform sampler2D earth ;
+uniform sampler2D clouds ;
+uniform sampler2D lights ;
+uniform sampler2D random ;
+uniform sampler2D winter ;
+
+uniform float time ;
+uniform vec3 light ;
+uniform float dX ;
+uniform float dY ;
+
+in vec2 texCoord ;
+in vec3 trueNormal ;
+in vec4 location ;
+in vec3 light2 ;
+in mat3 normalMat ;
+
+out vec4 frag_color ;
+in vec2 texMapping ;
+
+
+float cloudMotion = -time / 1100.0 ;
+float earthMotion = -time / 1400.0 ;
+
+vec3 lighting( vec3 norm, vec3 lightPos ) {
+    vec3 diff = normalize(vec3(location) - lightPos) ;
+    float tmp = dot(diff, normalize( norm )) + 0.3 ;
+
+    if( tmp < 0.0 ) return vec3(0) ;
+    return vec3(
+        pow(tmp / length(diff),0.3),
+        pow(tmp / length(diff),0.8),
+        pow(tmp / length(diff),1.0)
+    );
+}
+
+vec4 sample(sampler2D tex, float xc,float yc) {
+   return texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2(xc,yc));
+}
+
+float f( float x ) {
+    return x * (x - 1.0) ;
+}
+
+vec3 calNormChange( sampler2D tex, vec3 norm, vec3 down, vec3 right ) {
+    float x00 = length(sample(tex,-dX, dY)) ; 
+    float x01 = length(sample(tex,  0, dY)) ; 
+    float x02 = length(sample(tex, dX, dY)) ; 
+
+    float x10 = length(sample(tex,-dX, 0)) ; 
+    float x11 = length(sample(tex,  0, 0)) ; 
+    float x12 = length(sample(tex, dX, 0)) ; 
+
+    float x20 = length(sample(tex,-dX,-dY)) ; 
+    float x21 = length(sample(tex,  0,-dY)) ; 
+    float x22 = length(sample(tex, dX,-dY)) ; 
+
+    down = ((x11 - x00) + (x11 - x01) + (x11 - x02) - (x11 - x20) - (x11 - x21) - (x11 - x22)) * down ;
+    right = ((x11 - x00) + (x11 - x10) + (x11 - x20) - (x11 - x02) - (x11 - x12) - (x11 - x22)) * right ;
+    
+    return (right + down + norm) / 3.0 ;
+}
+
+vec4 sampleBlur( sampler2D tex ) {
+    return
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2( dX, dY)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2(  0, dY)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2(-dX, dY)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2( dX,  0)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2(  0,  0)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2(-dX,  0)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2( dX,-dY)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2(  0,-dY)) / 9.0 +
+        texture2D(texture,texMapping + vec2(earthMotion,0.0) + vec2(-dX,-dY)) / 9.0;
+}
+
+void main() {
+    vec3 down = vec3( 0, -1, 0 ) ;
+    vec3 right = normalize(cross( trueNormal, down )) ;
+    down = normalize(cross( trueNormal, right ) );
+
+    /* Calculate the new normal using bump mapping */
+    vec3 newNorm = calNormChange( texture, trueNormal, down, right ) ;
+
+    /* Calculate the shadow casted by the clouds. Blur it a litte for
+     * realism */
+    vec4 shadow = (texture2D(clouds, texMapping+vec2(cloudMotion-0.005,-0.005))+
+                   texture2D(clouds, texMapping+vec2(cloudMotion-0.01,-0.01))+
+                   texture2D(clouds, texMapping+vec2(cloudMotion-0.01,-0.005))+
+                   texture2D(clouds, texMapping+vec2(cloudMotion-0.005,-0.01))) / 8.0 ;
+
+    /* The color of the clouds at the position */
+    vec4 cloudsColor = texture2D(clouds, texMapping+vec2(cloudMotion,0.0)) ;
+
+    /* Mix the colors of the earth in the summer and earth in the winter with
+     * as a function of the sin of the time */
+    vec4 color = mix(
+            texture2D(earth, texMapping+vec2(earthMotion,0.0)),
+            texture2D(winter, texMapping+vec2(earthMotion,0.0)), (sin(time / 400.0) + 1.0) / 2.0
+            /* Add the clouds an subtract the shadows */
+            ) + cloudsColor - shadow ;
+    
+    /* Calulate the light intensity using the new norrmal */
+    vec3 light = lighting(newNorm, light2) + vec3(0.05);
+    vec4 tmpcolor = vec4(color.x*light.x, color.y*light.y, color.z*light.z, 1.0);
+
+    /* Get a couple of random values from the noise texture */
+    vec4 cmp = texture2D(random, texMapping+vec2(earthMotion,0.0)) ;
+    vec4 cmp2 = texture2D(random, texMapping+vec2(earthMotion,0.1)) ;
+
+    /* Get the texture for the city lights */
+    vec4 cityLights = texture2D(lights, texMapping+vec2(earthMotion,0.0)) ;
+
+    if ( pow(length(cmp),2) > pow(length(tmpcolor)*1.3,2) && length(cityLights) > 1.0) {
+        /* if the random value is larger than the current color and there is a light
+         * in this position, turn it on. This is to simulate lights in regions
+         * under the shadow of a cloud */
+        tmpcolor += vec4(1.0,1.0,0.5,1.0) * cityLights ;
+    }
+
+    if (0.1 > light.x) {
+        /* It is night time all overt the place, so include the night texture
+         * and subtract out the clouds. Mix between two reddish-yellow colors as
+         * a function of time to simulate twinkling */
+        tmpcolor *= mix(
+            vec4(cmp.r*2.0,min(cmp.g,cmp.r)*1.5,min(cmp.b,cmp.r),1.0),
+            vec4(cmp2.r*2.0,min(cmp2.g,cmp2.r)*1.5,min(cmp2.b,cmp2.r),1.0), (sin(time*cmp2.a+cmp.a)+1.0)/2.0 ) ;
+        tmpcolor -= cloudsColor;
+    }
+
+    /* Draw the atmosphere of the earth. The blue ring at the edge of the
+     * Earth*/
+    float blue = max(
+        pow(1.0-dot(vec3(0,0,-1), normalize(trueNormal)),3.0),
+        0.0);
+    tmpcolor += vec4(0.0,0.0,blue*length(light),0.0) ;
+
+    /* Calculate the Sun's reflection off of the water on the Earth.
+     * Get a blurred sample from the earth to check for blue */
+    vec4 sample = sampleBlur(earth);
+
+    /* calculate the coefficient of the specular dot based on
+     * the amount of blue in the sample */
+    float lightlen = pow(max(length(light)-0.8,0.0),5.0) * (sample.b/(sample.r+sample.g)) * (1-length(shadow));
+    tmpcolor += vec4(0.3,0.2,0.15,0.0) *
+        max(
+            pow(dot(reflect(normalize(vec3(location) - light2), normalize(trueNormal)),
+                - normalize(vec3(location))),1.0) *
+        lightlen, 0.0) ;
+    frag_color = tmpcolor ;
+}
+
+
+
diff --git a/textures/clouds.png b/textures/clouds.png
new file mode 100644
index 0000000..fc1f859
--- /dev/null
+++ b/textures/clouds.png
diff --git a/textures/earth.png b/textures/earth.png
new file mode 100644
index 0000000..067c9c5
--- /dev/null
+++ b/textures/earth.png
diff --git a/textures/lights.png b/textures/lights.png
new file mode 100644
index 0000000..890a9bc
--- /dev/null
+++ b/textures/lights.png
diff --git a/textures/moon.png b/textures/moon.png
new file mode 100644
index 0000000..741d313
--- /dev/null
+++ b/textures/moon.png
diff --git a/textures/space.png b/textures/space.png
new file mode 100644
index 0000000..a6593d2
--- /dev/null
+++ b/textures/space.png
diff --git a/textures/winter.png b/textures/winter.png
new file mode 100644
index 0000000..e7fdd0f
--- /dev/null
+++ b/textures/winter.png