aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Graphics/Glyph/BufferBuilder.hs163
-rw-r--r--Graphics/Glyph/GLMath.hs145
-rw-r--r--Graphics/Glyph/Mat4.hs223
-rw-r--r--Graphics/Glyph/Shaders.hs57
-rw-r--r--Graphics/Glyph/Textures.hs39
-rw-r--r--Graphics/Glyph/Util.hs125
-rw-r--r--Hw8.hs501
-rw-r--r--Makefile25
-rw-r--r--README10
-rw-r--r--Setup.hs2
-rw-r--r--jora2470_hw8.cabal21
-rw-r--r--shaders/moon.frag50
-rw-r--r--shaders/moon.vert21
-rw-r--r--shaders/normal.vert27
-rw-r--r--shaders/space.frag9
-rw-r--r--shaders/space.vert8
-rw-r--r--shaders/textured.frag156
-rw-r--r--textures/clouds.pngbin0 -> 1065245 bytes
-rw-r--r--textures/earth.pngbin0 -> 1381215 bytes
-rw-r--r--textures/lights.pngbin0 -> 288457 bytes
-rw-r--r--textures/moon.pngbin0 -> 726619 bytes
-rw-r--r--textures/space.pngbin0 -> 1514637 bytes
-rw-r--r--textures/winter.pngbin0 -> 812781 bytes
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
Binary files differ
diff --git a/textures/earth.png b/textures/earth.png
new file mode 100644
index 0000000..067c9c5
--- /dev/null
+++ b/textures/earth.png
Binary files differ
diff --git a/textures/lights.png b/textures/lights.png
new file mode 100644
index 0000000..890a9bc
--- /dev/null
+++ b/textures/lights.png
Binary files differ
diff --git a/textures/moon.png b/textures/moon.png
new file mode 100644
index 0000000..741d313
--- /dev/null
+++ b/textures/moon.png
Binary files differ
diff --git a/textures/space.png b/textures/space.png
new file mode 100644
index 0000000..a6593d2
--- /dev/null
+++ b/textures/space.png
Binary files differ
diff --git a/textures/winter.png b/textures/winter.png
new file mode 100644
index 0000000..e7fdd0f
--- /dev/null
+++ b/textures/winter.png
Binary files differ
generated by cgit (git 2.34.1) at 2025-04-28 12:26:45 +0000