diff options
Diffstat (limited to 'Resources.hs')
| -rw-r--r-- | Resources.hs | 301 |
1 files changed, 186 insertions, 115 deletions
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 |