aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Data/ByteStringBuilder.hs12
-rw-r--r--EventHandler.hs3
-rw-r--r--Final.hs31
-rw-r--r--Graphics/Glyph/ArrayGenerator.hs12
-rw-r--r--Graphics/Glyph/BufferBuilder.hs13
-rw-r--r--Graphics/Glyph/ExtendedGL/Base.hs34
-rw-r--r--Graphics/Glyph/ExtendedGL/Framebuffers.hs26
-rw-r--r--Graphics/Glyph/GeometryBuilder.hs44
-rw-r--r--Graphics/Glyph/GlyphObject.hs57
-rw-r--r--Graphics/Glyph/Mat4.hs12
-rw-r--r--Graphics/Glyph/ObjLoader.hs4
-rw-r--r--Graphics/Glyph/Textures.hs9
-rw-r--r--Graphics/Glyph/Util.hs11
-rw-r--r--Graphics/Rendering/HelpGL.hs1
-rw-r--r--Graphics/SDL/SDLHelp.hs93
-rw-r--r--Models.hs8
-rw-r--r--Resources.hs301
-rw-r--r--Terralloc.cabal25
-rw-r--r--TileShow.hs27
-rwxr-xr-xterralloc3
20 files changed, 420 insertions, 306 deletions
diff --git a/Data/ByteStringBuilder.hs b/Data/ByteStringBuilder.hs
index 859d710..6f0222e 100644
--- a/Data/ByteStringBuilder.hs
+++ b/Data/ByteStringBuilder.hs
@@ -25,8 +25,18 @@ putB = put . BSL.singleton
runBuilder :: Builder -> ByteString
runBuilder (ByteStringBuilder bs _) = bs
+instance Functor ByteStringBuilder where
+ fmap f bb = bb >>= (return . f)
+
+instance Applicative ByteStringBuilder where
+ (<*>) afn aa = do
+ fn <- afn
+ a <- aa
+ return (fn a)
+
+ pure = return
+
instance Monad ByteStringBuilder where
ByteStringBuilder a _ >> ByteStringBuilder b c = ByteStringBuilder (a `append` b) c
a@(ByteStringBuilder _ b) >>= func = a >> func b
return = ByteStringBuilder BSL.empty
- fail = error
diff --git a/EventHandler.hs b/EventHandler.hs
deleted file mode 100644
index 4452c17..0000000
--- a/EventHandler.hs
+++ /dev/null
@@ -1,3 +0,0 @@
-module EventHandler where
-
-eventHandler
diff --git a/Final.hs b/Final.hs
index 4fd50e0..951edce 100644
--- a/Final.hs
+++ b/Final.hs
@@ -5,8 +5,8 @@
module Main where
import Graphics.Rendering.OpenGL as GL
-import Graphics.UI.SDL.Image as SDLImg
-import Graphics.UI.SDL as SDL
+import SDL.Image as SDLImg
+import SDL
import Graphics.SDL.SDLHelp
import Graphics.Glyph.Util
import Control.Monad
@@ -27,6 +27,8 @@ import Resources
import System.Random
import System.Environment
+import qualified SDL
+import qualified SDL
{-
@@ -37,14 +39,12 @@ import System.Environment
- w is the minimum width of the two images and h is the minimum
- height.
-}
-buildArray :: SDL.Surface -> SDL.Surface -> Array (Int,Int) Tile
-buildArray terrain height =
+buildArray :: SDL.Surface -> SDL.Surface -> IO (Array (Int,Int) Tile)
+buildArray terrain height = do
+ (V2 (fromIntegral -> w) (fromIntegral -> h)) <- SDL.surfaceDimensions terrain
{- Pick the minimum width and height between the two images -}
- let w = min (SDL.surfaceGetWidth terrain) $ SDL.surfaceGetWidth height
- h = min (SDL.surfaceGetHeight terrain) $ SDL.surfaceGetHeight height
-
- {- Function that returns a Tile for an x y coordinate -}
- conv (x,y) =
+ let {- Function that returns a Tile for an x y coordinate -}
+ conv x y =
let terrainVal = fromIntegral $ getPixelUnsafe x y terrain
{- The height is encoded as the sum of the color channels, to make life a litte
- easier on the heightmap reader. -}
@@ -62,8 +62,8 @@ buildArray terrain height =
Tile terrainVal' heightVal
{- build the list of Tiles to jam into the array -}
- list = map conv [(x,y) | x <- [0..w-1], y <- [0..h-1]]
- in listArray ((0,0),(w-1,h-1)) list
+ list = [conv x y | x <- [0..w-1], y <- [0..h-1]]
+ in return $ listArray ((0,0),(w-1,h-1)) list
{- This function takes the array generated in the function from above and
- creates a new array that colors in the array with locations of bodies
@@ -202,7 +202,7 @@ printShowArray arr = do
forM_ [0..h] $ \y -> do
forM_ [0..w] $ \x -> do
lNext <- readArray arr (x,y)
- putStr $ show lNext
+ putStr $ show lNext ++ " "
putStrLn ""
{- The colors each tile type is mapped to
@@ -332,10 +332,10 @@ main = do
(m:_) -> doload m
_ -> sequence [SDLImg.load "maps/wonderland_terrain.png", SDLImg.load "maps/wonderland_height.png"]
- let arr = buildArray terrain height
+ arr <- buildArray terrain height
coloredArr <- colorArray arr
- surface <- simpleStartup "Terralloc" (1280,1024)
+ window <- simpleStartup "Terralloc" (1280,1024)
stgen <- newStdGen
stgen2 <- newStdGen
@@ -347,7 +347,8 @@ main = do
(mapping,water) <- getWaterQuads arr coloredArr
coloredArr2 <- mapArray (\idx -> if idx == 0 then -1 else Map.findWithDefault (-1) idx mapping) coloredArr
printShowArray coloredArr2
+ printArray arr
{- Kick off SDL with the callbacks defined in Resources -}
- makeResources surface (createBuilder arr) forestLocations jungleLocations water arr coloredArr2
+ makeResources window (createBuilder arr) forestLocations jungleLocations water arr coloredArr2
>>= startPipeline reshape eventHandle displayHandle updateHandle;
diff --git a/Graphics/Glyph/ArrayGenerator.hs b/Graphics/Glyph/ArrayGenerator.hs
index 1e9e5a3..16fe41f 100644
--- a/Graphics/Glyph/ArrayGenerator.hs
+++ b/Graphics/Glyph/ArrayGenerator.hs
@@ -7,6 +7,18 @@ import Data.Array
import Data.Maybe
data ArrayTransaction ix val b = ArrayBuilderM_ (M.Map ix val) b
+
+instance (Ord ix) => Functor (ArrayTransaction ix a) where
+ fmap f bb = bb >>= (return . f)
+
+instance (Ord ix) => Applicative (ArrayTransaction ix a) where
+ (<*>) afn aa = do
+ fn <- afn
+ a <- aa
+ return (fn a)
+
+ pure = return
+
instance (Ord ix) => Monad (ArrayTransaction ix a) where
return = ArrayBuilderM_ M.empty
(ArrayBuilderM_ map1 val) >>= f =
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index 9dae0aa..b23f6ba 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -104,7 +104,17 @@ instance Show (CompiledBuild x) where
show (CompiledBuild stride enabled n ptr nbytes) =
"[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++" ptr="++!ptr++" nbytes="++!nbytes++"]"
-instance (Num t) => Monad (BuilderM t) where
+instance Functor (BuilderM t) where
+ fmap f b = b >>= (return . f)
+
+instance Applicative (BuilderM t) where
+ pure = return
+ (<*>) afn aa = do
+ fn <- afn
+ a <- aa
+ return (fn a)
+
+instance Monad (BuilderM t) where
(BuilderM !builder1 _) >> (BuilderM !builder2 ret) =
BuilderM (builder1 ><> builder2) ret
where
@@ -118,7 +128,6 @@ instance (Num t) => Monad (BuilderM t) where
b1@(BuilderM _ ret) >>= func = b1 >> func ret
return = BuilderM (LeafBuilder Seq.empty)
- fail = undefined
instance Functor Builder where
fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2))
diff --git a/Graphics/Glyph/ExtendedGL/Base.hs b/Graphics/Glyph/ExtendedGL/Base.hs
index 48f61a5..88566f4 100644
--- a/Graphics/Glyph/ExtendedGL/Base.hs
+++ b/Graphics/Glyph/ExtendedGL/Base.hs
@@ -5,8 +5,8 @@
module Graphics.Glyph.ExtendedGL.Base where
import qualified Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
-import Graphics.Rendering.OpenGL.Raw.ARB
+import Graphics.GL.Core43
+import Graphics.GL.Compatibility30
import Foreign.Marshal.Alloc
import Foreign.Ptr
@@ -18,6 +18,7 @@ import Control.Monad
import Data.StateVar
import Unsafe.Coerce
+import Data.Proxy
data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show,Enum)
@@ -40,8 +41,8 @@ class HasParamOfType b t a where
class IsPrimitiveModeMarshallable a where
marshalPrimitiveMode :: a -> GLuint
-castPrimitive :: forall a b t. (IsWrappedPrimitive t a, IsWrappedPrimitive t b) => a -> b
-castPrimitive x = wrap unw
+castPrimitive :: forall a b t. (IsWrappedPrimitive t a, IsWrappedPrimitive t b) => Proxy t -> a -> b
+castPrimitive _ x = wrap unw
where
unw :: t
unw = unwrap x
@@ -54,10 +55,10 @@ instance (IsWrappedPrimitive GLenum a) => IsGLEnumMarshallable a where
instance IsPrimitiveModeMarshallable ExPrimitiveMode where
marshalPrimitiveMode x = case x of
- Points -> gl_POINTS
- Triangles -> gl_TRIANGLES
- Lines -> gl_LINES
- Patches -> gl_PATCHES
+ Points -> GL_POINTS
+ Triangles -> GL_TRIANGLES
+ Lines -> GL_LINES
+ Patches -> GL_PATCHES
instance IsPrimitiveModeMarshallable GL.PrimitiveMode where
marshalPrimitiveMode x = case x of
@@ -75,13 +76,6 @@ instance IsPrimitiveModeMarshallable GL.PrimitiveMode where
instance IsPrimitiveModeMarshallable GLuint where
marshalPrimitiveMode = id
-drawArraysInstanced ::
- (IsPrimitiveModeMarshallable a) =>
- a -> GL.ArrayIndex ->
- GL.NumArrayIndices ->
- GLsizei -> IO ()
-drawArraysInstanced = glDrawArraysInstanced . marshalPrimitiveMode
-
vertexAttributeDivisor :: GL.AttribLocation -> SettableStateVar GLuint
vertexAttributeDivisor (GL.AttribLocation loc) =
makeSettableStateVar $ \val ->
@@ -92,15 +86,15 @@ vertexAttributeDivisor (GL.AttribLocation loc) =
patchVertices :: (Integral a) => SettableStateVar a
patchVertices =
makeSettableStateVar $ \val ->
- glPatchParameteri gl_PATCH_VERTICES $ fromIntegral val
+ glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val
{- Returns the maximum number of patches
- for a tessilation shader -}
maxPatchVertices :: IO CInt
maxPatchVertices =
alloca $ \ptr -> do
- glGetIntegerv gl_MAX_PATCH_VERTICES ptr
- peek ptr
+ glGetIntegerv GL_MAX_PATCH_VERTICES ptr
+ fromIntegral <$> peek ptr
getGLVersion :: IO String
getGLVersion =
@@ -108,8 +102,8 @@ getGLVersion =
x <- a ; y <- b ; return (x,y)
in
alloca $ \ptr1 -> alloca $ \ptr2 -> do
- glGetIntegerv gl_MAJOR_VERSION ptr1
- glGetIntegerv gl_MINOR_VERSION ptr2
+ glGetIntegerv GL_MAJOR_VERSION ptr1
+ glGetIntegerv GL_MINOR_VERSION ptr2
(v1,v2) <- lift2 (peek ptr1, peek ptr2)
return ("OpenGL " ++ show v1 ++ "." ++ show v2)
diff --git a/Graphics/Glyph/ExtendedGL/Framebuffers.hs b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
index abe9756..a6c2891 100644
--- a/Graphics/Glyph/ExtendedGL/Framebuffers.hs
+++ b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
@@ -6,8 +6,8 @@
module Graphics.Glyph.ExtendedGL.Framebuffers where
-import Graphics.Rendering.OpenGL.Raw.ARB
-import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.GL.Compatibility30
+import Graphics.GL.Core43
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Glyph.ExtendedGL.Base
@@ -46,12 +46,12 @@ instance IsGenerable Renderbuffer where
glGenRenderbuffers 1 ptr
liftM Renderbuffer $ peek ptr
instance IsBindable Renderbuffer where
- bind = glBindRenderbuffer gl_RENDERBUFFER . unwrap
+ bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap
data RenderbufferArgument =
DepthAttachment
instance IsWrappedPrimitive GLenum RenderbufferArgument where
- unwrap DepthAttachment = gl_DEPTH_ATTACHMENT
+ unwrap DepthAttachment = GL_DEPTH_ATTACHMENT
renderBufferStorageRaw :: (IsGLEnumMarshallable a, IsGLEnumMarshallable b) => a -> b -> Int -> Int -> IO ()
renderBufferStorageRaw typ enum w h = glRenderbufferStorage (toGLEnum typ)
@@ -59,7 +59,7 @@ renderBufferStorageRaw typ enum w h = glRenderbufferStorage (toGLEnum typ)
renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a,Int,Int)
renderBufferStorage buffer = makeSettableStateVar $ \(en,w,h) -> do
bind buffer
- renderBufferStorageRaw gl_RENDERBUFFER en w h
+ renderBufferStorageRaw GL_RENDERBUFFER en w h
frameBufferRenderBuffer :: forall a b. (IsFramebuffer a,IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a
frameBufferRenderBuffer rb e = do
@@ -68,7 +68,7 @@ frameBufferRenderBuffer rb e = do
unw :: GLuint
unw = unwrap rb
bind rb
- glFramebufferRenderbuffer enum (toGLEnum e) gl_RENDERBUFFER (unwrap rb)
+ glFramebufferRenderbuffer enum (toGLEnum e) GL_RENDERBUFFER (unwrap rb)
return $ wrap unw
where
test :: a
@@ -79,14 +79,14 @@ data FramebufferParameter = DefaultWidth | DefaultHeight
instance IsWrappedPrimitive GLenum FramebufferParameter where
unwrap p = case p of
- DefaultWidth -> gl_FRAMEBUFFER_DEFAULT_WIDTH
- DefaultHeight -> gl_FRAMEBUFFER_DEFAULT_HEIGHT
- wrap x | x == gl_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth
- | x == gl_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight
+ DefaultWidth -> GL_FRAMEBUFFER_DEFAULT_WIDTH
+ DefaultHeight -> GL_FRAMEBUFFER_DEFAULT_HEIGHT
+ wrap x | x == GL_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth
+ | x == GL_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight
| otherwise = undefined
instance HasIntegerParam GLenum DrawFramebuffer where
- parami p fb = framebufferBasicParameteri gl_DRAW_FRAMEBUFFER fb p
+ parami p fb = framebufferBasicParameteri GL_DRAW_FRAMEBUFFER fb p
{- Has parameters of type GLuint which are acessable by the data FramebufferParameter for
- the type DrawFramebuffer -}
@@ -99,11 +99,11 @@ instance IsGenerable DrawFramebuffer where
liftM DrawFramebuffer $ peek ptr
instance IsBindable DrawFramebuffer where
- bind (DrawFramebuffer fb) = glBindFramebuffer gl_DRAW_FRAMEBUFFER fb
+ bind (DrawFramebuffer fb) = glBindFramebuffer GL_DRAW_FRAMEBUFFER fb
instance IsWrappedPrimitive GLuint DrawFramebuffer where
unwrap (DrawFramebuffer fb) = fb
wrap = DrawFramebuffer
instance IsFramebuffer DrawFramebuffer where
- getType _ = gl_DRAW_FRAMEBUFFER
+ getType _ = GL_DRAW_FRAMEBUFFER
diff --git a/Graphics/Glyph/GeometryBuilder.hs b/Graphics/Glyph/GeometryBuilder.hs
index 31be715..53c6681 100644
--- a/Graphics/Glyph/GeometryBuilder.hs
+++ b/Graphics/Glyph/GeometryBuilder.hs
@@ -3,7 +3,6 @@
module Graphics.Glyph.GeometryBuilder where
import Data.Sequence as Seq
-import Data.Setters
import Data.Maybe
import Graphics.Glyph.Util
@@ -95,10 +94,8 @@ data GeometryBuilder a = GeometryBuilder {
gRet :: a
}
-$(declareSetters ''GeometryBuilder)
-
generating :: OutType -> GeometryBuilder () -> GeometryBuilder ()
-generating TriangleStrip builder = setGOutType (Just TriangleStrip) $ builder
+generating TriangleStrip builder = builder { gOutType = Just TriangleStrip }
generating Triangles builder = do
let (nSeq,_) =
Fold.foldl' (\(tSeq,cnt) datum ->
@@ -109,45 +106,57 @@ generating Triangles builder = do
_ -> (tSeq |> datum,cnt)
) (Seq.empty, 0) (gList builder)
- setGOutType (Just Triangles) $
- setGList nSeq builder
+ builder {
+ gOutType = Just Triangles,
+ gList = nSeq
+ }
projectionMatrixUniform :: String -> GeometryBuilder ()
-projectionMatrixUniform str = setPjMatrixUniform (Just str) $ return ()
+projectionMatrixUniform str = (return ()) { pjMatrixUniform = (Just str) }
modelViewMatrixUniform :: String -> GeometryBuilder ()
-modelViewMatrixUniform str = setMvMatrixUniform (Just str) $ return ()
+modelViewMatrixUniform str = (return ()) { mvMatrixUniform = (Just str) }
maxVerticies :: Int -> GeometryBuilder ()
-maxVerticies i = setMaxVerts (Just i) $ return ()
+maxVerticies i = (return ()) { maxVerts = (Just i) }
textureOutput :: String -> GeometryBuilder ()
-textureOutput str = setTextureOut (Just str) $ return ()
+textureOutput str = (return ()) { textureOut = (Just str) }
normalOutput :: String -> GeometryBuilder ()
-normalOutput str = setNormalOut (Just str) $ return ()
+normalOutput str = (return ()) { normalOut = (Just str) }
positionOutput :: String -> GeometryBuilder ()
-positionOutput str = setPositionOut (Just str) $ return ()
+positionOutput str = (return ()) { positionOut = (Just str) }
gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder ()
-gVertex4 x y z w = setGList (Seq.singleton $ Vertex x y z w) $ return ()
+gVertex4 x y z w = (return ()) { gList = Seq.singleton $ Vertex x y z w }
gNormal3 :: Float -> Float -> Float -> GeometryBuilder ()
-gNormal3 x y z = setGList (Seq.singleton $ Normal x y z) $ return ()
+gNormal3 x y z = (return ()) { gList = (Seq.singleton $ Normal x y z) }
gTexture2 :: Float -> Float -> GeometryBuilder ()
-gTexture2 x y = setGList (Seq.singleton $ Texture x y) $ return ()
+gTexture2 x y = (return ()) { gList = (Seq.singleton $ Texture x y) }
gEmitVertex :: GeometryBuilder ()
-gEmitVertex = setGList (Seq.singleton $ EmitVertex) $ return ()
+gEmitVertex = (return ()) { gList = (Seq.singleton $ EmitVertex) }
gEndPrimitive :: GeometryBuilder ()
-gEndPrimitive = setGList (Seq.singleton $ EndPrimitive) $ return ()
+gEndPrimitive = (return ()) { gList = Seq.singleton $ EndPrimitive }
gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder ()
gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex
+instance Functor GeometryBuilder where
+ fmap f bb = bb >>= (return . f)
+
+instance Applicative GeometryBuilder where
+ (<*>) afn aa = do
+ fn <- afn
+ a <- aa
+ return (fn a)
+
+ pure = return
instance Monad GeometryBuilder where
aB >> bB = GeometryBuilder
@@ -171,7 +180,6 @@ instance Monad GeometryBuilder where
Nothing
Nothing
Nothing
- fail = error
instance IsModelBuilder Float GeometryBuilder where
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
index 29d25bb..db7b47c 100644
--- a/Graphics/Glyph/GlyphObject.hs
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
-
module Graphics.Glyph.GlyphObject (
GlyphObject,
getBufferObject,
@@ -32,9 +30,8 @@ module Graphics.Glyph.GlyphObject (
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
-import Graphics.Rendering.OpenGL
+import Graphics.Rendering.OpenGL as GL
import Graphics.Glyph.ExtendedGL as Ex
-import Data.Setters
import Control.Monad
import Control.Applicative
@@ -59,7 +56,6 @@ data GlyphObject a = GlyphObject {
numInstances :: Int
}
-$(declareSetters ''GlyphObject)
getBufferObject :: GlyphObject a -> BufferObject
getBufferObject = bufferObject
@@ -90,6 +86,43 @@ getTeardownRoutine = teardownRoutine
getPrimitiveMode :: GlyphObject a -> ExPrimitiveMode
getPrimitiveMode = primitiveMode
+setBufferObject :: GlyphObject a -> BufferObject -> GlyphObject a
+setBufferObject o a = o {bufferObject = a}
+
+setCompiledData :: GlyphObject a -> (CompiledBuild GLfloat) -> GlyphObject a
+setCompiledData o a = o {compiledData = a}
+
+setVertexAttribute :: GlyphObject a -> AttribLocation -> GlyphObject a
+setVertexAttribute o a = o {vertexAttribute = a}
+
+setNormalAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
+setNormalAttribute o a = o {normalAttribute = 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}
+
+setResources :: GlyphObject a -> a -> GlyphObject a
+setResources o a = o {resources = a}
+
+setSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
+setSetupRoutine o a = o {setupRoutine = a}
+
+setSetupRoutine2 :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
+setSetupRoutine2 o a = o {setupRoutine2 = a}
+
+setTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
+setTeardownRoutine o a = o {teardownRoutine = a}
+
+setPrimitiveMode :: GlyphObject a -> ExPrimitiveMode -> GlyphObject a
+setPrimitiveMode o a = o {primitiveMode = a}
+
+setNumInstances :: GlyphObject a -> Int -> GlyphObject a
+setNumInstances o a = o {numInstances = a}
+
+
newGlyphObject :: BuilderM GLfloat x ->
AttribLocation ->
Maybe AttribLocation ->
@@ -107,13 +140,13 @@ newGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear mo
return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup Nothing tear mode 1
prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-prepare a b = setSetupRoutine2 (Just b) a
+prepare a b = setSetupRoutine2 a (Just b)
startClosure :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-startClosure a b = setSetupRoutine (Just b) a
+startClosure a b = setSetupRoutine a (Just b)
teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-teardown a b = setTeardownRoutine (Just b) a
+teardown a b = setTeardownRoutine a (Just b)
instance Drawable (GlyphObject a) where
draw = drawInstances <..> numInstances
@@ -139,7 +172,13 @@ drawInstances n obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup1 setup2 t
vertexAttribPointer attr $= (ToFloat, ad)
vertexAttribArray attr $= Enabled
- drawArraysInstanced p 0 (bufferLength co) $ fromIntegral n
+ let p' = case p of
+ Ex.Points -> GL.Points
+ Ex.Lines -> GL.Lines
+ Ex.Triangles -> GL.Triangles
+ Ex.Patches -> GL.Patches
+
+ drawArraysInstanced p' 0 (bufferLength co) $ fromIntegral n
forM_ enabled $ \(attr, _) -> do
vertexAttribArray attr $= Disabled
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
index c1ae485..7d54b05 100644
--- a/Graphics/Glyph/Mat4.hs
+++ b/Graphics/Glyph/Mat4.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
module Graphics.Glyph.Mat4 where
import Control.Monad
@@ -9,8 +9,9 @@ import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL (Uniform(..),uniform,UniformLocation(..),makeStateVar)
-import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.GL.Core43
+{- ORMOLU_DISABLE -};
data Mat4 a = Matrix4 (a,a,a,a,
a,a,a,a,
a,a,a,a,
@@ -19,6 +20,7 @@ data Mat4 a = Matrix4 (a,a,a,a,
data Mat3 a = Matrix3 ( a,a,a,
a,a,a,
a,a,a ) | IdentityMatrix3
+{- ORMOLU_ENABLE -};
class StorableMatrix t a where
fromList :: [t] -> a t
@@ -85,7 +87,7 @@ instance (Storable t) => StorableMatrix t Mat3 where
instance Uniform (Mat4 GLfloat) where
uniform (UniformLocation loc) = makeStateVar getter setter
where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix4fv loc 1 (fromIntegral gl_FALSE) ptr
+ glUniformMatrix4fv loc 1 (fromIntegral GL_FALSE) ptr
getter :: IO (Mat4 GLfloat)
getter = do
pid <- liftM fromIntegral getCurrentProgram
@@ -97,7 +99,7 @@ instance Uniform (Mat4 GLfloat) where
instance Uniform (Mat3 GLfloat) where
uniform (UniformLocation loc) = makeStateVar getter setter
where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix3fv loc 1 (fromIntegral gl_FALSE) ptr
+ glUniformMatrix3fv loc 1 (fromIntegral GL_FALSE) ptr
getter :: IO (Mat3 GLfloat)
getter = do
pid <- liftM fromIntegral getCurrentProgram
@@ -107,7 +109,7 @@ instance Uniform (Mat3 GLfloat) where
uniformv _ = undefined
getCurrentProgram :: IO GLint
-getCurrentProgram = alloca $ glGetIntegerv gl_CURRENT_PROGRAM >> peek
+getCurrentProgram = alloca $ \ptr -> glGetIntegerv GL_CURRENT_PROGRAM ptr >> peek ptr
instance (Show a) => Show (Mat4 a) where
show IdentityMatrix =
diff --git a/Graphics/Glyph/ObjLoader.hs b/Graphics/Glyph/ObjLoader.hs
index 78f010a..b392a26 100644
--- a/Graphics/Glyph/ObjLoader.hs
+++ b/Graphics/Glyph/ObjLoader.hs
@@ -4,9 +4,9 @@ import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
import Debug.Trace
+import Data.List.Split
import Control.Monad
import Data.Either
-import Data.String.Utils
import Data.Array
import System.IO
import qualified Data.Map as M
@@ -82,7 +82,7 @@ loadObjFromBytestring _contents =
"" -> -1
_ -> read str in
- let s2t s = case split "/" s of
+ let s2t s = case splitOn "/" s of
[a,b,c] -> Just (mapT3 mys2n (a,b,c))
[a,b] -> Just (mapT3 mys2n (a,b,""))
[a] -> Just (mapT3 mys2n (a,"",""))
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
index 7e86d2a..ec3e12f 100644
--- a/Graphics/Glyph/Textures.hs
+++ b/Graphics/Glyph/Textures.hs
@@ -1,11 +1,10 @@
module Graphics.Glyph.Textures where
+import Control.Monad
import Data.Array.Storable
import Data.Word
-
-import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.GL.Compatibility30
import Graphics.Rendering.OpenGL
-import Control.Monad
data Pixels =
PixelsRGB (Int,Int) (StorableArray Int Word8) |
@@ -32,8 +31,8 @@ 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
+ 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 e8a5974..1c1269d 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -286,11 +286,20 @@ plusM a = MonadPlusBuilder a ()
runMonadPlusBuilder :: MonadPlusBuilder a b -> a
runMonadPlusBuilder (MonadPlusBuilder !a _) = a
+instance (MonadPlus a) => Functor (MonadPlusBuilder (a b)) where
+ fmap f b = b >>= return . f
+
+instance (MonadPlus a) => Applicative (MonadPlusBuilder (a b)) where
+ (<*>) afn aa = do
+ fn <- afn
+ fn <$> aa
+
+ pure = return
+
instance (MonadPlus a) => Monad (MonadPlusBuilder (a b)) where
return = MonadPlusBuilder mzero
MonadPlusBuilder a1 _ >> MonadPlusBuilder a2 b = MonadPlusBuilder (a1 `mplus` a2) b
builder@(MonadPlusBuilder _ b) >>= f = builder >> f b
- fail = undefined
untilM2 :: (Monad m) => (a -> m Bool) -> a -> (a -> m a) -> m a
untilM2 cond ini bod = do
diff --git a/Graphics/Rendering/HelpGL.hs b/Graphics/Rendering/HelpGL.hs
index 3ea66eb..938147e 100644
--- a/Graphics/Rendering/HelpGL.hs
+++ b/Graphics/Rendering/HelpGL.hs
@@ -3,7 +3,6 @@ module Graphics.Rendering.HelpGL
where
import Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
import Foreign.Ptr
import Foreign.Marshal.Array
diff --git a/Graphics/SDL/SDLHelp.hs b/Graphics/SDL/SDLHelp.hs
index 75806b2..62bb640 100644
--- a/Graphics/SDL/SDLHelp.hs
+++ b/Graphics/SDL/SDLHelp.hs
@@ -1,13 +1,15 @@
+{-# LANGUAGE OverloadedStrings, LambdaCase, ViewPatterns, RankNTypes #-}
module Graphics.SDL.SDLHelp where
-import Graphics.UI.SDL.Image as SDLImg
-import Graphics.UI.SDL as SDL
import Data.Word
import Control.Monad
import Graphics.Glyph.Util
+import SDL as SDL
+import SDL.Video.Renderer (SurfacePixelFormat(..))
+
+import Graphics.GL.Compatibility30
import Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
import Foreign.Storable
import Foreign.Ptr
@@ -28,22 +30,21 @@ data TextureData3D = TextureData3D {
bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
bindSurfaceToTexture surf to = do
- textureBinding Texture2D $= Just to
- bbp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
- putStrLn $ "bpp: " ++! bbp
- 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
+ textureBinding Texture2D $= Just to
+ bbp <- return 4 -- 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
textureFromPointer3D :: Ptr Word8 -> (Int,Int,Int) -> TextureObject -> IO TextureData3D
textureFromPointer3D ptr (w,h,d) to = do
textureBinding Texture3D $= Just to
- glTexImage3D gl_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 gl_RGB gl_UNSIGNED_BYTE ptr
+ glTexImage3D GL_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 GL_RGB GL_UNSIGNED_BYTE ptr
return $ TextureData3D (w,h,d) to
where f = fromIntegral
@@ -66,9 +67,10 @@ makeTexture = do
getPixel :: Int -> Int -> SDL.Surface -> IO Word32
getPixel x y surf = do
- bpp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
- ptr <- (surfaceGetPixels surf >>= return.castPtr) :: IO (Ptr Word8)
- let newPtr = ptr `plusPtr` (y * (fromIntegral $ surfaceGetPitch surf)) `plusPtr` (x * bpp)
+ bpp <- return 3 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
+ ptr <- (surfacePixels surf >>= return.castPtr) :: IO (Ptr Word8)
+ (V2 w h) <- SDL.surfaceDimensions surf
+ let newPtr = ptr `plusPtr` (y * bpp * fromIntegral w) `plusPtr` (x * bpp)
ret <- case bpp of
-- bytes = R G B A
@@ -105,37 +107,54 @@ wordToPixel word =
getRGBA :: SDL.Surface -> Int -> Int -> IO (Color4 Word8)
getRGBA surf x y = liftM wordToPixel $ getPixel x y surf
-simpleStartup :: String -> (Int,Int) -> IO Surface
+simpleStartup :: String -> (Int,Int) -> IO SDL.Window
simpleStartup name' (w,h) = do
- SDL.init [SDL.InitEverything]
- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
- SDL.setCaption name' name'
- SDL.getVideoSurface
+ SDL.initialize [SDL.InitVideo]
+ SDL.HintRenderScaleQuality $= SDL.ScaleLinear
+ renderQuality <- SDL.get SDL.HintRenderScaleQuality
+ when (renderQuality /= SDL.ScaleLinear) $
+ putStrLn "Warning: Linear texture filtering not enabled!"
+
+ window <-
+ SDL.createWindow
+ "SDL / OpenGL Example"
+ SDL.defaultWindow
+ { SDL.windowInitialSize = V2 1920 1080,
+ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+ }
+ SDL.showWindow window
+
+ _ <- SDL.glCreateContext window
+ return window
defaultReshape :: Int -> Int -> a -> IO a
defaultReshape w h ret = do
let size = Size (fromIntegral w) (fromIntegral h)
viewport $=(Position 0 0, size)
- _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
+ -- _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
return ret
-startPipeline :: (Int -> Int -> a -> IO a) -> (Event -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
+startPipeline :: forall a. (Int -> Int -> a -> IO a) -> (SDL.EventPayload -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
startPipeline reshapeH eventH displayH updateH ini = do
+
let pumpEvents' res = do
- ev <- SDL.pollEvent
- case ev of
- Quit -> do
- putStrLn "Exit event."
- exitSuccess
- SDL.NoEvent -> return res
- VideoResize w h -> reshapeH w h res >>= pumpEvents'
- _ -> eventH ev res >>= pumpEvents'
- let runPipeline val = do
+ evs <- SDL.pollEvents
+ foldM (\res (SDL.eventPayload -> ev) -> case ev of
+ SDL.QuitEvent -> exitSuccess >> return res
+ _ -> eventH ev res) res evs
+ -- case ev of
+ -- Quit -> do
+ -- putStrLn "Exit event."
+ -- exitSuccess
+ -- SDL.NoEvent -> return res
+ -- VideoResize w h -> reshapeH w h res >>= pumpEvents'
+ -- _ -> eventH ev res >>= pumpEvents'
+ runPipeline val = do
res <- pumpEvents' val >>= displayH
- SDL.glSwapBuffers `seq` (updateH res) >>= runPipeline
+ updateH res >>= runPipeline
- -- TODO unhardcode this
- reshapeH 640 480 ini >>= runPipeline
+ -- -- TODO unhardcode this
+ reshapeH 1920 1080 ini >>= runPipeline
setupTexturing :: TextureData -> UniformLocation -> Int -> IO ()
setupTexturing (TextureData _ to) tu unit = do
diff --git a/Models.hs b/Models.hs
index 3f15288..3d154e6 100644
--- a/Models.hs
+++ b/Models.hs
@@ -53,8 +53,8 @@ tree =
forM_ [0..6.4] $ \th -> do
let vertex x y z = do
- gNormal3 x 0 z
- gVertex4E x y z 0
+ gNormal3 x 0 z
+ gVertex4E x y z 0
let c = r * cos th
let s = r * sin th
@@ -75,8 +75,8 @@ tree =
forM_ [0..6.4] $ \th -> do
let vertex x y z = do
- gNormal3 x 0 z
- gVertex4E x y z 0
+ gNormal3 x 0 z
+ gVertex4E x y z 0
let c = r * 4 * cos th
let s = r * 4 * sin th
diff --git a/Resources.hs b/Resources.hs
index 30d129b..009bdac 100644
--- a/Resources.hs
+++ b/Resources.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
module Resources where
-import Graphics.UI.SDL as SDL
-import Graphics.UI.SDL.Image as SDLImg
+import qualified SDL
+import qualified SDL.Image
import Foreign.Storable
import Foreign.Ptr
@@ -19,14 +19,13 @@ import Graphics.Glyph.Mat4
import Graphics.Glyph.Util
import Graphics.Glyph.ExtendedGL as Ex
import Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.GL.Compatibility30
import Control.Applicative
import Control.Monad
import Data.Angle
import Data.Function
-import Data.Setters
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold
import Data.Maybe
@@ -35,15 +34,22 @@ import Debug.Trace
import System.Exit
import qualified Data.Array.IO as ArrIO
-import TileShow
-
import Data.Array
import qualified Data.StateVar as SV
{- Types of terrain which are possible -}
data TileType = Forest | Beach | Water | Grass | Jungle | Mountains |
Tundra | Unknown deriving (Enum,Eq)
-$(makeShow ''TileType)
+instance Show TileType where
+ show = \case
+ Forest -> "F"
+ Beach -> "B"
+ Water -> "W"
+ Grass -> "G"
+ Jungle -> "J"
+ Mountains -> "M"
+ Tundra -> "T"
+ Unknown -> "?"
{- A tile has 2 things, a type and
- elevation, however, the term tile is
@@ -64,7 +70,7 @@ data CameraPosition = CameraPosition {
{- The central data type for rendering
- the scene. Contains the 'global' information -}
data Resources = Resources {
- rSurface :: SDL.Surface,
+ rWindow :: SDL.Window,
rPosition :: CameraPosition,
rDPosition :: CameraPosition,
@@ -85,6 +91,49 @@ data Resources = Resources {
waterArray :: ArrIO.IOArray (Int,Int) GLfloat
}
+setRSurface :: SDL.Window -> Resources -> Resources
+setRSurface x r = r { rWindow = x }
+
+setRPosition :: CameraPosition -> Resources -> Resources
+setRPosition x r = r { rPosition = x }
+
+setRDPosition :: CameraPosition -> Resources -> Resources
+setRDPosition x r = r { rDPosition = x }
+
+setPMatrix :: Mat4 GLfloat -> Resources -> Resources
+setPMatrix x r = r { pMatrix = x }
+
+setMvMatrix :: Mat4 GLfloat -> Resources -> Resources
+setMvMatrix x r = r { mvMatrix = x }
+
+setRoutines :: [ResourcesClosure -> IO ()] -> Resources -> Resources
+setRoutines x r = r { routines = x }
+
+setSpeed :: GLfloat -> Resources -> Resources
+setSpeed x r = r { speed = x }
+
+setTimeSpeed :: Int -> Resources -> Resources
+setTimeSpeed x r = r { timeSpeed = x }
+
+setTime :: Int -> Resources -> Resources
+setTime x r = r { time = x }
+
+setHeightMap :: Array (Int,Int) Tile -> Resources -> Resources
+setHeightMap x r = r { heightMap = x }
+
+setPositionUpdate :: (Resources -> IO Resources) -> Resources -> Resources
+setPositionUpdate x r = r { positionUpdate = x }
+
+setSpeedFactor :: GLfloat -> Resources -> Resources
+setSpeedFactor x r = r { speedFactor = x }
+
+setDDown :: GLfloat -> Resources -> Resources
+setDDown x r = r { dDown = x }
+
+setWaterArray :: ArrIO.IOArray (Int,Int) GLfloat -> Resources -> Resources
+setWaterArray x r = r { waterArray = x }
+
+
{- Central data type for rendering each frame -}
data ResourcesClosure = ResourcesClosure {
rcMVMatrix :: Mat4 GLfloat
@@ -98,8 +147,6 @@ data ResourcesClosure = ResourcesClosure {
, rcResources :: Resources
}
-$(declareSetters ''Resources)
-
{- A function that makes the resources data first
- person -}
firstPerson :: Resources -> IO Resources
@@ -153,80 +200,104 @@ buildMVMatrix (CameraPosition eye th ph) =
{- Called after each frame to crunch throught the
- events -}
-eventHandle :: SDL.Event -> Resources -> IO Resources
-eventHandle event res = do
- let (CameraPosition eye th ph) = rDPosition res
- let (CameraPosition peye pth pph) = rPosition res
- case event of
- KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess
-
- KeyDown (Keysym SDLK_EQUALS _ _) ->
- return $ (setTimeSpeed <..> ((+1).timeSpeed)) res
- KeyDown (Keysym SDLK_MINUS _ _) ->
- return $ (setTimeSpeed <..> ((subtract 1).timeSpeed)) res
-
- KeyDown (Keysym SDLK_UP _ _) ->
- return $ setRDPosition (CameraPosition eye th (ph+1)) res
- KeyDown (Keysym SDLK_DOWN _ _) ->
- return $ setRDPosition (CameraPosition eye th (ph-1)) res
- KeyDown (Keysym SDLK_RIGHT _ _) ->
- return $ setRDPosition (CameraPosition eye (th+1) ph) res
- KeyDown (Keysym SDLK_LEFT _ _) ->
- return $ setRDPosition (CameraPosition eye (th-1) ph) res
-
- KeyUp (Keysym SDLK_UP _ _) ->
- return $ setRDPosition (CameraPosition eye th (ph-1)) res
- KeyUp (Keysym SDLK_DOWN _ _) ->
- return $ setRDPosition (CameraPosition eye th (ph+1)) res
- KeyUp (Keysym SDLK_RIGHT _ _) ->
- return $ setRDPosition (CameraPosition eye (th-1) ph) res
- KeyUp (Keysym SDLK_LEFT _ _) ->
- return $ setRDPosition (CameraPosition eye (th+1) ph) res
-
- MouseMotion _ _ x y -> do
- return $ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res
-
- KeyDown (Keysym SDLK_w _ _) ->
- return $ setSpeed (speed res + speedFactor res) res
- KeyDown (Keysym SDLK_s _ _) ->
- return $ setSpeed (speed res - speedFactor res) res
- KeyUp (Keysym SDLK_w _ _) ->
- return $ setSpeed 0 res
- KeyUp (Keysym SDLK_s _ _) ->
- return $ setSpeed 0 res
-
- KeyUp (Keysym SDLK_q _ _) ->
- let getY (Vec3 (_,y,_)) = y in
- return $
- setPositionUpdate firstPerson $
- setSpeedFactor 0.1 $
- (setDDown <..> (negate . getY . resourcesVelocity)) res
- KeyUp (Keysym SDLK_e _ _) ->
- return $
- setPositionUpdate return $
- setSpeedFactor 1 $
- if speed res > 0 then setSpeed 1 res else res
-
- KeyUp (Keysym SDLK_f _ _) -> do
- ret <- reshape 1920 1080 res
- SDL.toggleFullscreen $ rSurface ret
- SDL.showCursor False
- SDL.grabInput True
- return ret
- KeyUp (Keysym SDLK_g _ _) -> do
- SDL.showCursor False
- SDL.grabInput True
- return res
-
- KeyDown (Keysym SDLK_SPACE _ _) -> do
- return $ setDDown (-0.3) res
-
- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
- return $ (setSpeed <..> ((*3) . speed)) res
- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
- return $ (setSpeed <..> ((/3) . speed)) res
-
- _ -> return res
+eventHandle :: SDL.EventPayload -> Resources -> IO Resources
+eventHandle event = case event of
+ SDL.KeyboardEvent e ->
+ case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
+ (SDL.Pressed, SDL.ScancodeW) -> setPh 1
+ (SDL.Released, SDL.ScancodeW) -> setPh 0
+ (SDL.Pressed, SDL.ScancodeA) -> setTh (-1)
+ (SDL.Released, SDL.ScancodeA) -> setTh 0
+ (SDL.Pressed, SDL.ScancodeS) -> setPh (-1)
+ (SDL.Released, SDL.ScancodeS) -> setPh 0
+ (SDL.Pressed, SDL.ScancodeD) -> setTh 1
+ (SDL.Released, SDL.ScancodeD) -> setTh 0
+ (SDL.Pressed, SDL.ScancodeI) -> \res -> return $ setSpeed (speedFactor res) res
+ (SDL.Released, SDL.ScancodeI) -> return . setSpeed 0
+ (SDL.Pressed, SDL.ScancodeK) -> \res -> return $ setSpeed (0 - speedFactor res) res
+ (SDL.Released, SDL.ScancodeK) -> return . setSpeed 0
+ _ -> return
+ _ -> return
+
+ where
+ setPh i res =
+ let (CameraPosition eye th ph) = rDPosition res in
+ return $ setRDPosition (CameraPosition eye th i) res
+ setTh i res =
+ let (CameraPosition eye th ph) = rDPosition res in
+ return $ setRDPosition (CameraPosition eye i ph) res
+ -- let (CameraPosition eye th ph) = rDPosition res
+ -- let (CameraPosition peye pth pph) = rPosition res
+ -- case event of
+ -- KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess
+
+ -- KeyDown (Keysym SDLK_EQUALS _ _) ->
+ -- return $ (setTimeSpeed <..> ((+1).timeSpeed)) res
+ -- KeyDown (Keysym SDLK_MINUS _ _) ->
+ -- return $ (setTimeSpeed <..> ((subtract 1).timeSpeed)) res
+
+ -- KeyDown (Keysym SDLK_UP _ _) ->
+ -- return $ setRDPosition (CameraPosition eye th (ph+1)) res
+ -- KeyDown (Keysym SDLK_DOWN _ _) ->
+ -- return $ setRDPosition (CameraPosition eye th (ph-1)) res
+ -- KeyDown (Keysym SDLK_RIGHT _ _) ->
+ -- return $ setRDPosition (CameraPosition eye (th+1) ph) res
+ -- KeyDown (Keysym SDLK_LEFT _ _) ->
+ -- return $ setRDPosition (CameraPosition eye (th-1) ph) res
+
+ -- KeyUp (Keysym SDLK_UP _ _) ->
+ -- return $ setRDPosition (CameraPosition eye th (ph-1)) res
+ -- KeyUp (Keysym SDLK_DOWN _ _) ->
+ -- return $ setRDPosition (CameraPosition eye th (ph+1)) res
+ -- KeyUp (Keysym SDLK_RIGHT _ _) ->
+ -- return $ setRDPosition (CameraPosition eye (th-1) ph) res
+ -- KeyUp (Keysym SDLK_LEFT _ _) ->
+ -- return $ setRDPosition (CameraPosition eye (th+1) ph) res
+
+ -- MouseMotion _ _ x y -> do
+ -- return $ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res
+
+ -- KeyDown (Keysym SDLK_w _ _) ->
+ -- return $ setSpeed (speed res + speedFactor res) res
+ -- KeyDown (Keysym SDLK_s _ _) ->
+ -- return $ setSpeed (speed res - speedFactor res) res
+ -- KeyUp (Keysym SDLK_w _ _) ->
+ -- return $ setSpeed 0 res
+ -- KeyUp (Keysym SDLK_s _ _) ->
+ -- return $ setSpeed 0 res
+
+ -- KeyUp (Keysym SDLK_q _ _) ->
+ -- let getY (Vec3 (_,y,_)) = y in
+ -- return $
+ -- setPositionUpdate firstPerson $
+ -- setSpeedFactor 0.1 $
+ -- (setDDown <..> (negate . getY . resourcesVelocity)) res
+ -- KeyUp (Keysym SDLK_e _ _) ->
+ -- return $
+ -- setPositionUpdate return $
+ -- setSpeedFactor 1 $
+ -- if speed res > 0 then setSpeed 1 res else res
+
+ -- KeyUp (Keysym SDLK_f _ _) -> do
+ -- ret <- reshape 1920 1080 res
+ -- SDL.toggleFullscreen $ rSurface ret
+ -- SDL.showCursor False
+ -- SDL.grabInput True
+ -- return ret
+ -- KeyUp (Keysym SDLK_g _ _) -> do
+ -- SDL.showCursor False
+ -- SDL.grabInput True
+ -- return res
+
+ -- KeyDown (Keysym SDLK_SPACE _ _) -> do
+ -- return $ setDDown (-0.3) res
+
+ -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ (setSpeed <..> ((*3) . speed)) res
+ -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do
+ -- return $ (setSpeed <..> ((/3) . speed)) res
+
+ -- _ -> return res
{- Callback for the display -}
displayHandle :: Resources -> IO Resources
@@ -246,7 +317,6 @@ displayHandle resources = do
clearColor $= Color4 0 0 0 0
clear [ColorBuffer, DepthBuffer]
- SDL.flip $ rSurface resources
printErrors "Display"
@@ -262,7 +332,7 @@ displayHandle resources = do
in mapM_ (Prelude.$rc) $ routines resources
- SDL.glSwapBuffers
+ SDL.glSwapWindow (rWindow resources)
return resources
cameraToEuclidian :: CameraPosition -> Vec3 GLfloat
@@ -323,7 +393,7 @@ buildTerrainObject builder = do
terrainProg <- loadProgramSafe' "shaders/basic.vert" "shaders/basic.frag" (Nothing::Maybe String)
lst <- forM (zip [0..7::Int] $ terrainList ++ repeat "terrain/unknown.png") $ \(idx,str) -> do
location <- get $ uniformLocation terrainProg $ "textures[" ++! idx ++ "]"
- load str >>= textureFromSurface >>= return . (,) location
+ SDL.Image.load str >>= textureFromSurface >>= return . (,) location
let (dx,dy) = (mapT2 $ (1/).fromIntegral) (mapT2 maximum (unzip $ map (textureSize.snd) lst));
dXlocation <- get $ uniformLocation terrainProg "dX"
@@ -394,7 +464,7 @@ buildForestObject a_seq obj tex =
forestProg <- loadProgramSafe'
"shaders/forest.vert" "shaders/forest.frag" noShader
- woodTexture <- load tex >>= textureFromSurface
+ woodTexture <- SDL.Image.load tex >>= textureFromSurface
let (dx,dy) = (mapT2 $ (1/).fromIntegral) (textureSize woodTexture)
dXlocation <- get $ uniformLocation forestProg "dX"
dYlocation <- get $ uniformLocation forestProg "dY"
@@ -426,7 +496,7 @@ buildForestObject a_seq obj tex =
printErrors "forestClosure"
putStrLn $ "N trees = " ++! (Seq.length a_seq `div` 3)
- let obj'' = setNumInstances (Seq.length a_seq `div` 3) obj'
+ let obj'' = setNumInstances obj' (Seq.length a_seq `div` 3)
return $ \rc -> do
draw $ (prepare obj'') $ \_ -> do
@@ -442,13 +512,13 @@ buildWaterObject builder = do
waterProg <- loadProgramFullSafe'
(Just ("shaders/water.tcs","shaders/water.tes"))
noShader "shaders/water.vert" "shaders/water.frag"
- waterTexture <- load "textures/water.jpg" >>= textureFromSurface
- skyTexture <- load "textures/skybox_top.png" >>= textureFromSurface
- skyNightTexture <- load "textures/skybox_top_night.png" >>= textureFromSurface
+ waterTexture <- SDL.Image.load "textures/water.jpg" >>= textureFromSurface
+ skyTexture <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
+ skyNightTexture <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
location <- get (uniformLocation waterProg "texture")
skyLocation <- get (uniformLocation waterProg "skytex")
skyNightLocation <- get (uniformLocation waterProg "skynight")
- obj <- (liftM (setPrimitiveMode Ex.Patches) $ newDefaultGlyphObjectWithClosure builder () $ \_ -> do
+ obj <- (liftM (flip setPrimitiveMode Ex.Patches) $ newDefaultGlyphObjectWithClosure builder () $ \_ -> do
currentProgram $= Just waterProg
setupTexturing waterTexture location 0
setupTexturing skyTexture skyLocation 1
@@ -458,7 +528,7 @@ buildWaterObject builder = do
return $ \rc -> do
draw $ prepare obj $ \_ -> do
cullFace $= Nothing
- patchVertices SV.$= (4::Int)
+ GL.patchVertices $= 4
uniform (UniformLocation 4) $= rcPMatrix rc
uniform (UniformLocation 5) $= rcMVMatrix rc
uniform (UniformLocation 7) $= rcNormalMatrix rc
@@ -471,11 +541,11 @@ buildWaterObject builder = do
uniform fogU $= Index1 (0.0::GLfloat)
-makeResources :: SDL.Surface -> BuilderM GLfloat b ->
+makeResources :: SDL.Window -> BuilderM GLfloat b ->
Seq.Seq GLfloat -> Seq.Seq GLfloat ->
BuilderM GLfloat a -> Array (Int,Int) Tile ->
ArrIO.IOArray (Int,Int) GLfloat -> IO Resources
-makeResources surf builder forestB jungleB water arr waterarr = do
+makeResources window builder forestB jungleB water arr waterarr = do
let pMatrix' = perspectiveMatrix 50 1.8 0.1 100
let l_routines = sequence [
@@ -494,7 +564,7 @@ makeResources surf builder forestB jungleB water arr waterarr = do
-- cloudProgram
]
Resources
- <$> pure surf
+ <$> pure window
<*> do CameraPosition
<$> pure (Vec3 (10,10,2))
<*> pure 0
@@ -565,18 +635,18 @@ skyboxObject = do
matLoc <- get $ uniformLocation prog "mvMatrix"
pmatLoc <- get $ uniformLocation prog "pjMatrix"
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
- l_texture <- load "textures/skybox_sides.png" >>= textureFromSurface
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
- l_texture2 <- load "textures/skybox_sides_night.png" >>= textureFromSurface
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
- l_textureTop <- load "textures/skybox_top.png" >>= textureFromSurface
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
- l_textureTopNight <- load "textures/skybox_top_night.png" >>= textureFromSurface
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_texture <- SDL.Image.load "textures/skybox_sides.png" >>= textureFromSurface
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_texture2 <- SDL.Image.load "textures/skybox_sides_night.png" >>= textureFromSurface
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_textureTop <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
+ l_textureTopNight <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
[lightposU,multU] <- mapM (get . uniformLocation prog)
["lightpos","mult"]
@@ -585,13 +655,14 @@ skyboxObject = do
setupTexturing l_textureTopNight texLocNight 3
obj <- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc,pmatLoc) $ \_ -> do
- currentProgram $= Just prog
- setupTexturing l_texture texLoc 0
- setupTexturing l_texture2 texLocNight 1
- printErrors "Skybox"
+ currentProgram $= Just prog
+ setupTexturing l_texture texLoc 0
+ setupTexturing l_texture2 texLocNight 1
+ printErrors "Skybox"
let obj' = teardown obj $ \_ -> do
- draw topObj
+ draw topObj
+
return $ \rc -> do
depthFunc $= Nothing
cullFace $= Nothing
diff --git a/Terralloc.cabal b/Terralloc.cabal
deleted file mode 100644
index 7281d81..0000000
--- a/Terralloc.cabal
+++ /dev/null
@@ -1,25 +0,0 @@
--- Initial jora2470_hw2.cabal generated by cabal init. For further
--- documentation, see http://haskell.org/cabal/users-guide/
-
---enable-library-profiling and/or
---enable-executable-profiling.
-name: homework9
-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 terralloc.bin
- main-is: Final.hs
- extensions: FlexibleInstances
- ghc-options: -rtsopts -O3
- -- ghc-options: -prof -osuf h_o
- -- other-modules:
- build-depends: setters, base, OpenGL, bytestring, array, SDL, random, OpenGLRaw, AC-Angle, deepseq, containers, SDL-image, cpu, template-haskell, filepath, MissingH, StateVar
diff --git a/TileShow.hs b/TileShow.hs
deleted file mode 100644
index dd353dc..0000000
--- a/TileShow.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module TileShow where
-import Language.Haskell.TH
-
-makeShow t = do
- TyConI (DataD _ _ _ constructors _) <- reify t
- -- Make `show` clause for one constructor:
- -- show (A x1 x2) = "A "++show x1++" "++show x2
- let showClause (NormalC name fields) = do
- -- Name of constructor, i.e. "A". Will become string literal in generated code
- let constructorName = [(head $ nameBase name)]
- -- Generate function clause for one constructor
- clause [conP name []] -- (A x1 x2)
- (normalB [| constructorName |]) [] -- "A "++show x1++" "++show x2
- -- Make body for function `show`:
- -- show (A x1 x2) = "A "++show x1++" "++show x2
- -- show (B x1) = "B "++show x1
- -- show C = "C"
- showbody <- mapM showClause constructors
- -- Generate template instance declaration and then replace
- -- type name (T1) and function body (\x -> "text") with our data
- d <- [d| instance Show String where
- show _x = "text"
- |]
- let [InstanceD [] (AppT showt (ConT _T1)) [FunD showf _text]] = d
- return [InstanceD [] (AppT showt (ConT t )) [FunD showf showbody]]
diff --git a/terralloc b/terralloc
deleted file mode 100755
index 3280cbe..0000000
--- a/terralloc
+++ /dev/null
@@ -1,3 +0,0 @@
-#!/bin/bash
-
-PATH="$PATH:dist/build/terralloc.bin/" terralloc.bin +RTS -K3000000000 -RTS $@
generated by cgit (git 2.34.1) at 2025-04-28 11:15:29 +0000