aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Graphics/Glyph/BufferBuilder.hs231
-rw-r--r--Graphics/Glyph/GLMath.hs400
-rw-r--r--Graphics/Glyph/GlyphObject.hs196
-rw-r--r--Graphics/Glyph/Mat4.hs552
-rw-r--r--Graphics/Glyph/Shaders.hs58
-rw-r--r--Graphics/Glyph/Textures.hs52
-rw-r--r--Graphics/Glyph/Util.hs116
-rw-r--r--Hw8.hs796
-rw-r--r--Setup.hs1
9 files changed, 1400 insertions, 1002 deletions
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index 4800d3d..5704875 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -1,22 +1,22 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
module Graphics.Glyph.BufferBuilder where
import Control.Monad
-import Graphics.Rendering.OpenGL
-import Foreign.Storable
-import Foreign.Ptr
import Data.Array.Storable
-import Debug.Trace
import qualified Data.Foldable as Fold
import Data.Sequence as Seq
-
+import Debug.Trace
+import Foreign.Ptr
+import Foreign.Storable
import Graphics.Glyph.Mat4
import Graphics.Glyph.Util
-
+import Graphics.Rendering.OpenGL
import System.IO.Unsafe
-data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End
+data BufferBuilder3D = Plot BufferBuilder3D (GLfloat, GLfloat, GLfloat) Int Int | End
+
bufferSize :: BufferBuilder3D -> Int
bufferSize End = 0
bufferSize (Plot _ _ l _) = l
@@ -30,30 +30,33 @@ sizeofGLfloat = 4
{- A state monad that keeps track of operations
- and will compile them into a buffer -}
-data Builder b a = Builder {
- bList :: Seq (BuildDatum b),
- bReturn :: a
-} | BuildError String
-
-data BuildDatum b =
- VertexLink (b,b,b) |
- NormalLink (b,b,b) |
- ColorLink (b,b,b,b) |
- TextureLink (b,b) deriving Show
-
-data CompiledBuild b = CompiledBuild {
- bStride :: Int,
- bEnabled :: (Bool,Bool,Bool),
- nElems :: Int,
+data Builder b a
+ = Builder
+ { bList :: Seq (BuildDatum b),
+ bReturn :: a
+ }
+ | BuildError String
+
+data BuildDatum b
+ = VertexLink (b, b, b)
+ | NormalLink (b, b, b)
+ | ColorLink (b, b, b, b)
+ | TextureLink (b, b)
+ deriving (Show)
+
+data CompiledBuild b = CompiledBuild
+ { bStride :: Int,
+ bEnabled :: (Bool, Bool, Bool),
+ nElems :: Int,
array :: StorableArray Int b
-}
+ }
bufferLength :: (Integral a) => CompiledBuild b -> a
bufferLength = fromIntegral . nElems
instance Show (CompiledBuild x) where
- show (CompiledBuild stride enabled n _) =
- "[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++"]"
+ show (CompiledBuild stride enabled n _) =
+ "[CompiledBuild stride=" ++! stride ++ " enabled" ++! enabled ++ " n=" ++! n ++ "]"
instance Functor (Builder t) where
fmap f b = b >>= (return . f)
@@ -66,106 +69,134 @@ instance Applicative (Builder t) where
return (fn a)
instance Monad (Builder t) where
- (Builder lst1 _) >> (Builder lst2 ret) = Builder (lst2 >< lst1) ret
- BuildError str >> _ = BuildError str
- _ >> BuildError str = BuildError str
+ (Builder lst1 _) >> (Builder lst2 ret) = Builder (lst2 >< lst1) ret
+ BuildError str >> _ = BuildError str
+ _ >> BuildError str = BuildError str
- b1@(Builder _ ret1) >>= func = b1 >> func ret1
- BuildError str >>= _ = BuildError str
+ b1@(Builder _ ret1) >>= func = b1 >> func ret1
+ BuildError str >>= _ = BuildError str
- return = Builder empty
+ return = Builder empty
{- Add a vertex to the current builder -}
-bVertex3 :: (a,a,a) -> Builder a ()
+bVertex3 :: (a, a, a) -> Builder a ()
bVertex3 vert = Builder (Seq.singleton $ VertexLink vert) ()
-bTexture2 :: (a,a) -> Builder a ()
+bTexture2 :: (a, a) -> Builder a ()
bTexture2 tex = Builder (Seq.singleton $ TextureLink tex) ()
-bNormal3 :: (a,a,a) -> Builder a ()
+bNormal3 :: (a, a, a) -> Builder a ()
bNormal3 norm = Builder (Seq.singleton $ NormalLink norm) ()
-bColor4 :: (a,a,a,a) -> Builder a ()
+bColor4 :: (a, a, a, a) -> Builder a ()
bColor4 col = Builder (Seq.singleton $ ColorLink col) ()
compilingBuilder :: (Storable b, Num b, Show b) => Builder b x -> IO (CompiledBuild b)
compilingBuilder (Builder lst _) = do
- -- Size of the elements
- let sizeof = sizeOf $ tmp (Seq.index lst 0)
- where tmp (VertexLink (a,_,_)) = a
- tmp _ = 0
- {- Simply figure out what types of elementse
- - exist in this buffer -}
- let en@(bn,bc,bt) = Fold.foldl' (\(bn,bc,bt) ele ->
- case ele of
- NormalLink _ -> (True,bc,bt)
- ColorLink _ -> (bn,True,bt)
- TextureLink _ -> (bn,bc,True)
- VertexLink _ -> (bn,bc,bt)) (False,False,False) lst
- {- Calculate the stride; number of floats per element -}
- let stride = (3 + (?)bn * 3 + (?)bc * 4 + (?)bt * 2) * sizeof
- where (?) True = 1
- (?) False = 0
- -- Cur color normal texture buffer
- let (nverts,_,_,_,buffer) =
- Fold.foldl' (\(num,cn,cc,ct,ll) ele ->
- -- trace ("foldl " ++! ele) $
- case ele of
- NormalLink nn -> (num,nn,cc,ct,ll)
- ColorLink nc -> (num,cn,nc,ct,ll)
- TextureLink nt -> (num,cn,cc,nt,ll)
- VertexLink vert ->
- (num+1,cn,cc,ct,
- ll >< (tp3 True vert >< tp3 bn cn >< tp4 bc cc >< tp2 bt ct)
- )) ( 0, (0,0,0), (0,0,0,0), (0,0), Seq.empty ) (Seq.reverse lst)
-
- let blst = (Fold.toList buffer)
- arr <- blst `seq` newListArray (0,Seq.length buffer) blst
- let compiledRet = CompiledBuild stride en nverts arr
- compiledRet `seq` putStrLn ("Compiled: " ++! compiledRet ) `seq` return compiledRet
+ -- Size of the elements
+ let sizeof = sizeOf $ tmp (Seq.index lst 0)
+ where
+ tmp (VertexLink (a, _, _)) = a
+ tmp _ = 0
+ {- Simply figure out what types of elementse
+ - exist in this buffer -}
+ let en@(bn, bc, bt) =
+ Fold.foldl'
+ ( \(bn, bc, bt) ele ->
+ case ele of
+ NormalLink _ -> (True, bc, bt)
+ ColorLink _ -> (bn, True, bt)
+ TextureLink _ -> (bn, bc, True)
+ VertexLink _ -> (bn, bc, bt)
+ )
+ (False, False, False)
+ lst
+ {- Calculate the stride; number of floats per element -}
+ let stride = (3 + (?) bn * 3 + (?) bc * 4 + (?) bt * 2) * sizeof
+ where
+ (?) True = 1
+ (?) False = 0
+ -- Cur color normal texture buffer
+ let (nverts, _, _, _, buffer) =
+ Fold.foldl'
+ ( \(num, cn, cc, ct, ll) ele ->
+ -- trace ("foldl " ++! ele) $
+ case ele of
+ NormalLink nn -> (num, nn, cc, ct, ll)
+ ColorLink nc -> (num, cn, nc, ct, ll)
+ TextureLink nt -> (num, cn, cc, nt, ll)
+ VertexLink vert ->
+ ( num + 1,
+ cn,
+ cc,
+ ct,
+ ll >< (tp3 True vert >< tp3 bn cn >< tp4 bc cc >< tp2 bt ct)
+ )
+ )
+ (0, (0, 0, 0), (0, 0, 0, 0), (0, 0), Seq.empty)
+ (Seq.reverse lst)
+
+ let blst = (Fold.toList buffer)
+ arr <- blst `seq` newListArray (0, Seq.length buffer) blst
+ let compiledRet = CompiledBuild stride en nverts arr
+ compiledRet `seq` putStrLn ("Compiled: " ++! compiledRet) `seq` return compiledRet
where
- tp2 True (a,b) = Seq.fromList [a,b]
- tp2 False _ = empty
-
- tp3 True (a,b,c) = Seq.fromList [a,b,c]
- tp3 False _ = empty
-
- tp4 True (a,b,c,d) = Seq.fromList [a,b,c,d]
- tp4 False _ = empty
+ tp2 True (a, b) = Seq.fromList [a, b]
+ tp2 False _ = empty
+
+ tp3 True (a, b, c) = Seq.fromList [a, b, c]
+ tp3 False _ = empty
+
+ tp4 True (a, b, c, d) = Seq.fromList [a, b, c, d]
+ tp4 False _ = empty
storableArrayToBuffer :: (Storable el) => BufferTarget -> StorableArray Int el -> IO BufferObject
storableArrayToBuffer target arr = do
- let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
- [buffer] <- genObjectNames 1
- bindBuffer target $= Just buffer
- len <- getBounds arr >>= (\(a,b) -> return $ (b - a) * sizeof )
- withStorableArray arr $ \ptr ->
- bufferData target $= (fromIntegral len, ptr, StaticDraw)
- return buffer
+ let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
+ [buffer] <- genObjectNames 1
+ bindBuffer target $= Just buffer
+ len <- getBounds arr >>= (\(a, b) -> return $ (b - a) * sizeof)
+ withStorableArray arr $ \ptr ->
+ bufferData target $= (fromIntegral len, ptr, StaticDraw)
+ return buffer
vertexArrayDescriptor :: CompiledBuild GLfloat -> VertexArrayDescriptor GLfloat
vertexArrayDescriptor (CompiledBuild stride _ _ _) = VertexArrayDescriptor 3 Float (fromIntegral stride) (wordPtrToPtr 0)
normalArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-normalArrayDescriptor (CompiledBuild stride (True,_,_) _ _) =
- Just $ VertexArrayDescriptor 3 Float
- (fromIntegral stride) (wordPtrToPtr (3*4))
-normalArrayDescriptor _ = Nothing
+normalArrayDescriptor (CompiledBuild stride (True, _, _) _ _) =
+ Just $
+ VertexArrayDescriptor
+ 3
+ Float
+ (fromIntegral stride)
+ (wordPtrToPtr (3 * 4))
+normalArrayDescriptor _ = Nothing
colorArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-colorArrayDescriptor (CompiledBuild stride tup@(_,True,_) _ _) =
- Just $ VertexArrayDescriptor 4 Float
- (fromIntegral stride) (wordPtrToPtr (offset tup))
- where offset (b1,_,_) = if b1 then (6*4) else (3*4)
-
-colorArrayDescriptor _ = Nothing
+colorArrayDescriptor (CompiledBuild stride tup@(_, True, _) _ _) =
+ Just $
+ VertexArrayDescriptor
+ 4
+ Float
+ (fromIntegral stride)
+ (wordPtrToPtr (offset tup))
+ where
+ offset (b1, _, _) = if b1 then (6 * 4) else (3 * 4)
+colorArrayDescriptor _ = Nothing
textureArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-textureArrayDescriptor (CompiledBuild stride tup@(_,_,True) _ _) =
- Just $ VertexArrayDescriptor 2 Float
- (fromIntegral stride) (wordPtrToPtr (offset tup))
- where offset (b1,b2,_) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
- ifp b x = if b then x else 0
-textureArrayDescriptor _ = Nothing
+textureArrayDescriptor (CompiledBuild stride tup@(_, _, True) _ _) =
+ Just $
+ VertexArrayDescriptor
+ 2
+ Float
+ (fromIntegral stride)
+ (wordPtrToPtr (offset tup))
+ where
+ offset (b1, b2, _) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
+ ifp b x = if b then x else 0
+textureArrayDescriptor _ = Nothing
+
createBufferObject :: BufferTarget -> CompiledBuild GLfloat -> IO BufferObject
createBufferObject target (CompiledBuild _ _ _ arr) = storableArrayToBuffer target arr
diff --git a/Graphics/Glyph/GLMath.hs b/Graphics/Glyph/GLMath.hs
index bec796c..7cd4471 100644
--- a/Graphics/Glyph/GLMath.hs
+++ b/Graphics/Glyph/GLMath.hs
@@ -1,145 +1,259 @@
{-# LANGUAGE MultiParamTypeClasses #-}
+
module Graphics.Glyph.GLMath where
- import Graphics.Glyph.Mat4
- import qualified Graphics.Rendering.OpenGL as GL
- import Graphics.Rendering.OpenGL (GLfloat,Uniform,Vertex3(..),uniform,UniformComponent)
- import Data.Angle
- import Debug.Trace
-
- data Vec2 a = Vec2 (a,a) deriving Show
- data Vec3 a = Vec3 (a,a,a) deriving Show
- data Vec4 a = Vec4 (a,a,a,a) deriving Show
-
- instance UniformComponent a => Uniform (Vec3 a) where
- uniform loc = GL.makeStateVar
- (do
- (Vertex3 x y z) <-
- GL.get (uniform loc)
- return (Vec3 (x,y,z)) )
- (\(Vec3 (x,y,z)) -> uniform loc GL.$= Vertex3 x y z)
-
- class (Floating flT) => Vector flT b where
- (<+>) :: b flT -> b flT -> b flT
- (<->) :: b flT -> b flT -> b flT
- norm :: b flT -> flT
- normalize :: b flT -> b flT
- vDot :: b flT -> b flT -> flT
- vScale :: flT -> b flT -> b flT
-
-
- (<.>) :: (Vector a b) => b a -> b a -> a
- (<.>) = vDot
-
- (|||) :: (Vector a b) => b a -> a
- (|||) = norm
-
- instance (Floating flT) => Vector flT Vec2 where
- (<+>) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a+c,b+d)
- (<->) (Vec2 (a,b)) (Vec2 (c,d)) = Vec2 (a-c,b-d)
- vDot (Vec2 (a,b)) (Vec2 (c,d)) = a * c + b * d
- vScale c (Vec2 (a,b)) = Vec2 (a*c,b*c)
- norm (Vec2 (a,b)) = sqrt (a*a + b*b)
- normalize vec@(Vec2 (a,b)) =
- let n = norm vec in Vec2 (a/n,b/n)
-
- instance (Floating flT) => Vector flT Vec3 where
- (<+>) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a+d,b+e,c+f)
- (<->) (Vec3 (a,b,c)) (Vec3 (d,e,f)) = Vec3 (a-d,b-e,c-f)
- vDot (Vec3 (a,b,c)) (Vec3 (d,e,f)) = a * d + b * e + c * f
- vScale x (Vec3 (a,b,c)) = Vec3 (a*x,b*x,c*x)
- norm (Vec3 (a,b,c)) = sqrt (a*a + b*b + c*c)
- normalize vec@(Vec3 (a,b,c)) =
- let n = norm vec in Vec3 (a/n,b/n,c/n)
-
- instance (Floating flT) => Vector flT Vec4 where
- (<+>) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a+d,b+e,c+f,g+h)
- (<->) (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = Vec4 (a-d,b-e,c-f,g-h)
- vDot (Vec4 (a,b,c,g)) (Vec4 (d,e,f,h)) = a * d + b * e + c * f + g * h
- vScale x (Vec4 (a,b,c,d)) = Vec4 (a*x,b*x,c*x,d*x)
- norm (Vec4 (a,b,c,d)) = sqrt (a*a + b*b + c*c + d*d)
- normalize vec@(Vec4 (a,b,c,d)) =
- let n = norm vec in Vec4 (a/n,b/n,c/n,d/n)
-
- cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
- cross (Vec3 (u1,u2,u3)) (Vec3 (v1,v2,v3)) =
- Vec3 ( u2*v3 - u3*v2,
- u3*v1 - u1*v3,
- u1*v2 - u2*v1 )
- (×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
- (×) = cross
-
- lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
- lookAtMatrix e@(Vec3 (ex,ey,ez)) c u =
- let f@(Vec3 (fx,fy,fz)) = normalize (c <-> e)
- s@(Vec3 (sx,sy,sz)) = normalize (f × u)
- u'@(Vec3 (ux,uy,uz)) = s × f in
- Matrix (sx, ux, -fx, 0,
- sy, uy, -fy, 0,
- sz, uz, -fz, 0,
- -(s<.>e) , -(u'<.>e), (f<.>e), 1 )
-
- perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
- {- as close to copied from glm as possible -}
- perspectiveMatrix fov asp zn zf =
- let tanHalfFovy = tangent (Degrees fov/2)
- res00 = 1 / (asp * tanHalfFovy)
- res11 = 1 / tanHalfFovy
- res22 = - (zf + zn) / (zf - zn)
- res23 = - 1
- res32 = - (2 * zf * zn) / (zf - zn) in
- trace ("res22=" ++ (show res22)) $
- Matrix (res00, 0, 0, 0,
- 0, res11, 0, 0,
- 0, 0, res22, res23,
- 0, 0, res32, 0)
-
- class VectorMatrix vecT matT where
- vTranslate :: matT -> vecT -> matT
- (-*|) :: matT -> vecT -> vecT
-
- instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
- vTranslate (Matrix3 (a00,a01,a02,
- a10,a11,a12,
- a20,a21,a22)) (Vec3 (a,b,c)) =
- Matrix3 (a00,a01,a02+a,
- a10,a11,a12+b,
- a20,a21,a22+c)
-
- (Matrix3 (a00,a01,a02,
- a10,a11,a12,
- a20,a21,a22)) -*| (Vec3 (a,b,c)) =
- Vec3 (a00 * a + a01 * b + a02 * c,
- a10 * a + a11 * b + a12 * c,
- a20 * a + a21 * b + a22 * c )
-
-
-
-
- instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
- vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
- mat -*| tmp = glslMatMul mat tmp
-
- glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
- glslMatMul (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) (Vec4 (v0,v1,v2,v3)) =
- Vec4 ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
- v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
- v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
- v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33 )
-
- (==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
- (==>) = glslMatTranslate
- glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
- glslMatTranslate
- mat@(Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) vec =
- let (Vec4 (v0,v1,v2,v3)) = mat -*| vec in
- (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30+v0,m31+v1,m32+v2,m33+v3))
-
+
+import Data.Angle
+import Debug.Trace
+import Graphics.Glyph.Mat4
+import Graphics.Rendering.OpenGL (GLfloat, Uniform, UniformComponent, Vertex3 (..), uniform)
+import qualified Graphics.Rendering.OpenGL as GL
+
+data Vec2 a = Vec2 (a, a) deriving (Show)
+
+data Vec3 a = Vec3 (a, a, a) deriving (Show)
+
+data Vec4 a = Vec4 (a, a, a, a) deriving (Show)
+
+instance UniformComponent a => Uniform (Vec3 a) where
+ uniform loc =
+ GL.makeStateVar
+ ( do
+ (Vertex3 x y z) <-
+ GL.get (uniform loc)
+ return (Vec3 (x, y, z))
+ )
+ (\(Vec3 (x, y, z)) -> uniform loc GL.$= Vertex3 x y z)
+
+class (Floating flT) => Vector flT b where
+ (<+>) :: b flT -> b flT -> b flT
+ (<->) :: b flT -> b flT -> b flT
+ norm :: b flT -> flT
+ normalize :: b flT -> b flT
+ vDot :: b flT -> b flT -> flT
+ vScale :: flT -> b flT -> b flT
+
+(<.>) :: (Vector a b) => b a -> b a -> a
+(<.>) = vDot
+
+(|||) :: (Vector a b) => b a -> a
+(|||) = norm
+
+instance (Floating flT) => Vector flT Vec2 where
+ (<+>) (Vec2 (a, b)) (Vec2 (c, d)) = Vec2 (a + c, b + d)
+ (<->) (Vec2 (a, b)) (Vec2 (c, d)) = Vec2 (a - c, b - d)
+ vDot (Vec2 (a, b)) (Vec2 (c, d)) = a * c + b * d
+ vScale c (Vec2 (a, b)) = Vec2 (a * c, b * c)
+ norm (Vec2 (a, b)) = sqrt (a * a + b * b)
+ normalize vec@(Vec2 (a, b)) =
+ let n = norm vec in Vec2 (a / n, b / n)
+
+instance (Floating flT) => Vector flT Vec3 where
+ (<+>) (Vec3 (a, b, c)) (Vec3 (d, e, f)) = Vec3 (a + d, b + e, c + f)
+ (<->) (Vec3 (a, b, c)) (Vec3 (d, e, f)) = Vec3 (a - d, b - e, c - f)
+ vDot (Vec3 (a, b, c)) (Vec3 (d, e, f)) = a * d + b * e + c * f
+ vScale x (Vec3 (a, b, c)) = Vec3 (a * x, b * x, c * x)
+ norm (Vec3 (a, b, c)) = sqrt (a * a + b * b + c * c)
+ normalize vec@(Vec3 (a, b, c)) =
+ let n = norm vec in Vec3 (a / n, b / n, c / n)
+
+instance (Floating flT) => Vector flT Vec4 where
+ (<+>) (Vec4 (a, b, c, g)) (Vec4 (d, e, f, h)) = Vec4 (a + d, b + e, c + f, g + h)
+ (<->) (Vec4 (a, b, c, g)) (Vec4 (d, e, f, h)) = Vec4 (a - d, b - e, c - f, g - h)
+ vDot (Vec4 (a, b, c, g)) (Vec4 (d, e, f, h)) = a * d + b * e + c * f + g * h
+ vScale x (Vec4 (a, b, c, d)) = Vec4 (a * x, b * x, c * x, d * x)
+ norm (Vec4 (a, b, c, d)) = sqrt (a * a + b * b + c * c + d * d)
+ normalize vec@(Vec4 (a, b, c, d)) =
+ let n = norm vec in Vec4 (a / n, b / n, c / n, d / n)
+
+cross :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+cross (Vec3 (u1, u2, u3)) (Vec3 (v1, v2, v3)) =
+ Vec3
+ ( u2 * v3 - u3 * v2,
+ u3 * v1 - u1 * v3,
+ u1 * v2 - u2 * v1
+ )
+
+(×) :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a
+(×) = cross
+
+lookAtMatrix :: Vec3 GLfloat -> Vec3 GLfloat -> Vec3 GLfloat -> Mat4 GLfloat
+lookAtMatrix e@(Vec3 (ex, ey, ez)) c u =
+ let f@(Vec3 (fx, fy, fz)) = normalize (c <-> e)
+ s@(Vec3 (sx, sy, sz)) = normalize (f × u)
+ u'@(Vec3 (ux, uy, uz)) = s × f
+ in Matrix
+ ( sx,
+ ux,
+ - fx,
+ 0,
+ sy,
+ uy,
+ - fy,
+ 0,
+ sz,
+ uz,
+ - fz,
+ 0,
+ - (s <.> e),
+ - (u' <.> e),
+ (f <.> e),
+ 1
+ )
+
+perspectiveMatrix :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Mat4 GLfloat
+{- as close to copied from glm as possible -}
+perspectiveMatrix fov asp zn zf =
+ let tanHalfFovy = tangent (Degrees fov / 2)
+ res00 = 1 / (asp * tanHalfFovy)
+ res11 = 1 / tanHalfFovy
+ res22 = - (zf + zn) / (zf - zn)
+ res23 = - 1
+ res32 = - (2 * zf * zn) / (zf - zn)
+ in trace ("res22=" ++ (show res22)) $
+ Matrix
+ ( res00,
+ 0,
+ 0,
+ 0,
+ 0,
+ res11,
+ 0,
+ 0,
+ 0,
+ 0,
+ res22,
+ res23,
+ 0,
+ 0,
+ res32,
+ 0
+ )
+
+class VectorMatrix vecT matT where
+ vTranslate :: matT -> vecT -> matT
+ (-*|) :: matT -> vecT -> vecT
+
+instance (Num a) => VectorMatrix (Vec3 a) (Mat3 a) where
+ vTranslate
+ ( Matrix3
+ ( a00,
+ a01,
+ a02,
+ a10,
+ a11,
+ a12,
+ a20,
+ a21,
+ a22
+ )
+ )
+ (Vec3 (a, b, c)) =
+ Matrix3
+ ( a00,
+ a01,
+ a02 + a,
+ a10,
+ a11,
+ a12 + b,
+ a20,
+ a21,
+ a22 + c
+ )
+
+ ( Matrix3
+ ( a00,
+ a01,
+ a02,
+ a10,
+ a11,
+ a12,
+ a20,
+ a21,
+ a22
+ )
+ )
+ -*| (Vec3 (a, b, c)) =
+ Vec3
+ ( a00 * a + a01 * b + a02 * c,
+ a10 * a + a11 * b + a12 * c,
+ a20 * a + a21 * b + a22 * c
+ )
+
+instance (Num a) => VectorMatrix (Vec4 a) (Mat4 a) where
+ vTranslate mat (Vec4 tmp) = translateMat4 mat tmp
+ mat -*| tmp = glslMatMul mat tmp
+
+glslMatMul :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a
+glslMatMul
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ (Vec4 (v0, v1, v2, v3)) =
+ Vec4
+ ( v0 * m00 + v1 * m10 + v2 * m20 + v3 * m30,
+ v0 * m01 + v1 * m11 + v2 * m21 + v3 * m31,
+ v0 * m02 + v1 * m12 + v2 * m22 + v3 * m32,
+ v0 * m03 + v1 * m13 + v2 * m23 + v3 * m33
+ )
+
+(==>) :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+(==>) = glslMatTranslate
+
+glslMatTranslate :: (Num a) => Mat4 a -> Vec4 a -> Mat4 a
+glslMatTranslate
+ mat@( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ vec =
+ let (Vec4 (v0, v1, v2, v3)) = mat -*| vec
+ in ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30 + v0,
+ m31 + v1,
+ m32 + v2,
+ m33 + v3
+ )
+ )
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
index 239007d..ef83cd8 100644
--- a/Graphics/Glyph/GlyphObject.hs
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -1,12 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
-module Graphics.Glyph.GlyphObject (
- GlyphObject(..),
+module Graphics.Glyph.GlyphObject
+ ( GlyphObject (..),
getBufferObject,
getCompiledData,
getVertexAttribute,
getNormalAttribute,
- getColorAttribute ,
+ getColorAttribute,
getTextureAttribute,
getResources,
getSetupRoutine,
@@ -16,41 +16,44 @@ module Graphics.Glyph.GlyphObject (
setCompiledData,
setVertexAttribute,
setNormalAttribute,
- setColorAttribute ,
+ setColorAttribute,
setTextureAttribute,
setResources,
setSetupRoutine,
setTeardownRoutine,
setPrimitiveMode,
- prepare, teardown,
- Drawable, draw, newGlyphObject,
- newDefaultGlyphObject
-) where
+ prepare,
+ teardown,
+ Drawable,
+ draw,
+ newGlyphObject,
+ newDefaultGlyphObject,
+ )
+where
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL
-import Control.Monad
-import Control.Applicative
-import Data.Maybe
-
class Drawable a where
- -- mvMat -> pMat -> obj -> IO ()
- draw :: a -> IO ()
+ -- mvMat -> pMat -> obj -> IO ()
+ draw :: a -> IO ()
-data GlyphObject a = GlyphObject {
- bufferObject :: BufferObject, -- buffer
+data GlyphObject a = GlyphObject
+ { bufferObject :: BufferObject, -- buffer
compiledData :: (CompiledBuild GLfloat), -- compiled data
vertexAttribute :: AttribLocation, -- vertex attribute
normalAttribute :: (Maybe AttribLocation), -- normal attrib
- colorAttribute :: (Maybe AttribLocation), -- color attrib
+ colorAttribute :: (Maybe AttribLocation), -- color attrib
textureAttribute :: (Maybe AttribLocation), -- texture attrib
resources :: a, -- Resources
setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
primitiveMode :: PrimitiveMode
-}
+ }
getBufferObject :: GlyphObject a -> BufferObject
getBufferObject = bufferObject
@@ -64,8 +67,8 @@ getVertexAttribute = vertexAttribute
getNormalAttribute :: GlyphObject a -> (Maybe AttribLocation)
getNormalAttribute = normalAttribute
-getColorAttribute :: GlyphObject a -> (Maybe AttribLocation)
-getColorAttribute = colorAttribute
+getColorAttribute :: GlyphObject a -> (Maybe AttribLocation)
+getColorAttribute = colorAttribute
getTextureAttribute :: GlyphObject a -> (Maybe AttribLocation)
getTextureAttribute = textureAttribute
@@ -83,104 +86,109 @@ getPrimitiveMode :: GlyphObject a -> PrimitiveMode
getPrimitiveMode = primitiveMode
setBufferObject :: GlyphObject a -> BufferObject -> GlyphObject a
-setBufferObject o a = o { bufferObject = a }
+setBufferObject o a = o {bufferObject = a}
setCompiledData :: GlyphObject a -> (CompiledBuild GLfloat) -> GlyphObject a
-setCompiledData o a = o { compiledData = a }
+setCompiledData o a = o {compiledData = a}
setVertexAttribute :: GlyphObject a -> AttribLocation -> GlyphObject a
-setVertexAttribute o a = o { vertexAttribute = a }
+setVertexAttribute o a = o {vertexAttribute = a}
setNormalAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setNormalAttribute o a = o { normalAttribute = a }
+setNormalAttribute o a = o {normalAttribute = a}
-setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setColorAttribute o a = o { colorAttribute = a }
+setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
+setColorAttribute o a = o {colorAttribute = a}
setTextureAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
-setTextureAttribute o a = o { textureAttribute = a }
+setTextureAttribute o a = o {textureAttribute = a}
setResources :: GlyphObject a -> a -> GlyphObject a
-setResources o a = o { resources = a }
+setResources o a = o {resources = a}
setSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
-setSetupRoutine o a = o { setupRoutine = a }
+setSetupRoutine o a = o {setupRoutine = a}
setTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
-setTeardownRoutine o a = o { teardownRoutine = a }
+setTeardownRoutine o a = o {teardownRoutine = a}
setPrimitiveMode :: GlyphObject a -> PrimitiveMode -> GlyphObject a
-setPrimitiveMode o a = o { primitiveMode = a }
-
-newGlyphObject :: Builder GLfloat x ->
- AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- Maybe AttribLocation ->
- a ->
- Maybe (GlyphObject a -> IO ()) ->
- Maybe (GlyphObject a -> IO ()) ->
- PrimitiveMode ->
- IO (GlyphObject a)
-
+setPrimitiveMode o a = o {primitiveMode = a}
+
+newGlyphObject ::
+ Builder GLfloat x ->
+ AttribLocation ->
+ Maybe AttribLocation ->
+ Maybe AttribLocation ->
+ Maybe AttribLocation ->
+ a ->
+ Maybe (GlyphObject a -> IO ()) ->
+ Maybe (GlyphObject a -> IO ()) ->
+ PrimitiveMode ->
+ IO (GlyphObject a)
newGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear mode = do
- compiled <- compilingBuilder builder
- buffer <- createBufferObject ArrayBuffer compiled
- return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup tear mode
+ compiled <- compilingBuilder builder
+ buffer <- createBufferObject ArrayBuffer compiled
+ return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup tear mode
-prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-prepare a b = a { setupRoutine = (Just b) }
+prepare :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
+prepare a b = a {setupRoutine = (Just b)}
-teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-teardown a b = a { teardownRoutine = Just b }
+teardown :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
+teardown a b = a {teardownRoutine = Just b}
instance Drawable (GlyphObject a) where
- draw obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown p) = do
- {- Setup whatever we need for the object to draw itself -}
- maybe (return ()) (apply obj) setup
-
- {- Get the array descriptors for the possible
- - parts -}
- let vad = vertexArrayDescriptor co
- let nad = normalArrayDescriptor co
- let cad = colorArrayDescriptor co
- let tad = textureArrayDescriptor co
-
- bindBuffer ArrayBuffer $= Just bo
- let enabled = catMaybes $
- map liftMaybe [(Just vAttr,Just vad), (nAttr, nad), (cAttr,cad), (tAttr,tad)]
-
- forM_ enabled $ \(attr, ad) -> do
- vertexAttribPointer attr $= (ToFloat, ad)
- vertexAttribArray attr $= Enabled
-
- drawArrays p 0 (bufferLength co)
-
- forM_ enabled $ \(attr, _) -> do
- vertexAttribArray attr $= Disabled
-
- {- Tear down whatever the object needs -}
- maybe (return ()) (apply obj) tearDown
- where liftMaybe (Just a, Just b) = Just (a,b)
- liftMaybe _ = Nothing
- apply obj' f = f obj'
+ draw obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown p) = do
+ {- Setup whatever we need for the object to draw itself -}
+ maybe (return ()) (apply obj) setup
+
+ {- Get the array descriptors for the possible
+ - parts -}
+ let vad = vertexArrayDescriptor co
+ let nad = normalArrayDescriptor co
+ let cad = colorArrayDescriptor co
+ let tad = textureArrayDescriptor co
+
+ bindBuffer ArrayBuffer $= Just bo
+ let enabled =
+ catMaybes $
+ map liftMaybe [(Just vAttr, Just vad), (nAttr, nad), (cAttr, cad), (tAttr, tad)]
+
+ forM_ enabled $ \(attr, ad) -> do
+ vertexAttribPointer attr $= (ToFloat, ad)
+ vertexAttribArray attr $= Enabled
+
+ drawArrays p 0 (bufferLength co)
+
+ forM_ enabled $ \(attr, _) -> do
+ vertexAttribArray attr $= Disabled
+
+ {- Tear down whatever the object needs -}
+ maybe (return ()) (apply obj) tearDown
+ where
+ liftMaybe (Just a, Just b) = Just (a, b)
+ liftMaybe _ = Nothing
+ apply obj' f = f obj'
instance (Show a) => Show (GlyphObject a) where
- show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ p) =
- "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++
- " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++" PrimitiveMode="++!p++"]"
-
+ show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ p) =
+ "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr
+ ++ " normalAttr=" ++! nAttr
+ ++ " colorAttr=" ++! cAttr
+ ++ " textureAttr=" ++! tAttr
+ ++ " res=" ++! res
+ ++ " PrimitiveMode=" ++! p
+ ++ "]"
newDefaultGlyphObject :: Builder GLfloat x -> a -> IO (GlyphObject a)
newDefaultGlyphObject builder resources =
- newGlyphObject builder
- (AttribLocation 0) -- vertex
- (Just $ AttribLocation 1) -- normal
- (Just $ AttribLocation 2) -- color
- (Just $ AttribLocation 3) -- texture
- resources
- Nothing -- setup
- Nothing -- teardown
- Triangles -- primitive
-
-
+ newGlyphObject
+ builder
+ (AttribLocation 0) -- vertex
+ (Just $ AttribLocation 1) -- normal
+ (Just $ AttribLocation 2) -- color
+ (Just $ AttribLocation 3) -- texture
+ resources
+ Nothing -- setup
+ Nothing -- teardown
+ Triangles -- primitive
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
index 6581126..9ef922f 100644
--- a/Graphics/Glyph/Mat4.hs
+++ b/Graphics/Glyph/Mat4.hs
@@ -1,224 +1,430 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
module Graphics.Glyph.Mat4 where
import Control.Monad
-
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
-
-import Graphics.Rendering.OpenGL
import Graphics.GL.Compatibility30
--- import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.Rendering.OpenGL
-data Mat4 a = Matrix (a,a,a,a,
- a,a,a,a,
- a,a,a,a,
- a,a,a,a) | IdentityMatrix
+-- import Graphics.Rendering.OpenGL.Raw.Core31
-data Mat3 a = Matrix3 ( a,a,a,
- a,a,a,
- a,a,a ) | IdentityMatrix3
+data Mat4 a
+ = Matrix
+ ( a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a
+ )
+ | IdentityMatrix
+
+data Mat3 a
+ = Matrix3
+ ( a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a,
+ a
+ )
+ | IdentityMatrix3
class StorableMatrix t a where
- fromList :: [t] -> a t
- toPtr :: a t -> (Ptr t -> IO b) -> IO b
- fromPtr :: Ptr t -> (a t -> IO b) -> IO b
+ fromList :: [t] -> a t
+ toPtr :: a t -> (Ptr t -> IO b) -> IO b
+ fromPtr :: Ptr t -> (a t -> IO b) -> IO b
instance (Storable t) => StorableMatrix t Mat4 where
- fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:m10:m11:m12:m13:m14:m15:m16:_) =
- Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)
+ fromList (m1 : m2 : m3 : m4 : m5 : m6 : m7 : m8 : m9 : m10 : m11 : m12 : m13 : m14 : m15 : m16 : _) =
+ Matrix (m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14, m15, m16)
- toPtr (Matrix (m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16)) fun =
- allocaArray 16 $ \ptr -> do
- pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9,m10,m11,m12,m13,m14,m15,m16]
- fun ptr
+ toPtr (Matrix (m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14, m15, m16)) fun =
+ allocaArray 16 $ \ptr -> do
+ pokeArray ptr [m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14, m15, m16]
+ fun ptr
- fromPtr ptr f = peekArray 16 ptr >>= f . fromList
+ fromPtr ptr f = peekArray 16 ptr >>= f . fromList
instance (Storable t) => StorableMatrix t Mat3 where
- fromList (m1:m2:m3:m4:m5:m6:m7:m8:m9:_) =
- Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)
+ fromList (m1 : m2 : m3 : m4 : m5 : m6 : m7 : m8 : m9 : _) =
+ Matrix3 (m1, m2, m3, m4, m5, m6, m7, m8, m9)
- toPtr (Matrix3 (m1,m2,m3,m4,m5,m6,m7,m8,m9)) fun =
- allocaArray 9 $ \ptr -> do
- pokeArray ptr [m1,m2,m3,m4,m5,m6,m7,m8,m9]
- fun ptr
+ toPtr (Matrix3 (m1, m2, m3, m4, m5, m6, m7, m8, m9)) fun =
+ allocaArray 9 $ \ptr -> do
+ pokeArray ptr [m1, m2, m3, m4, m5, m6, m7, m8, m9]
+ fun ptr
- fromPtr ptr f = peekArray 9 ptr >>= f . fromList
+ fromPtr ptr f = peekArray 9 ptr >>= f . fromList
instance Uniform (Mat4 GLfloat) where
- uniform (UniformLocation loc) = makeStateVar getter setter
- where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix4fv loc 1 (fromIntegral GL_FALSE) ptr
- getter :: IO (Mat4 GLfloat)
- getter = do
- pid <- liftM fromIntegral getCurrentProgram
- ( allocaArray 16 $ \buf -> do
- glGetUniformfv pid loc buf
- fromPtr buf return )
+ uniform (UniformLocation loc) = makeStateVar getter setter
+ where
+ setter mat = toPtr mat $ \ptr ->
+ glUniformMatrix4fv loc 1 (fromIntegral GL_FALSE) ptr
+ getter :: IO (Mat4 GLfloat)
+ getter = do
+ pid <- liftM fromIntegral getCurrentProgram
+ ( allocaArray 16 $ \buf -> do
+ glGetUniformfv pid loc buf
+ fromPtr buf return
+ )
instance Uniform (Mat3 GLfloat) where
- uniform (UniformLocation loc) = makeStateVar getter setter
- where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix3fv loc 1 (fromIntegral GL_FALSE) ptr
- getter :: IO (Mat3 GLfloat)
- getter = do
- pid <- liftM fromIntegral getCurrentProgram
- ( allocaArray 9 $ \buf -> do
- glGetUniformfv pid loc buf
- fromPtr buf return )
+ uniform (UniformLocation loc) = makeStateVar getter setter
+ where
+ setter mat = toPtr mat $ \ptr ->
+ glUniformMatrix3fv loc 1 (fromIntegral GL_FALSE) ptr
+ getter :: IO (Mat3 GLfloat)
+ getter = do
+ pid <- liftM fromIntegral getCurrentProgram
+ ( allocaArray 9 $ \buf -> do
+ glGetUniformfv pid loc buf
+ fromPtr buf return
+ )
getCurrentProgram :: IO GLint
getCurrentProgram = alloca $ \ptr -> glGetIntegerv GL_CURRENT_PROGRAM ptr >> peek ptr
instance (Show a) => Show (Mat4 a) where
- show IdentityMatrix =
- "[ 1 0 0 0\n" ++
- " 0 1 0 0\n" ++
- " 0 0 1 0\n" ++
- " 0 0 0 1 ]\n"
- show (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) =
- "["++! m00 ++ " " ++! m01 ++ " " ++! m02 ++ " " ++! m03 ++ "\n" ++
- " "++! m10 ++ " " ++! m11 ++ " " ++! m12 ++ " " ++! m13 ++ "\n" ++
- " "++! m20 ++ " " ++! m21 ++ " " ++! m22 ++ " " ++! m23 ++ "\n" ++
- " "++! m30 ++ " " ++! m31 ++ " " ++! m32 ++ " " ++! m33 ++ "]"
- where (++!) a = (a++) . show
-
-
-
-
-translateMat4 :: (Num a) => Mat4 a -> (a,a,a,a) -> Mat4 a
-translateMat4 IdentityMatrix x = translateMat4 (Matrix (1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1)) x
-translateMat4 (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) (v0,v1,v2,v3) =
- Matrix (m00,m01,m02,m03+v0,
- m10,m11,m12,m13+v1,
- m20,m21,m22,m23+v2,
- m30,m31,m32,m33+v3)
-
-applyMatrix :: (Num a) => Mat4 a -> (a,a,a,a) -> (a,a,a,a)
-applyMatrix (Matrix (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33)) (v0,v1,v2,v3) =
- ( v0 * m00 + v1 * m01 + v2 * m02 + v3 * m03,
- v0 * m10 + v1 * m11 + v2 * m12 + v3 * m13,
- v0 * m20 + v1 * m21 + v2 * m22 + v3 * m23,
- v0 * m30 + v1 * m31 + v2 * m32 + v3 * m33 )
-
+ show IdentityMatrix =
+ "[ 1 0 0 0\n"
+ ++ " 0 1 0 0\n"
+ ++ " 0 0 1 0\n"
+ ++ " 0 0 0 1 ]\n"
+ show (Matrix (m00, m01, m02, m03, m10, m11, m12, m13, m20, m21, m22, m23, m30, m31, m32, m33)) =
+ "[" ++! m00 ++ " " ++! m01 ++ " " ++! m02 ++ " " ++! m03 ++ "\n"
+ ++ " " ++! m10
+ ++ " " ++! m11
+ ++ " " ++! m12
+ ++ " " ++! m13
+ ++ "\n"
+ ++ " " ++! m20
+ ++ " " ++! m21
+ ++ " " ++! m22
+ ++ " " ++! m23
+ ++ "\n"
+ ++ " " ++! m30
+ ++ " " ++! m31
+ ++ " " ++! m32
+ ++ " " ++! m33
+ ++ "]"
+ where
+ (++!) a = (a ++) . show
+
+translateMat4 :: (Num a) => Mat4 a -> (a, a, a, a) -> Mat4 a
+translateMat4 IdentityMatrix x = translateMat4 (Matrix (1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1)) x
+translateMat4
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ (v0, v1, v2, v3) =
+ Matrix
+ ( m00,
+ m01,
+ m02,
+ m03 + v0,
+ m10,
+ m11,
+ m12,
+ m13 + v1,
+ m20,
+ m21,
+ m22,
+ m23 + v2,
+ m30,
+ m31,
+ m32,
+ m33 + v3
+ )
+
+applyMatrix :: (Num a) => Mat4 a -> (a, a, a, a) -> (a, a, a, a)
+applyMatrix
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ )
+ (v0, v1, v2, v3) =
+ ( v0 * m00 + v1 * m01 + v2 * m02 + v3 * m03,
+ v0 * m10 + v1 * m11 + v2 * m12 + v3 * m13,
+ v0 * m20 + v1 * m21 + v2 * m22 + v3 * m23,
+ v0 * m30 + v1 * m31 + v2 * m32 + v3 * m33
+ )
applyMatrix IdentityMatrix v = v
-scaleMatrix :: (Num a) => Mat4 a -> (a,a,a) -> Mat4 a
-scaleMatrix IdentityMatrix (a,b,c) = Matrix ( a,0,0,0,
- 0,b,0,0,
- 0,0,c,0,
- 0,0,0,1)
-
-scaleMatrix (Matrix (m00,m01,m02,m03,m10,m11,m12,m13,m20,m21,m22,m23,m30,m31,m32,m33)) (a,b,c)
- = Matrix ( m00*a,m01,m02,m03,
- m10,m11*b,m12,m13,
- m20,m21,m22*c,m23,
- m30,m31,m32,m33)
+scaleMatrix :: (Num a) => Mat4 a -> (a, a, a) -> Mat4 a
+scaleMatrix IdentityMatrix (a, b, c) =
+ Matrix
+ ( a,
+ 0,
+ 0,
+ 0,
+ 0,
+ b,
+ 0,
+ 0,
+ 0,
+ 0,
+ c,
+ 0,
+ 0,
+ 0,
+ 0,
+ 1
+ )
+scaleMatrix (Matrix (m00, m01, m02, m03, m10, m11, m12, m13, m20, m21, m22, m23, m30, m31, m32, m33)) (a, b, c) =
+ Matrix
+ ( m00 * a,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11 * b,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22 * c,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
applyMatrixToList :: (Num a) => Mat4 a -> [a] -> [a]
applyMatrixToList IdentityMatrix t = t
-applyMatrixToList mat (a:b:c:xs) =
- let (a',b',c',_) = applyMatrix mat (a,b,c,1) in
- (a':b':c':applyMatrixToList mat xs)
-
+applyMatrixToList mat (a : b : c : xs) =
+ let (a', b', c', _) = applyMatrix mat (a, b, c, 1)
+ in (a' : b' : c' : applyMatrixToList mat xs)
applyMatrixToList _ _ = []
mulMatrix4 :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
mulMatrix4 IdentityMatrix a = a
mulMatrix4 a IdentityMatrix = a
mulMatrix4
- (Matrix (a00,a01,a02,a03,
- a10,a11,a12,a13,
- a20,a21,a22,a23,
- a30,a31,a32,a33 ))
- (Matrix (b00,b01,b02,b03,
- b10,b11,b12,b13,
- b20,b21,b22,b23,
- b30,b31,b32,b33 )) =
- Matrix (b00*a00+b10*a01+b20*a02+b30*a03,
- b01*a00+b11*a01+b21*a02+b31*a03,
- b02*a00+b12*a01+b22*a02+b32*a03,
- b03*a00+b13*a01+b23*a02+b33*a03,
-
- b00*a10+b10*a11+b20*a12+b30*a13,
- b01*a10+b11*a11+b21*a12+b31*a13,
- b02*a10+b12*a11+b22*a12+b32*a13,
- b03*a10+b13*a11+b23*a12+b33*a13,
-
- b00*a20+b10*a21+b20*a22+b30*a23,
- b01*a20+b11*a21+b21*a22+b31*a23,
- b02*a20+b12*a21+b22*a22+b32*a23,
- b03*a20+b13*a21+b23*a22+b33*a23,
-
- b00*a30+b10*a31+b20*a32+b30*a33,
- b01*a30+b11*a31+b21*a32+b31*a33,
- b02*a30+b12*a31+b22*a32+b32*a33,
- b03*a30+b13*a31+b23*a32+b33*a33 )
+ ( Matrix
+ ( a00,
+ a01,
+ a02,
+ a03,
+ a10,
+ a11,
+ a12,
+ a13,
+ a20,
+ a21,
+ a22,
+ a23,
+ a30,
+ a31,
+ a32,
+ a33
+ )
+ )
+ ( Matrix
+ ( b00,
+ b01,
+ b02,
+ b03,
+ b10,
+ b11,
+ b12,
+ b13,
+ b20,
+ b21,
+ b22,
+ b23,
+ b30,
+ b31,
+ b32,
+ b33
+ )
+ ) =
+ Matrix
+ ( b00 * a00 + b10 * a01 + b20 * a02 + b30 * a03,
+ b01 * a00 + b11 * a01 + b21 * a02 + b31 * a03,
+ b02 * a00 + b12 * a01 + b22 * a02 + b32 * a03,
+ b03 * a00 + b13 * a01 + b23 * a02 + b33 * a03,
+ b00 * a10 + b10 * a11 + b20 * a12 + b30 * a13,
+ b01 * a10 + b11 * a11 + b21 * a12 + b31 * a13,
+ b02 * a10 + b12 * a11 + b22 * a12 + b32 * a13,
+ b03 * a10 + b13 * a11 + b23 * a12 + b33 * a13,
+ b00 * a20 + b10 * a21 + b20 * a22 + b30 * a23,
+ b01 * a20 + b11 * a21 + b21 * a22 + b31 * a23,
+ b02 * a20 + b12 * a21 + b22 * a22 + b32 * a23,
+ b03 * a20 + b13 * a21 + b23 * a22 + b33 * a23,
+ b00 * a30 + b10 * a31 + b20 * a32 + b30 * a33,
+ b01 * a30 + b11 * a31 + b21 * a32 + b31 * a33,
+ b02 * a30 + b12 * a31 + b22 * a32 + b32 * a33,
+ b03 * a30 + b13 * a31 + b23 * a32 + b33 * a33
+ )
(|*|) :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a
(|*|) = mulMatrix4
transpose4 :: Mat4 a -> Mat4 a
-transpose4 (Matrix
- (m00,m01,m02,m03,
- m10,m11,m12,m13,
- m20,m21,m22,m23,
- m30,m31,m32,m33 )) = (Matrix (m00, m10, m20, m30,
- m01, m11, m21, m31,
- m02, m12, m22, m32,
- m03, m13, m23, m33))
+transpose4
+ ( Matrix
+ ( m00,
+ m01,
+ m02,
+ m03,
+ m10,
+ m11,
+ m12,
+ m13,
+ m20,
+ m21,
+ m22,
+ m23,
+ m30,
+ m31,
+ m32,
+ m33
+ )
+ ) =
+ ( Matrix
+ ( m00,
+ m10,
+ m20,
+ m30,
+ m01,
+ m11,
+ m21,
+ m31,
+ m02,
+ m12,
+ m22,
+ m32,
+ m03,
+ m13,
+ m23,
+ m33
+ )
+ )
+
scale4 :: (Num a) => a -> Mat4 a -> Mat4 a
-scale4 n (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- Matrix (m11*n,m12*n,m13*n,m14*n,m21*n,m22*n,m23*n,m24*n,m31*n,m32*n,m33*n,m34*n,m41*n,m42*n,m43*n,m44*n)
+scale4 n (Matrix (m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, m41, m42, m43, m44)) =
+ Matrix (m11 * n, m12 * n, m13 * n, m14 * n, m21 * n, m22 * n, m23 * n, m24 * n, m31 * n, m32 * n, m33 * n, m34 * n, m41 * n, m42 * n, m43 * n, m44 * n)
det4 :: (Num a) => Mat4 a -> a
-det4 (Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- m11*m22*m33*m44 + m11*m23*m34*m42 + m11*m24*m32*m43
- + m12*m21*m34*m43 + m12*m23*m31*m44 + m12*m24*m33*m41
- + m13*m21*m32*m44 + m13*m22*m34*m41 + m13*m24*m31*m42
- + m14*m21*m33*m42 + m14*m22*m31*m43 + m14*m23*m32*m41
- - m11*m22*m34*m43 - m11*m23*m32*m44 - m11*m24*m33*m42
- - m12*m21*m33*m44 - m12*m23*m34*m41 - m12*m24*m31*m43
- - m13*m21*m34*m42 - m13*m22*m31*m44 - m13*m24*m32*m41
- - m14*m21*m32*m43 - m14*m22*m33*m41 - m14*m23*m31*m42
-
-inv4 :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat4 a)
-inv4 mat@(Matrix (m11,m12,m13,m14,m21,m22,m23,m24,m31,m32,m33,m34,m41,m42,m43,m44)) =
- let b11 = m22*m33*m44 + m23*m34*m42 + m24*m32*m43 - m22*m34*m43 - m23*m32*m44 - m24*m33*m42
- b12 = m12*m34*m43 + m13*m32*m44 + m14*m33*m42 - m12*m33*m44 - m13*m34*m42 - m14*m32*m43
- b13 = m12*m23*m44 + m13*m24*m42 + m14*m22*m43 - m12*m24*m43 - m13*m22*m44 - m14*m23*m42
- b14 = m12*m24*m33 + m13*m22*m34 + m14*m23*m32 - m12*m23*m34 - m13*m24*m32 - m14*m22*m33
- b21 = m21*m34*m43 + m23*m31*m44 + m24*m33*m41 - m21*m33*m44 - m23*m34*m41 - m24*m31*m43
- b22 = m11*m33*m44 + m13*m34*m41 + m14*m31*m43 - m11*m34*m43 - m13*m31*m44 - m14*m33*m41
- b23 = m11*m24*m43 + m13*m21*m44 + m14*m23*m41 - m11*m23*m44 - m13*m24*m41 - m14*m21*m43
- b24 = m11*m23*m34 + m13*m24*m31 + m14*m21*m33 - m11*m24*m33 - m13*m21*m34 - m14*m23*m31
- b31 = m21*m32*m44 + m22*m34*m41 + m24*m31*m42 - m21*m34*m42 - m22*m31*m44 - m24*m32*m41
- b32 = m11*m34*m42 + m12*m31*m44 + m14*m32*m41 - m11*m32*m44 - m12*m34*m41 - m14*m31*m42
- b33 = m11*m22*m44 + m12*m24*m41 + m14*m21*m42 - m11*m24*m42 - m12*m21*m44 - m14*m22*m41
- b34 = m11*m24*m32 + m12*m21*m34 + m14*m22*m31 - m11*m22*m34 - m12*m24*m31 - m14*m21*m32
- b41 = m21*m33*m42 + m22*m31*m43 + m23*m32*m41 - m21*m32*m43 - m22*m33*m41 - m23*m31*m42
- b42 = m11*m32*m43 + m12*m33*m41 + m13*m31*m42 - m11*m33*m42 - m12*m31*m43 - m13*m32*m41
- b43 = m11*m23*m42 + m12*m21*m43 + m13*m22*m41 - m11*m22*m43 - m12*m23*m41 - m13*m21*m42
- b44 = m11*m22*m33 + m12*m23*m31 + m13*m21*m32 - m11*m23*m32 - m12*m21*m33 - m13*m22*m31 in
- case det4 mat of
- 0 -> Nothing
- det -> Just $ (1 / det) `scale4` Matrix (b11,b12,b13,b14,b21,b22,b23,b24,b31,b32,b33,b34,b41,b42,b43,b44)
+det4 (Matrix (m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, m41, m42, m43, m44)) =
+ m11 * m22 * m33 * m44 + m11 * m23 * m34 * m42 + m11 * m24 * m32 * m43
+ + m12 * m21 * m34 * m43
+ + m12 * m23 * m31 * m44
+ + m12 * m24 * m33 * m41
+ + m13 * m21 * m32 * m44
+ + m13 * m22 * m34 * m41
+ + m13 * m24 * m31 * m42
+ + m14 * m21 * m33 * m42
+ + m14 * m22 * m31 * m43
+ + m14 * m23 * m32 * m41
+ - m11 * m22 * m34 * m43
+ - m11 * m23 * m32 * m44
+ - m11 * m24 * m33 * m42
+ - m12 * m21 * m33 * m44
+ - m12 * m23 * m34 * m41
+ - m12 * m24 * m31 * m43
+ - m13 * m21 * m34 * m42
+ - m13 * m22 * m31 * m44
+ - m13 * m24 * m32 * m41
+ - m14 * m21 * m32 * m43
+ - m14 * m22 * m33 * m41
+ - m14 * m23 * m31 * m42
+
+inv4 :: (Floating a, Eq a) => Mat4 a -> Maybe (Mat4 a)
+inv4 mat@(Matrix (m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, m41, m42, m43, m44)) =
+ let b11 = m22 * m33 * m44 + m23 * m34 * m42 + m24 * m32 * m43 - m22 * m34 * m43 - m23 * m32 * m44 - m24 * m33 * m42
+ b12 = m12 * m34 * m43 + m13 * m32 * m44 + m14 * m33 * m42 - m12 * m33 * m44 - m13 * m34 * m42 - m14 * m32 * m43
+ b13 = m12 * m23 * m44 + m13 * m24 * m42 + m14 * m22 * m43 - m12 * m24 * m43 - m13 * m22 * m44 - m14 * m23 * m42
+ b14 = m12 * m24 * m33 + m13 * m22 * m34 + m14 * m23 * m32 - m12 * m23 * m34 - m13 * m24 * m32 - m14 * m22 * m33
+ b21 = m21 * m34 * m43 + m23 * m31 * m44 + m24 * m33 * m41 - m21 * m33 * m44 - m23 * m34 * m41 - m24 * m31 * m43
+ b22 = m11 * m33 * m44 + m13 * m34 * m41 + m14 * m31 * m43 - m11 * m34 * m43 - m13 * m31 * m44 - m14 * m33 * m41
+ b23 = m11 * m24 * m43 + m13 * m21 * m44 + m14 * m23 * m41 - m11 * m23 * m44 - m13 * m24 * m41 - m14 * m21 * m43
+ b24 = m11 * m23 * m34 + m13 * m24 * m31 + m14 * m21 * m33 - m11 * m24 * m33 - m13 * m21 * m34 - m14 * m23 * m31
+ b31 = m21 * m32 * m44 + m22 * m34 * m41 + m24 * m31 * m42 - m21 * m34 * m42 - m22 * m31 * m44 - m24 * m32 * m41
+ b32 = m11 * m34 * m42 + m12 * m31 * m44 + m14 * m32 * m41 - m11 * m32 * m44 - m12 * m34 * m41 - m14 * m31 * m42
+ b33 = m11 * m22 * m44 + m12 * m24 * m41 + m14 * m21 * m42 - m11 * m24 * m42 - m12 * m21 * m44 - m14 * m22 * m41
+ b34 = m11 * m24 * m32 + m12 * m21 * m34 + m14 * m22 * m31 - m11 * m22 * m34 - m12 * m24 * m31 - m14 * m21 * m32
+ b41 = m21 * m33 * m42 + m22 * m31 * m43 + m23 * m32 * m41 - m21 * m32 * m43 - m22 * m33 * m41 - m23 * m31 * m42
+ b42 = m11 * m32 * m43 + m12 * m33 * m41 + m13 * m31 * m42 - m11 * m33 * m42 - m12 * m31 * m43 - m13 * m32 * m41
+ b43 = m11 * m23 * m42 + m12 * m21 * m43 + m13 * m22 * m41 - m11 * m22 * m43 - m12 * m23 * m41 - m13 * m21 * m42
+ b44 = m11 * m22 * m33 + m12 * m23 * m31 + m13 * m21 * m32 - m11 * m23 * m32 - m12 * m21 * m33 - m13 * m22 * m31
+ in case det4 mat of
+ 0 -> Nothing
+ det -> Just $ (1 / det) `scale4` Matrix (b11, b12, b13, b14, b21, b22, b23, b24, b31, b32, b33, b34, b41, b42, b43, b44)
trunc4 :: Mat4 a -> Mat3 a
-trunc4 (Matrix
- (m11,m12,m13,_,
- m21,m22,m23,_,
- m31,m32,m33,_,
- _ , _ , _ ,_)) = Matrix3 (m11,m12,m13,m21,m22,m23,m31,m32,m33)
-
-toNormalMatrix :: (Floating a,Eq a) => Mat4 a -> Maybe (Mat3 a)
+trunc4
+ ( Matrix
+ ( m11,
+ m12,
+ m13,
+ _,
+ m21,
+ m22,
+ m23,
+ _,
+ m31,
+ m32,
+ m33,
+ _,
+ _,
+ _,
+ _,
+ _
+ )
+ ) = Matrix3 (m11, m12, m13, m21, m22, m23, m31, m32, m33)
+
+toNormalMatrix :: (Floating a, Eq a) => Mat4 a -> Maybe (Mat3 a)
toNormalMatrix mat = inv4 mat >>= return . trunc4 . transpose4
diff --git a/Graphics/Glyph/Shaders.hs b/Graphics/Glyph/Shaders.hs
index 9a85e1a..9041f52 100644
--- a/Graphics/Glyph/Shaders.hs
+++ b/Graphics/Glyph/Shaders.hs
@@ -1,57 +1,61 @@
module Graphics.Glyph.Shaders where
-import Graphics.Rendering.OpenGL
-import qualified Data.ByteString as BS
import Control.Monad
+import qualified Data.ByteString as BS
import Data.Maybe
+import Graphics.Rendering.OpenGL
loadShader :: ShaderType -> FilePath -> IO (String, Maybe Shader)
loadShader typ path = do
- shader <- createShader typ
- ( shaderSourceBS shader $= ) =<< BS.readFile path
- compileShader shader
-
- ok <- get (compileStatus shader)
- infoLog <- get (shaderInfoLog shader)
+ shader <- createShader typ
+ (shaderSourceBS shader $=) =<< BS.readFile path
+ compileShader shader
- unless ok $
- deleteObjectNames [shader]
+ ok <- get (compileStatus shader)
+ infoLog <- get (shaderInfoLog shader)
- return ( infoLog, if not ok then Nothing else Just shader );
+ unless ok $
+ deleteObjectNames [shader]
+ return (infoLog, if not ok then Nothing else Just shader)
-loadShaders :: [(ShaderType,FilePath)] -> IO [(String, Maybe Shader)]
-loadShaders = mapM ( uncurry loadShader )
+loadShaders :: [(ShaderType, FilePath)] -> IO [(String, Maybe Shader)]
+loadShaders = mapM (uncurry loadShader)
workingShaders :: [(a, Maybe Shader)] -> [Shader]
workingShaders lst = map (fromJust . snd) (filter (isJust . snd) lst)
createShaderProgram :: [Shader] -> IO (String, Maybe Program)
createShaderProgram shaders = do
- p <- createProgram
- mapM_ (attachShader p) shaders
- linkProgram p
+ p <- createProgram
+ mapM_ (attachShader p) shaders
+ linkProgram p
- ok <- get $ linkStatus p
- info <- get $ programInfoLog p
+ ok <- get $ linkStatus p
+ info <- get $ programInfoLog p
- unless ok $
- deleteObjectNames [p]
+ unless ok $
+ deleteObjectNames [p]
- return ( info, if not ok then Nothing else Just p )
+ return (info, if not ok then Nothing else Just p)
getUniform :: Uniform a => String -> IO (Maybe (StateVar a))
getUniform name =
- get currentProgram >>= (\pr -> case pr of
+ get currentProgram
+ >>= ( \pr -> case pr of
Just p -> liftM (Just . uniform) (get $ uniformLocation p name)
- Nothing -> return Nothing )
+ Nothing -> return Nothing
+ )
getUniformForProgram :: Uniform a => String -> Program -> IO (StateVar a)
getUniformForProgram name prog =
- liftM uniform (get $ uniformLocation prog name)
-
+ liftM uniform (get $ uniformLocation prog name)
getUniformLocation :: String -> IO (Maybe UniformLocation)
getUniformLocation name =
- get currentProgram >>= maybe (return Nothing) (\prog ->
- liftM Just (get $ uniformLocation prog name) )
+ get currentProgram
+ >>= maybe
+ (return Nothing)
+ ( \prog ->
+ liftM Just (get $ uniformLocation prog name)
+ )
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
index 55b18fc..538c87a 100644
--- a/Graphics/Glyph/Textures.hs
+++ b/Graphics/Glyph/Textures.hs
@@ -1,39 +1,45 @@
module Graphics.Glyph.Textures where
+import Control.Monad
import Data.Array.Storable
import Data.Word
-
-import Graphics.Rendering.OpenGL
-import Control.Monad
import Graphics.GL.Compatibility30
+import Graphics.Rendering.OpenGL
-data Pixels =
- PixelsRGB (Int,Int) (StorableArray Int Word8) |
- PixelsRGBA (Int,Int) (StorableArray Int Word8)
+data Pixels
+ = PixelsRGB (Int, Int) (StorableArray Int Word8)
+ | PixelsRGBA (Int, Int) (StorableArray Int Word8)
pixelsArray :: Pixels -> StorableArray Int Word8
-pixelsArray (PixelsRGB _ a) = a
+pixelsArray (PixelsRGB _ a) = a
pixelsArray (PixelsRGBA _ a) = a
+
-- construct a new 2d array of pixels
makePixelsRGB :: (Int, Int) -> IO Pixels
-makePixelsRGB a@(w,h) = liftM (PixelsRGB a) (newArray_ (0,w*h-1))
+makePixelsRGB a@(w, h) = liftM (PixelsRGB a) (newArray_ (0, w * h -1))
-- convert a list of rgb values to an array
-newPixelsFromListRGB :: (Int, Int) -> [(Word8,Word8,Word8)] -> IO Pixels
-newPixelsFromListRGB a@(w,h) lst = liftM (PixelsRGB a) $ (newListArray (0,w*h*3) .
- concatMap (\(x,y,z)->[x,y,z])) lst
-
-newPixelsFromListRGBA :: (Int, Int) -> [(Word8,Word8,Word8,Word8)] -> IO Pixels
-newPixelsFromListRGBA a@(w,h) lst = liftM (PixelsRGBA a) $ newListArray (0,w*h*4)
- (concatMap (\(x,y,z,q)->[x,y,z,q]) lst)
+newPixelsFromListRGB :: (Int, Int) -> [(Word8, Word8, Word8)] -> IO Pixels
+newPixelsFromListRGB a@(w, h) lst =
+ liftM (PixelsRGB a) $
+ ( newListArray (0, w * h * 3)
+ . concatMap (\(x, y, z) -> [x, y, z])
+ )
+ lst
+
+newPixelsFromListRGBA :: (Int, Int) -> [(Word8, Word8, Word8, Word8)] -> IO Pixels
+newPixelsFromListRGBA a@(w, h) lst =
+ liftM (PixelsRGBA a) $
+ newListArray
+ (0, w * h * 4)
+ (concatMap (\(x, y, z, q) -> [x, y, z, q]) lst)
attachPixelsToTexture :: Pixels -> TextureObject -> IO ()
attachPixelsToTexture pixels tex =
- withStorableArray (pixelsArray pixels) $ \ptr -> do
- textureBinding Texture2D $= Just tex
- case pixels of
- PixelsRGB (w,h) _ -> glTexImage2D GL_TEXTURE_2D 0 3 (f w) (f h) 0 GL_RGB GL_UNSIGNED_BYTE ptr
- PixelsRGBA (w,h) _ -> glTexImage2D GL_TEXTURE_2D 0 4 (f w) (f h) 0 GL_RGBA GL_UNSIGNED_BYTE ptr
- where f = fromIntegral
-
-
+ withStorableArray (pixelsArray pixels) $ \ptr -> do
+ textureBinding Texture2D $= Just tex
+ case pixels of
+ PixelsRGB (w, h) _ -> glTexImage2D GL_TEXTURE_2D 0 3 (f w) (f h) 0 GL_RGB GL_UNSIGNED_BYTE ptr
+ PixelsRGBA (w, h) _ -> glTexImage2D GL_TEXTURE_2D 0 4 (f w) (f h) 0 GL_RGBA GL_UNSIGNED_BYTE ptr
+ where
+ f = fromIntegral
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
index d657aa3..a2257f6 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -4,22 +4,22 @@ import Data.Angle
import Graphics.Rendering.OpenGL
int :: (Integral a, Num b) => a -> b
-int = fromIntegral
+int = fromIntegral
-uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a,b,c,d,e,f,g) -> h
-uncurry7 func (a,b,c,d,e,f,g) = func a b c d e f g
+uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a, b, c, d, e, f, g) -> h
+uncurry7 func (a, b, c, d, e, f, g) = func a b c d e f g
-uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a,b,c,d,e,f) -> g
-uncurry6 func (a,b,c,d,e,f) = func a b c d e f
+uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
+uncurry6 func (a, b, c, d, e, f) = func a b c d e f
-uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
-uncurry5 func (a,b,c,d,e) = func a b c d e
+uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f
+uncurry5 func (a, b, c, d, e) = func a b c d e
-uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
-uncurry4 func (a,b,c,d) = func a b c d
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 func (a, b, c, d) = func a b c d
-uncurry3 :: (a -> b -> c -> e) -> (a,b,c) -> e
-uncurry3 func (a,b,c) = func a b c
+uncurry3 :: (a -> b -> c -> e) -> (a, b, c) -> e
+uncurry3 func (a, b, c) = func a b c
gsin :: (Floating a) => a -> a
gsin = sine . Degrees
@@ -28,73 +28,73 @@ gcos :: (Floating a) => a -> a
gcos = cosine . Degrees
toEuclidian :: (Floating a) => (a, a, a) -> (a, a, a)
-toEuclidian (r, th, ph) = (
- -r * gsin th * gcos ph,
- r * gsin ph,
- r * gcos th * gcos ph
- )
+toEuclidian (r, th, ph) =
+ ( - r * gsin th * gcos ph,
+ r * gsin ph,
+ r * gcos th * gcos ph
+ )
-mapT2 :: (a -> b) -> (a,a) -> (b,b)
+mapT2 :: (a -> b) -> (a, a) -> (b, b)
mapT2 f (a, b) = (f a, f b)
-mapT3 :: (a -> b) -> (a,a,a) -> (b,b,b)
+mapT3 :: (a -> b) -> (a, a, a) -> (b, b, b)
mapT3 f (a, b, c) = (f a, f b, f c)
-mapT4 :: (a -> b) -> (a,a,a,a) -> (b,b,b,b)
+mapT4 :: (a -> b) -> (a, a, a, a) -> (b, b, b, b)
mapT4 f (a, b, c, d) = (f a, f b, f c, f d)
-mapT5 :: (a -> b) -> (a,a,a,a,a) -> (b,b,b,b,b)
+mapT5 :: (a -> b) -> (a, a, a, a, a) -> (b, b, b, b, b)
mapT5 f (a, b, c, d, e) = (f a, f b, f c, f d, f e)
-mapT6 :: (a -> b) -> (a,a,a,a,a,a) -> (b,b,b,b,b,b)
+mapT6 :: (a -> b) -> (a, a, a, a, a, a) -> (b, b, b, b, b, b)
mapT6 f (a, b, c, d, e, _f) = (f a, f b, f c, f d, f e, f _f)
-mapT7 :: (a -> b) -> (a,a,a,a,a,a,a) -> (b,b,b,b,b,b,b)
+mapT7 :: (a -> b) -> (a, a, a, a, a, a, a) -> (b, b, b, b, b, b, b)
mapT7 f (a, b, c, d, e, _f, g) = (f a, f b, f c, f d, f e, f _f, f g)
-foldT2 :: (a -> b -> a) -> a -> (b,b) -> a
-foldT2 f ini (x,y) = ini `f` x `f` y
+foldT2 :: (a -> b -> a) -> a -> (b, b) -> a
+foldT2 f ini (x, y) = ini `f` x `f` y
-foldT3 :: (a -> b -> a) -> a -> (b,b,b) -> a
-foldT3 f ini (x,y,z) = ini `f` x `f` y `f` z
+foldT3 :: (a -> b -> a) -> a -> (b, b, b) -> a
+foldT3 f ini (x, y, z) = ini `f` x `f` y `f` z
-foldT4 :: (a -> b -> a) -> a -> (b,b,b,b) -> a
-foldT4 f ini (x,y,z,w) = ini `f` x `f` y `f` z `f` w
+foldT4 :: (a -> b -> a) -> a -> (b, b, b, b) -> a
+foldT4 f ini (x, y, z, w) = ini `f` x `f` y `f` z `f` w
-foldT5 :: (a -> b -> a) -> a -> (b,b,b,b,b) -> a
-foldT5 f ini (x,y,z,w,v) = ini `f` x `f` y `f` z `f` w `f` v
+foldT5 :: (a -> b -> a) -> a -> (b, b, b, b, b) -> a
+foldT5 f ini (x, y, z, w, v) = ini `f` x `f` y `f` z `f` w `f` v
-tup2Len :: (Real a,Floating b) => (a,a) -> b
-tup2Len = sqrt . foldT2 (+) 0 . mapT2 ((**2).toFloating)
+tup2Len :: (Real a, Floating b) => (a, a) -> b
+tup2Len = sqrt . foldT2 (+) 0 . mapT2 ((** 2) . toFloating)
-tup3Len :: (Real a,Floating b) => (a,a,a) -> b
-tup3Len = sqrt . foldT3 (+) 0 . mapT3 ((**2).toFloating)
+tup3Len :: (Real a, Floating b) => (a, a, a) -> b
+tup3Len = sqrt . foldT3 (+) 0 . mapT3 ((** 2) . toFloating)
-tup4Len :: (Real a,Floating b) => (a,a,a,a) -> b
-tup4Len = sqrt . foldT4 (+) 0 . mapT4 ((**2).toFloating)
+tup4Len :: (Real a, Floating b) => (a, a, a, a) -> b
+tup4Len = sqrt . foldT4 (+) 0 . mapT4 ((** 2) . toFloating)
-tup5Len :: (Real a,Floating b) => (a,a,a,a,a) -> b
-tup5Len = sqrt . foldT5 (+) 0 . mapT5 ((**2).toFloating)
+tup5Len :: (Real a, Floating b) => (a, a, a, a, a) -> b
+tup5Len = sqrt . foldT5 (+) 0 . mapT5 ((** 2) . toFloating)
-expand3 :: a -> (a,a,a)
-expand3 t = (t,t,t)
+expand3 :: a -> (a, a, a)
+expand3 t = (t, t, t)
-expand4 :: a -> (a,a,a,a)
-expand4 t = (t,t,t,t)
+expand4 :: a -> (a, a, a, a)
+expand4 t = (t, t, t, t)
-expand5 :: a -> (a,a,a,a,a)
-expand5 t = (t,t,t,t,t)
+expand5 :: a -> (a, a, a, a, a)
+expand5 t = (t, t, t, t, t)
-expand6 :: a -> (a,a,a,a,a)
-expand6 t = (t,t,t,t,t)
+expand6 :: a -> (a, a, a, a, a)
+expand6 t = (t, t, t, t, t)
-zipWithT2 :: (a -> b -> c) -> (a,a) -> (b,b) -> (c,c)
+zipWithT2 :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipWithT2 fu (a, b) (d, e) = (fu a d, fu b e)
-zipWithT3 :: (a -> b -> c) -> (a,a,a) -> (b,b,b) -> (c,c,c)
+zipWithT3 :: (a -> b -> c) -> (a, a, a) -> (b, b, b) -> (c, c, c)
zipWithT3 fu (a, b, c) (d, e, f) = (fu a d, fu b e, fu c f)
-zipWithT4 :: (a -> b -> c) -> (a,a,a,a) -> (b,b,b,b) -> (c,c,c,c)
+zipWithT4 :: (a -> b -> c) -> (a, a, a, a) -> (b, b, b, b) -> (c, c, c, c)
zipWithT4 fu (a, b, c, d) (e, f, g, h) = (fu a e, fu b f, fu c g, fu d h)
toFloating :: (Real a, Floating b) => a -> b
@@ -104,25 +104,25 @@ toFloating = fromRational . toRational
(!!%) lst idx = lst !! (idx `mod` length lst)
(++!) :: (Show a) => String -> a -> String
-(++!) str = (str++) . show
+(++!) str = (str ++) . show
-clamp :: (Ord a) => a -> (a, a) -> a
+clamp :: (Ord a) => a -> (a, a) -> a
clamp var (low, high) = min (max var low) high
-floatVertex :: (GLfloat,GLfloat,GLfloat) -> Vertex3 GLdouble
+floatVertex :: (GLfloat, GLfloat, GLfloat) -> Vertex3 GLdouble
floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup)
-floatVector :: (GLfloat,GLfloat,GLfloat) -> Vector3 GLdouble
+floatVector :: (GLfloat, GLfloat, GLfloat) -> Vector3 GLdouble
floatVector tup = uncurry3 Vector3 (mapT3 toFloating tup)
-- Maps a function across a list, except this function
-- can also be given a state variable like how foldl
-- works
-mapWith :: (s -> a -> (b,s)) -> s -> [a] -> ([b], s)
-mapWith func state (x:xs) =
- let (x',s') = func state x in
- let (l,s) = mapWith func s' xs in (x':l, s)
+mapWith :: (s -> a -> (b, s)) -> s -> [a] -> ([b], s)
+mapWith func state (x : xs) =
+ let (x', s') = func state x
+ in let (l, s) = mapWith func s' xs in (x' : l, s)
+mapWith _ s [] = ([], s)
-mapWith _ s [] = ([],s)
(>&>) :: (Monad m) => (a -> m b) -> (a -> m c) -> a -> m c
(>&>) f1 f2 a = f1 a >> f2 a
diff --git a/Hw8.hs b/Hw8.hs
index d977ff1..8a21e3f 100644
--- a/Hw8.hs
+++ b/Hw8.hs
@@ -1,78 +1,80 @@
-{-# LANGUAGE TemplateHaskell, OverloadedStrings, ViewPatterns #-}
-module Main where
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Main where
-import Data.Monoid
-import Text.Printf
import Control.Applicative
-import Control.Monad
-import GHC.Exts hiding (Vec4)
+-- import Graphics.UI.SDL.Image
-import SDL.Vect
-import SDL (($=))
-import SDL.Image
+import Control.DeepSeq
+import Control.Monad
import Data.Maybe
+import Data.Monoid
import Data.Word
-
import Debug.Trace
-
-import Graphics.Rendering.OpenGL as GL
-import qualified SDL
+import Foreign.Ptr
+import Foreign.Storable
+import GHC.Exts hiding (Vec4)
+import Graphics.GL.Compatibility30
+import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.GLMath
+import Graphics.Glyph.GlyphObject
import Graphics.Glyph.Mat4
-import Graphics.GL.Compatibility30
-
--- import Graphics.UI.SDL.Image
-import Graphics.Glyph.Textures
import Graphics.Glyph.Shaders
+import Graphics.Glyph.Textures
import Graphics.Glyph.Util
-import Graphics.Glyph.BufferBuilder
-import Graphics.Glyph.GlyphObject
-
-import Control.DeepSeq
+import Graphics.Rendering.OpenGL as GL
+import SDL (($=))
+import qualified SDL
+import SDL.Image
+import SDL.Vect
import System.Exit
import System.Random hiding (uniform)
+import Text.Printf
-import Debug.Trace
-import Foreign.Storable
-import Foreign.Ptr
-
-
-data Uniforms = Uniforms {
- dxU :: UniformLocation,
+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),
- satelites :: GlyphObject (Program,
- UniformLocation, -- noise
- UniformLocation, -- mvMat
- UniformLocation, -- pMat
- UniformLocation, -- time
- UniformLocation), -- light
- moon :: GlyphObject (Program,
- UniformLocation,
- UniformLocation,
- UniformLocation,
- UniformLocation,
- UniformLocation,
- UniformLocation,
- UniformLocation),
+ }
+ deriving (Show)
+
+data TextureData = TextureData
+ { textureSize :: (Int, Int),
+ textureObject :: TextureObject
+ }
+ deriving (Show)
+
+data Resources = Resources
+ { object :: GlyphObject Uniforms,
+ backDrop :: GlyphObject (Program, UniformLocation),
+ satelites ::
+ GlyphObject
+ ( Program,
+ UniformLocation, -- noise
+ UniformLocation, -- mvMat
+ UniformLocation, -- pMat
+ UniformLocation, -- time
+ UniformLocation -- light
+ ),
+ moon ::
+ GlyphObject
+ ( Program,
+ UniformLocation,
+ UniformLocation,
+ UniformLocation,
+ UniformLocation,
+ UniformLocation,
+ UniformLocation,
+ UniformLocation
+ ),
resTexture :: TextureData,
earthTex :: TextureData,
cloudsTex :: TextureData,
@@ -87,19 +89,20 @@ data Resources = Resources {
normalMatU :: UniformLocation,
resTime :: GLfloat,
pMatrix :: Mat4 GLfloat,
- eyeLocation :: (GLfloat,GLfloat,GLfloat),
+ eyeLocation :: (GLfloat, GLfloat, GLfloat),
difEyeLocation :: (GLfloat, GLfloat, GLfloat),
- lightPos :: (GLfloat,GLfloat,GLfloat),
+ lightPos :: (GLfloat, GLfloat, GLfloat),
useNoise :: Bool,
dTime :: GLfloat
-} deriving (Show)
+ }
+ deriving (Show)
makeTexture :: IO TextureObject
makeTexture = do
- texobj <- liftM head $ genObjectNames 1
- textureBinding Texture2D $= Just texobj
- textureFilter Texture2D $= ((Linear', Nothing), Linear')
- return texobj
+ 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
@@ -109,365 +112,390 @@ enumNeq a = not . enumEq a
loadProgram :: String -> String -> Maybe String -> IO Program
loadProgram vert frag geom = do
- shaders <- loadShaders $ catMaybes [
- Just (VertexShader, vert),
- Just (FragmentShader, frag),
- geom >>= return . (,)GeometryShader]
- -- 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
+ shaders <-
+ loadShaders $
+ catMaybes
+ [ Just (VertexShader, vert),
+ Just (FragmentShader, frag),
+ geom >>= return . (,) GeometryShader
+ ]
+ -- 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)
+ 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)
+ when (isNothing maybeProg) $ do
+ putStrLn "Failed to link program"
+ putStrLn linklog
+ exitWith (ExitFailure 111)
- (return . fromJust) maybeProg
+ (return . fromJust) maybeProg
quad :: Builder GLfloat ()
quad = do
- let lst = [ (-1,-1,0.0),
- (-1, 1,0.0),
- ( 1, 1,0.0) ]
- let neg (a,b,c) = (-a,-b,-c)
-
- forM_ lst bVertex3
- forM_ lst (bVertex3.neg)
+ let lst =
+ [ (-1, -1, 0.0),
+ (-1, 1, 0.0),
+ (1, 1, 0.0)
+ ]
+ let neg (a, b, c) = (- a, - b, - c)
+ forM_ lst bVertex3
+ forM_ lst (bVertex3 . neg)
circle :: GLfloat -> GLfloat -> Builder GLfloat ()
circle r step = do
- let fromQuad (a,b,c,d) = [a,b,c,b,c,d]
- let lst = concat [fromQuad ((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))
-
-
+ let fromQuad (a, b, c, d) = [a, b, c, b, c, d]
+ let lst =
+ concat
+ [ fromQuad
+ ( (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" Nothing >>= (\prog -> do
- glo <- newDefaultGlyphObject (circle 1 3)
- <$> 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")
-
- prog2 <- loadBackdropProgram
- backDrop <- newDefaultGlyphObject quad
- <$> (get (uniformLocation prog2 "texture") >>=
- \x-> return (prog2,x))
-
- moonProg <- loadProgram "shaders/moon.vert" "shaders/moon.frag" Nothing
- moon <- newDefaultGlyphObject (circle 0.2 5)
- <$> 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")
-
- stgen1 <- newStdGen
- stgen2 <- newStdGen
- stgen3 <- newStdGen
- let run = (\(x,y,_)->bTexture2 (1.0/x,1.0/y)) >&> bVertex3
- satelitesProg <- loadProgram "shaders/satelites.vert" "shaders/satelites.frag" (Just "shaders/satelites.geom")
- satelites <- newDefaultGlyphObject (do
- mapM_ run $
- sortWith (\(a,_,_)-> -a) $ take 200000 $ zip3 (randoms stgen1) (randoms stgen2) (randoms stgen3)
- )
- <$> do (,,,,,)
- <$> pure satelitesProg
- <*> get (uniformLocation satelitesProg "noiseTexture")
- <*> get (uniformLocation satelitesProg "mvMatrix")
- <*> get (uniformLocation satelitesProg "pMatrix")
- <*> get (uniformLocation satelitesProg "time")
- <*> get (uniformLocation satelitesProg "light")
-
- Resources
- <$> glo
- <*> backDrop
- <*> liftM (\s -> s {primitiveMode = Points}) satelites
- <*> 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 0.1
+ let pMatrix' = perspectiveMatrix 50 1.8 0.1 100
+ in loadProgram "shaders/normal.vert" "shaders/textured.frag" Nothing
+ >>= ( \prog -> do
+ glo <-
+ newDefaultGlyphObject (circle 1 3)
+ <$> 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")
+
+ prog2 <- loadBackdropProgram
+ backDrop <-
+ newDefaultGlyphObject quad
+ <$> ( get (uniformLocation prog2 "texture")
+ >>= \x -> return (prog2, x)
+ )
+
+ moonProg <- loadProgram "shaders/moon.vert" "shaders/moon.frag" Nothing
+ moon <-
+ newDefaultGlyphObject (circle 0.2 5)
+ <$> 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")
+
+ stgen1 <- newStdGen
+ stgen2 <- newStdGen
+ stgen3 <- newStdGen
+ let run = (\(x, y, _) -> bTexture2 (1.0 / x, 1.0 / y)) >&> bVertex3
+ satelitesProg <- loadProgram "shaders/satelites.vert" "shaders/satelites.frag" (Just "shaders/satelites.geom")
+ satelites <-
+ newDefaultGlyphObject
+ ( do
+ mapM_ run $
+ sortWith (\(a, _, _) -> - a) $ take 200000 $ zip3 (randoms stgen1) (randoms stgen2) (randoms stgen3)
+ )
+ <$> do
+ (,,,,,)
+ <$> pure satelitesProg
+ <*> get (uniformLocation satelitesProg "noiseTexture")
+ <*> get (uniformLocation satelitesProg "mvMatrix")
+ <*> get (uniformLocation satelitesProg "pMatrix")
+ <*> get (uniformLocation satelitesProg "time")
+ <*> get (uniformLocation satelitesProg "light")
+
+ Resources
+ <$> glo
+ <*> backDrop
+ <*> liftM (\s -> s {primitiveMode = Points}) satelites
+ <*> 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 0.1
)
-
+
printErrors :: String -> IO ()
printErrors ctx =
- get errors >>= mapM_ (putStrLn . (("GL["++ctx++"]: ")++) . show)
+ get errors >>= mapM_ (putStrLn . (("GL[" ++ ctx ++ "]: ") ++) . show)
-setupMvp :: Mat4 GLfloat ->Resources -> IO ()
+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
+ 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)
+ 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"
-
+ Just mat -> uniform (normalMatU res) $= mat
+ _ -> putStrLn "Normal matrix could not be computed"
setupTexturing :: String -> TextureData -> UniformLocation -> Int -> IO ()
setupTexturing v (TextureData _ to) tu unit = do
- texture Texture2D $= Enabled
- activeTexture $= TextureUnit (fromIntegral unit)
- textureBinding Texture2D $= Just to
- uniform tu $= Index1 (fromIntegral unit::GLint)
-
+ texture Texture2D $= Enabled
+ activeTexture $= TextureUnit (fromIntegral unit)
+ textureBinding Texture2D $= Just to
+ uniform tu $= Index1 (fromIntegral unit :: GLint)
display :: SDL.Window -> Resources -> IO Resources
display win res = do
- clear [ColorBuffer, DepthBuffer]
- clearColor $= Color4 0.3 0.3 0.3 1.0
-
- depthFunc $= Nothing
- draw $ prepare (backDrop res) $ \obj -> do
- let (prg,uni) = (getResources obj)
- currentProgram $= Just prg
- setupTexturing "space" (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
-
- blend $= Disabled
- vertexProgramPointSize $= Enabled
- draw $ prepare (object res) $ \glo -> do
- depthFunc $= Just Less
- let bumpMap = if useNoise res then resTexture else earthTex
- let uniforms = getResources 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 "bump" (bumpMap res) (textureU uniforms) 0
- setupTexturing "earth" (earthTex res) (earthU uniforms) 1
- setupTexturing "clouds" (cloudsTex res) (cloudsU uniforms) 2
- setupTexturing "lights" (lightsTex res) (lightsU uniforms) 3
- setupTexturing "res" (resTexture res) (randomU uniforms) 4
- setupTexturing "winter" (winterTex res) (winterU uniforms) 5
-
- draw $ prepare (moon res) $ \glo -> do
- let (prog, texU, lU, mvMatU, pMatU, timeUn,dxUn,dyUn) = getResources 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 "moon" (moonTex res) texU 0
- setupLighting mvMatrix res lU
-
- blend $= Enabled
- blendFunc $= (GL.SrcAlpha,OneMinusSrcAlpha)
- draw $ prepare (satelites res) $ \glo -> do
- let (prog, texU, mvMatU, pMatU, timeUn, light) = getResources glo
- let time = resTime res
- currentProgram $= Just prog
- uniform mvMatU $= mvMatrix
- uniform pMatU $= pMatrix res
- uniform timeUn $= Index1 time
- setupLighting mvMatrix res light
- setupTexturing "res" (resTexture res) texU 0
-
- -- SDL.glSwapBuffers
- SDL.glSwapWindow win
- return res
+ clear [ColorBuffer, DepthBuffer]
+ clearColor $= Color4 0.3 0.3 0.3 1.0
+
+ depthFunc $= Nothing
+ draw $
+ prepare (backDrop res) $ \obj -> do
+ let (prg, uni) = (getResources obj)
+ currentProgram $= Just prg
+ setupTexturing "space" (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
+
+ blend $= Disabled
+ vertexProgramPointSize $= Enabled
+ draw $
+ prepare (object res) $ \glo -> do
+ depthFunc $= Just Less
+ let bumpMap = if useNoise res then resTexture else earthTex
+ let uniforms = getResources 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 "bump" (bumpMap res) (textureU uniforms) 0
+ setupTexturing "earth" (earthTex res) (earthU uniforms) 1
+ setupTexturing "clouds" (cloudsTex res) (cloudsU uniforms) 2
+ setupTexturing "lights" (lightsTex res) (lightsU uniforms) 3
+ setupTexturing "res" (resTexture res) (randomU uniforms) 4
+ setupTexturing "winter" (winterTex res) (winterU uniforms) 5
+
+ draw $
+ prepare (moon res) $ \glo -> do
+ let (prog, texU, lU, mvMatU, pMatU, timeUn, dxUn, dyUn) = getResources 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 "moon" (moonTex res) texU 0
+ setupLighting mvMatrix res lU
+
+ blend $= Enabled
+ blendFunc $= (GL.SrcAlpha, OneMinusSrcAlpha)
+ draw $
+ prepare (satelites res) $ \glo -> do
+ let (prog, texU, mvMatU, pMatU, timeUn, light) = getResources glo
+ let time = resTime res
+ currentProgram $= Just prog
+ uniform mvMatU $= mvMatrix
+ uniform pMatU $= pMatrix res
+ uniform timeUn $= Index1 time
+ setupLighting mvMatrix res light
+ setupTexturing "res" (resTexture res) texU 0
+
+ -- SDL.glSwapBuffers
+ SDL.glSwapWindow win
+ return res
digestEvents :: Resources -> IO Resources
digestEvents res = do
- evs <- SDL.pollEvents
- let (quit, res') =
- foldl (\(q, res) ev ->
- case ev of
- SDL.QuitEvent -> (True, res)
- SDL.KeyboardEvent e ->
- (\(q, f) -> (q, f res)) $
- (q, case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
- (SDL.Pressed, SDL.ScancodeW) -> diff $ set3 0.2
- (SDL.Released, SDL.ScancodeW) -> diff $ set3 0
-
- (SDL.Pressed, SDL.ScancodeA) -> diff $ set2 (-0.2)
- (SDL.Released, SDL.ScancodeA) -> diff $ set2 0
-
- (SDL.Pressed, SDL.ScancodeS) -> diff $ set3 (-0.2)
- (SDL.Released, SDL.ScancodeS) -> diff $ set3 0
-
- (SDL.Pressed, SDL.ScancodeD) -> diff $ set2 0.2
- (SDL.Released, SDL.ScancodeD) -> diff $ set2 0
-
- (SDL.Pressed, SDL.ScancodeI) -> diff $ set1 (-0.1)
- (SDL.Released, SDL.ScancodeI) -> diff $ set1 0
-
- (SDL.Pressed, SDL.ScancodeK) -> diff $ set1 0.1
- (SDL.Released, SDL.ScancodeK) -> diff $ set1 0
- _ -> id)
- _ -> (q, res)) (False, res) (map SDL.eventPayload evs)
-
- when quit $
+ evs <- SDL.pollEvents
+ let (quit, res') =
+ foldl
+ ( \(q, res) ev ->
+ case ev of
+ SDL.QuitEvent -> (True, res)
+ SDL.KeyboardEvent e ->
+ (\(q, f) -> (q, f res)) $
+ ( q,
+ case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
+ (SDL.Pressed, SDL.ScancodeW) -> diff $ set3 0.2
+ (SDL.Released, SDL.ScancodeW) -> diff $ set3 0
+ (SDL.Pressed, SDL.ScancodeA) -> diff $ set2 (-0.2)
+ (SDL.Released, SDL.ScancodeA) -> diff $ set2 0
+ (SDL.Pressed, SDL.ScancodeS) -> diff $ set3 (-0.2)
+ (SDL.Released, SDL.ScancodeS) -> diff $ set3 0
+ (SDL.Pressed, SDL.ScancodeD) -> diff $ set2 0.2
+ (SDL.Released, SDL.ScancodeD) -> diff $ set2 0
+ (SDL.Pressed, SDL.ScancodeI) -> diff $ set1 (-0.1)
+ (SDL.Released, SDL.ScancodeI) -> diff $ set1 0
+ (SDL.Pressed, SDL.ScancodeK) -> diff $ set1 0.1
+ (SDL.Released, SDL.ScancodeK) -> diff $ set1 0
+ _ -> id
+ )
+ _ -> (q, res)
+ )
+ (False, res)
+ (map SDL.eventPayload evs)
+
+ when quit $
exitSuccess
- return res'
-
- where
- diff tup res = res { difEyeLocation = tup (difEyeLocation res)}
- set1 x (_, y, z) = (x, y, z)
- set2 y (x, _, z) = (x, y, z)
- set3 z (x, y, _) = (x, y, z)
- (+++) = zipWithT3 (+)
-
- -- ev <- SDL.pollEvent
- -- return args
- -- 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 + 0.1) args
-
- -- KeyDown (Keysym SDLK_MINUS _ _) ->
- -- digestEvents $ setDTime (dTime args - 0.1) args
-
- -- Quit -> exitSuccess
- -- _ -> digestEvents args
- -- where
- -- (+++) = zipWithT3 (+)
+ return res'
+ where
+ diff tup res = res {difEyeLocation = tup (difEyeLocation res)}
+ set1 x (_, y, z) = (x, y, z)
+ set2 y (x, _, z) = (x, y, z)
+ set3 z (x, y, _) = (x, y, z)
+ (+++) = zipWithT3 (+)
+
+-- ev <- SDL.pollEvent
+-- return args
+-- 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 + 0.1) args
+
+-- KeyDown (Keysym SDLK_MINUS _ _) ->
+-- digestEvents $ setDTime (dTime args - 0.1) 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 $ args { pMatrix = pMatrix' }
+ 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 $ args {pMatrix = pMatrix'}
bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
bindSurfaceToTexture surf to = do
- textureBinding Texture2D $= Just to
- bbp <- return 3 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ SDL.surfacePixels surf)
- ptr <- SDL.surfacePixels surf
- (V2 w h) <- SDL.surfaceDimensions surf
+ textureBinding Texture2D $= Just to
+ bbp <- return 3 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ SDL.surfacePixels surf)
+ ptr <- SDL.surfacePixels surf
+ (V2 w h) <- SDL.surfaceDimensions surf
- glTexImage2D GL_TEXTURE_2D 0 bbp (fi w) (fi h) 0 (if bbp == 3 then GL_RGB else GL_RGBA) GL_UNSIGNED_BYTE ptr
- return $ TextureData (fi w, fi h) to
- where fi :: (Integral a, Integral b) => a -> b
- fi = fromIntegral
+ glTexImage2D GL_TEXTURE_2D 0 bbp (fi w) (fi h) 0 (if bbp == 3 then GL_RGB else GL_RGBA) GL_UNSIGNED_BYTE ptr
+ return $ TextureData (fi w, fi h) to
+ where
+ fi :: (Integral a, Integral b) => a -> b
+ fi = fromIntegral
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
+ -- 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
@@ -481,8 +509,10 @@ main = do
window <-
SDL.createWindow
"SDL / OpenGL Example"
- SDL.defaultWindow {SDL.windowInitialSize = V2 1920 1080,
- SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL}
+ SDL.defaultWindow
+ { SDL.windowInitialSize = V2 1920 1080,
+ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+ }
putStrLn "2"
SDL.showWindow window
putStrLn "3"
@@ -490,14 +520,12 @@ main = do
_ <- SDL.glCreateContext window
resources <- makeResources
reshape (1920, 1080) resources >>= mainloop window
-
- where mainloop win resources =
- digestEvents resources >>= display win >>= (mainloop win . updateResources)
- (+++) = zipWithT3 (+)
- updateResources res =
- res {
- resTime = ( resTime res + (dTime res) ),
- eyeLocation = zipWithT3 (+) (eyeLocation res) (difEyeLocation res)
- }
-
-
+ where
+ mainloop win resources =
+ digestEvents resources >>= display win >>= (mainloop win . updateResources)
+ (+++) = zipWithT3 (+)
+ updateResources res =
+ res
+ { resTime = (resTime res + (dTime res)),
+ eyeLocation = zipWithT3 (+) (eyeLocation res) (difEyeLocation res)
+ }
diff --git a/Setup.hs b/Setup.hs
index 9a994af..e8ef27d 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain
generated by cgit (git 2.34.1) at 2025-04-28 12:07:35 +0000