diff options
Diffstat (limited to 'Resources.hs')
| -rw-r--r-- | Resources.hs | 1407 |
1 files changed, 734 insertions, 673 deletions
diff --git a/Resources.hs b/Resources.hs index ce38b21..da5040e 100644 --- a/Resources.hs +++ b/Resources.hs @@ -1,580 +1,612 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} -module Resources where -import qualified SDL -import qualified SDL.Image +module Resources where -import Foreign.Storable -import Foreign.Ptr +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Data.Angle +import Data.Array +import qualified Data.Array.IO as ArrIO +import qualified Data.Foldable as Fold +import Data.Function +import Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.StateVar as SV +import Data.Time.Clock.POSIX +import Debug.Trace import Foreign.Marshal.Array - +import Foreign.Ptr +import Foreign.Storable +import Graphics.GL.Compatibility30 +import Graphics.Glyph.BufferBuilder +import Graphics.Glyph.ExtendedGL as Ex import Graphics.Glyph.GLMath as V import Graphics.Glyph.GlyphObject +import Graphics.Glyph.Mat4 import Graphics.Glyph.ObjLoader import Graphics.Glyph.Shaders -import Graphics.SDL.SDLHelp -import Graphics.Glyph.BufferBuilder -import Graphics.Glyph.Mat4 import Graphics.Glyph.Util -import Graphics.Glyph.ExtendedGL as Ex import Graphics.Rendering.OpenGL as GL -import Graphics.GL.Compatibility30 - -import Control.Applicative -import Control.Monad - -import Data.Angle -import Data.Function -import qualified Data.Sequence as Seq -import qualified Data.Foldable as Fold -import Data.Maybe -import Debug.Trace - +import Graphics.SDL.SDLHelp +import qualified SDL +import qualified SDL.Image import System.Exit -import qualified Data.Array.IO as ArrIO - -import Data.Array -import qualified Data.StateVar as SV -import Data.Time.Clock.POSIX -import Control.Concurrent -import Text.Printf import System.IO import System.Random hiding (uniform) -import qualified SDL +import Text.Printf {- Types of terrain which are possible -} -data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | - Tundra | Unknown deriving (Enum,Eq) +data TileType + = Forest + | Beach + | Water + | Grass + | Jungle + | Mountains + | Tundra + | Unknown + deriving (Enum, Eq) + instance Show TileType where - show = \case - Forest -> "F" - Beach -> "B" - Water -> "W" - Grass -> "G" - Jungle -> "J" - Mountains -> "M" - Tundra -> "T" - Unknown -> "?" + 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 - a litte misleading, it is really a point. -} -data Tile = Tile { - tileType :: TileType, +data Tile = Tile + { tileType :: TileType, elevation :: Int -} deriving Show + } + deriving (Show) {- Position of the camera as described by - polar coordinates -} -data CameraPosition = CameraPosition { - pEye :: Vec3 GLfloat, +data CameraPosition = CameraPosition + { pEye :: Vec3 GLfloat, pTh :: GLfloat, pPh :: GLfloat -} deriving Show + } + deriving (Show) {- The central data type for rendering - the scene. Contains the 'global' information -} -data Resources = Resources { - rWindow :: SDL.Window, - +data Resources = Resources + { rWindow :: SDL.Window, rPosition :: CameraPosition, rDPosition :: CameraPosition, - pMatrix :: Mat4 GLfloat, mvMatrix :: Mat4 GLfloat, - routines :: [ResourcesClosure -> IO ()], - timeSpeed :: Int, time :: Int, - - heightMap :: Array (Int,Int) Tile, + heightMap :: Array (Int, Int) Tile, positionUpdate :: (Resources -> IO Resources), - {- Smaller if in first person -} speedFactor :: GLfloat, {- Higher if shift is held -} speedMultiplier :: GLfloat, {- Direction -} speedDirection :: Vec3 GLfloat, - dDown :: GLfloat, - waterArray :: ArrIO.IOArray (Int,Int) GLfloat, + waterArray :: ArrIO.IOArray (Int, Int) GLfloat, headBob :: GLfloat, mode :: CameraMode, threadDiff :: Double -} + } setHeadBob :: GLfloat -> Resources -> Resources -setHeadBob f r = r { headBob = f } +setHeadBob f r = r {headBob = f} setThreadDiff :: Double -> Resources -> Resources -setThreadDiff f r = r { threadDiff = f } +setThreadDiff f r = r {threadDiff = f} setRSurface :: SDL.Window -> Resources -> Resources -setRSurface x r = r { rWindow = x } +setRSurface x r = r {rWindow = x} setRPosition :: CameraPosition -> Resources -> Resources -setRPosition x r = r { rPosition = x } +setRPosition x r = r {rPosition = x} setRDPosition :: CameraPosition -> Resources -> Resources -setRDPosition x r = r { rDPosition = x } +setRDPosition x r = r {rDPosition = x} setPMatrix :: Mat4 GLfloat -> Resources -> Resources -setPMatrix x r = r { pMatrix = x } +setPMatrix x r = r {pMatrix = x} setMvMatrix :: Mat4 GLfloat -> Resources -> Resources -setMvMatrix x r = r { mvMatrix = x } +setMvMatrix x r = r {mvMatrix = x} setRoutines :: [ResourcesClosure -> IO ()] -> Resources -> Resources -setRoutines x r = r { routines = x } +setRoutines x r = r {routines = x} setSpeedDirection :: Vec3 GLfloat -> Resources -> Resources -setSpeedDirection x r = r { speedDirection = x } +setSpeedDirection x r = r {speedDirection = x} setTimeSpeed :: Int -> Resources -> Resources -setTimeSpeed x r = r { timeSpeed = x } +setTimeSpeed x r = r {timeSpeed = x} setTime :: Int -> Resources -> Resources -setTime x r = r { time = x } +setTime x r = r {time = x} -setHeightMap :: Array (Int,Int) Tile -> Resources -> Resources -setHeightMap x r = r { heightMap = 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 } +setPositionUpdate x r = r {positionUpdate = x} setSpeedFactor :: GLfloat -> Resources -> Resources -setSpeedFactor x r = r { speedFactor = x } +setSpeedFactor x r = r {speedFactor = x} setDDown :: GLfloat -> Resources -> Resources -setDDown x r = r { dDown = x } +setDDown x r = r {dDown = x} -setWaterArray :: ArrIO.IOArray (Int,Int) GLfloat -> Resources -> Resources -setWaterArray x r = r { waterArray = x } +setWaterArray :: ArrIO.IOArray (Int, Int) GLfloat -> Resources -> Resources +setWaterArray x r = r {waterArray = x} getSpeed :: Resources -> GLfloat -getSpeed res =speedFactor res * speedMultiplier res * norm (speedDirection res) +getSpeed res = speedFactor res * speedMultiplier res * norm (speedDirection res) cameraForward :: CameraPosition -> Vec3 GLfloat -cameraForward (CameraPosition _ th ph) = Vec3 $ toEuclidian (1,th,ph) +cameraForward (CameraPosition _ th ph) = Vec3 $ toEuclidian (1, th, ph) cameraUp :: CameraPosition -> Vec3 GLfloat -cameraUp (CameraPosition _ _ ph) = - if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0) - where ph' = (floor ph::Int) `mod` 360 +cameraUp (CameraPosition _ _ ph) = + if ph' >= 90 && ph' < 270 then Vec3 (0, -1, 0) else Vec3 (0, 1, 0) + where + ph' = (floor ph :: Int) `mod` 360 cameraRight :: CameraPosition -> Vec3 GLfloat cameraRight cam = cameraUp cam × cameraForward cam - getVelocity :: Resources -> Vec3 GLfloat getVelocity res = - let dir = speedDirection res - camdir = cameraForward $ rPosition res - truedir = coordinateConvert camdir (Vec3 (0,1,0)) dir in - getSpeed res `vScale` maybeNormalize truedir + let dir = speedDirection res + camdir = cameraForward $ rPosition res + truedir = coordinateConvert camdir (Vec3 (0, 1, 0)) dir + in getSpeed res `vScale` maybeNormalize truedir -data CameraMode = Oracle | FirstPerson deriving Eq +data CameraMode = Oracle | FirstPerson deriving (Eq) {- Central data type for rendering each frame -} -data ResourcesClosure = ResourcesClosure { - rcMVMatrix :: Mat4 GLfloat - , rcPMatrix :: Mat4 GLfloat - , rcLightPos :: Vec4 GLfloat - , rcTime :: GLfloat - , rcNormalMatrix :: Mat3 GLfloat - , rcGlobalAmbient :: Vec4 GLfloat - , rcCameraPos :: CameraPosition - , rcCameraLocation :: Vec3 GLfloat - , rcResources :: Resources -} +data ResourcesClosure = ResourcesClosure + { rcMVMatrix :: Mat4 GLfloat, + rcPMatrix :: Mat4 GLfloat, + rcLightPos :: Vec4 GLfloat, + rcTime :: GLfloat, + rcNormalMatrix :: Mat3 GLfloat, + rcGlobalAmbient :: Vec4 GLfloat, + rcCameraPos :: CameraPosition, + rcCameraLocation :: Vec3 GLfloat, + rcResources :: Resources + } {- A function that makes the resources data first - person -} firstPerson :: Resources -> IO Resources firstPerson res = - let camera@(CameraPosition (Vec3 (x,curh,y)) th ph) = rPosition res - (_,(w,h)) = bounds $ heightMap res - (!!!) arr (x',y') = if x' < 0 || y' < 0 || x' > w || y' > h then -1000 else elevation (arr ! (x',y')) - h1 = ((/10.0).fromIntegral) (heightMap res !!! (floor x, floor y) ) - h2 = ((/10.0).fromIntegral) (heightMap res !!! (floor x, floor (y+1)) ) - h3 = ((/10.0).fromIntegral) (heightMap res !!! (floor (x+1), floor y) ) - h4 = ((/10.0).fromIntegral) (heightMap res !!! (floor (x+1), floor (y+1))) - u = x - (int $ (floor x::Int)) - v = y - (int $ (floor y::Int)) - mixu1 = mix h3 h1 u - mixu2 = mix h4 h2 u - newh = mix mixu2 mixu1 v - droph = curh - dDown res - speed = getSpeed res - jitter = (max 0 $ speed - 0.029) ** 0.1 / 2 - dy = sin (headBob res*2) * jitter - dx = realToFrac $ cos (headBob res) * jitter - in do - return $ ((setHeadBob.(+ jitter)) <..> headBob) $ - if (newh+0.3 > droph) then - setSpeedFactor 0.03 $ - setRPosition (CameraPosition (Vec3 (x,newh+0.2,y)) (th + (asin dx) * speed * 15) (ph - (asin dy) * speed * 15)) $ + let camera@(CameraPosition (Vec3 (x, curh, y)) th ph) = rPosition res + (_, (w, h)) = bounds $ heightMap res + (!!!) arr (x', y') = if x' < 0 || y' < 0 || x' > w || y' > h then -1000 else elevation (arr ! (x', y')) + h1 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor x, floor y)) + h2 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor x, floor (y + 1))) + h3 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor (x + 1), floor y)) + h4 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor (x + 1), floor (y + 1))) + u = x - (int $ (floor x :: Int)) + v = y - (int $ (floor y :: Int)) + mixu1 = mix h3 h1 u + mixu2 = mix h4 h2 u + newh = mix mixu2 mixu1 v + droph = curh - dDown res + speed = getSpeed res + jitter = (max 0 $ speed - 0.029) ** 0.1 / 2 + dy = sin (headBob res * 2) * jitter + dx = realToFrac $ cos (headBob res) * jitter + in do + return $ + ((setHeadBob . (+ jitter)) <..> headBob) $ + if (newh + 0.3 > droph) + then + setSpeedFactor 0.03 $ + setRPosition (CameraPosition (Vec3 (x, newh + 0.2, y)) (th + (asin dx) * speed * 15) (ph - (asin dy) * speed * 15)) $ setDDown 0 res - else + else setRPosition (CameraPosition (Vec3 (x, droph, y)) th ph) $ - setDDown (dDown res + 0.03) res + setDDown (dDown res + 0.03) res {- A function which will explode if a uniform - does not exist for the shader given, otherwis, - it will return a list of uniform locations -} getUniformsSafe :: Program -> [String] -> IO [UniformLocation] getUniformsSafe prog uniforms = - forM uniforms $ \a_uniform -> do - tmp <- get $ uniformLocation prog a_uniform - case tmp of - UniformLocation (-1) -> do - putStrLn $ "No uniform with name: "++a_uniform - exitWith (ExitFailure 112) - _ -> return tmp + forM uniforms $ \a_uniform -> do + tmp <- get $ uniformLocation prog a_uniform + case tmp of + UniformLocation (-1) -> do + putStrLn $ "No uniform with name: " ++ a_uniform + exitWith (ExitFailure 112) + _ -> return tmp {- Builds an model view matrix given the - camera position of the scene -} buildMVMatrix :: CameraPosition -> Mat4 GLfloat buildMVMatrix camera@(CameraPosition eye _ _) = - let lookat = eye <+> cameraForward camera in - lookAtMatrix eye lookat (cameraUp camera) + let lookat = eye <+> cameraForward camera + in lookAtMatrix eye lookat (cameraUp camera) {- Called after each frame to crunch throught the - events -} 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 2 - (SDL.Released, SDL.ScancodeW) -> setPh 0 - (SDL.Pressed, SDL.ScancodeA) -> setTh (-2) - (SDL.Released, SDL.ScancodeA) -> setTh 0 - (SDL.Pressed, SDL.ScancodeS) -> setPh (-2) - (SDL.Released, SDL.ScancodeS) -> setPh 0 - (SDL.Pressed, SDL.ScancodeD) -> setTh 2 - (SDL.Released, SDL.ScancodeD) -> setTh 0 - (SDL.Pressed, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 1)) - (SDL.Released, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 0)) - (SDL.Pressed, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, -1)) - (SDL.Released, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, 0)) - - -- Pressing the 'q' enters first-person-mode - (SDL.Pressed, SDL.ScancodeQ) -> return . appAll - [setPositionUpdate firstPerson, - setSpeedFactor 0.1, - \res -> res { dDown = negate $ (\(Vec3 (_,y,_)) -> y) $ resourcesVelocity res}] - - (SDL.Pressed, SDL.ScancodeE) -> return . appAll - [setPositionUpdate return, - setSpeedFactor 1, - \res -> res { dDown = 0 }] - - (SDL.Pressed, SDL.ScancodeSpace) -> return . appAll - [setSpeedFactor 0.05, - \res -> res { dDown = -0.2 }] - - (SDL.Pressed, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 4 } - - (SDL.Released, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 1 } - - -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do - -- return $ setSpeedMultiplier 4 res - - -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do - -- return $ setSpeedMultiplier 1 res - -- KeyUp (Keysym SDLK_e _ _) -> - -- return $ - -- setPositionUpdate return $ - -- setSpeedFactor 1 $ - -- if speed res > 0 then setSpeed 1 res else res - - _ -> return - _ -> return - - where - appAll :: [a -> a] -> a -> a - appAll (f:fs) a = appAll fs (f a) - appAll [] a = a - - 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 + SDL.KeyboardEvent e -> + case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of + (SDL.Pressed, SDL.ScancodeW) -> setPh 2 + (SDL.Released, SDL.ScancodeW) -> setPh 0 + (SDL.Pressed, SDL.ScancodeA) -> setTh (-2) + (SDL.Released, SDL.ScancodeA) -> setTh 0 + (SDL.Pressed, SDL.ScancodeS) -> setPh (-2) + (SDL.Released, SDL.ScancodeS) -> setPh 0 + (SDL.Pressed, SDL.ScancodeD) -> setTh 2 + (SDL.Released, SDL.ScancodeD) -> setTh 0 + (SDL.Pressed, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 1)) + (SDL.Released, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 0)) + (SDL.Pressed, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, -1)) + (SDL.Released, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, 0)) + -- Pressing the 'q' enters first-person-mode + (SDL.Pressed, SDL.ScancodeQ) -> + return + . appAll + [ setPositionUpdate firstPerson, + setSpeedFactor 0.1, + \res -> res {dDown = negate $ (\(Vec3 (_, y, _)) -> y) $ resourcesVelocity res} + ] + (SDL.Pressed, SDL.ScancodeE) -> + return + . appAll + [ setPositionUpdate return, + setSpeedFactor 1, + \res -> res {dDown = 0} + ] + (SDL.Pressed, SDL.ScancodeSpace) -> + return + . appAll + [ setSpeedFactor 0.05, + \res -> res {dDown = -0.2} + ] + (SDL.Pressed, SDL.ScancodeLShift) -> \res -> return $ res {speedMultiplier = 4} + (SDL.Released, SDL.ScancodeLShift) -> \res -> return $ res {speedMultiplier = 1} + -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do + -- return $ setSpeedMultiplier 4 res + + -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do + -- return $ setSpeedMultiplier 1 res + -- KeyUp (Keysym SDLK_e _ _) -> + -- return $ + -- setPositionUpdate return $ + -- setSpeedFactor 1 $ + -- if speed res > 0 then setSpeed 1 res else res + + _ -> return + _ -> return + where + appAll :: [a -> a] -> a -> a + appAll (f : fs) a = appAll fs (f a) + appAll [] a = a + + 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 -- 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 - -- MouseMotion _ _ x y -> do - -- return $ - -- setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res - - -- KeyDown (Keysym SDLK_w _ _) -> - -- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res - -- KeyDown (Keysym SDLK_s _ _) -> - -- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res - -- KeyDown (Keysym SDLK_d _ _) -> - -- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res - -- KeyDown (Keysym SDLK_a _ _) -> - -- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res - - -- KeyUp (Keysym SDLK_w _ _) -> - -- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res - -- KeyUp (Keysym SDLK_s _ _) -> - -- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res - -- KeyUp (Keysym SDLK_d _ _) -> - -- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res - -- KeyUp (Keysym SDLK_a _ _) -> - -- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res - - -- KeyUp (Keysym SDLK_q _ _) -> - -- let getY (Vec3 (_,y,_)) = y in - -- return $ - -- setPositionUpdate firstPerson $ - -- setMode FirstPerson $ - -- (setDDown <..> (negate . getY . resourcesVelocity)) res - -- KeyUp (Keysym SDLK_e _ _) -> - -- return $ - -- setPositionUpdate return $ - -- setSpeedFactor 1 $ - -- setMode Oracle 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_c _ _) -> do - -- SDL.showCursor True - -- SDL.grabInput False - -- return res - -- KeyUp (Keysym SDLK_g _ _) -> do - -- SDL.showCursor False - -- SDL.grabInput True - -- return res - - -- KeyDown (Keysym SDLK_SPACE _ _) -> do - -- return $ - -- setDDown (-0.2) $ - -- setSpeedFactor 0.05 res - - -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do - -- return $ setSpeedMultiplier 4 res - - -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do - -- return $ setSpeedMultiplier 1 res - - -- KeyDown (Keysym SDLK_LSHIFT _ _) -> do - -- return $ (setSpeed <..> ((*3) . speed)) res - -- KeyUp (Keysym SDLK_LSHIFT _ _) -> do - -- return $ (setSpeed <..> ((/3) . speed)) res - - -- _ -> return 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 +-- MouseMotion _ _ x y -> do +-- return $ +-- setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res + +-- KeyDown (Keysym SDLK_w _ _) -> +-- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res +-- KeyDown (Keysym SDLK_s _ _) -> +-- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res +-- KeyDown (Keysym SDLK_d _ _) -> +-- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res +-- KeyDown (Keysym SDLK_a _ _) -> +-- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res + +-- KeyUp (Keysym SDLK_w _ _) -> +-- return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res +-- KeyUp (Keysym SDLK_s _ _) -> +-- return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res +-- KeyUp (Keysym SDLK_d _ _) -> +-- return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res +-- KeyUp (Keysym SDLK_a _ _) -> +-- return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res + +-- KeyUp (Keysym SDLK_q _ _) -> +-- let getY (Vec3 (_,y,_)) = y in +-- return $ +-- setPositionUpdate firstPerson $ +-- setMode FirstPerson $ +-- (setDDown <..> (negate . getY . resourcesVelocity)) res +-- KeyUp (Keysym SDLK_e _ _) -> +-- return $ +-- setPositionUpdate return $ +-- setSpeedFactor 1 $ +-- setMode Oracle 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_c _ _) -> do +-- SDL.showCursor True +-- SDL.grabInput False +-- return res +-- KeyUp (Keysym SDLK_g _ _) -> do +-- SDL.showCursor False +-- SDL.grabInput True +-- return res + +-- KeyDown (Keysym SDLK_SPACE _ _) -> do +-- return $ +-- setDDown (-0.2) $ +-- setSpeedFactor 0.05 res + +-- KeyDown (Keysym SDLK_LSHIFT _ _) -> do +-- return $ setSpeedMultiplier 4 res + +-- KeyUp (Keysym SDLK_LSHIFT _ _) -> do +-- return $ setSpeedMultiplier 1 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 displayHandle resources = do - time1 <- getPOSIXTime - let cameraPos@(CameraPosition loc _ _) = rPosition resources - let lighty = ((/10) . fromIntegral . time) resources - let logist c = (1 / (1 + 2.71828**(-c*x))) * 0.9 + 0.1 - where x = sine $ Degrees (lighty) - let globalAmbient::(GLfloat,GLfloat,GLfloat,GLfloat) - globalAmbient = ( logist 2+0.1, logist 10, (logist 15) + 0.1,(sine.Degrees) lighty) - let lightPos = Vec4( 50, - 1000000 * (sine.Degrees $ lighty), - -1000000 * (cosine.Degrees . (/10) . fromIntegral . time) resources, - 1 ) - let l_mvMatrix = buildMVMatrix $ cameraPos - let normalMatrix = glslModelViewToNormalMatrix l_mvMatrix - - clearColor $= Color4 0 0 0 0 - clear [ColorBuffer, DepthBuffer] - printErrors "Display" - - - let rc = ResourcesClosure l_mvMatrix - (pMatrix resources) - (l_mvMatrix `glslMatMul` lightPos) - (fromIntegral $ time resources) - (normalMatrix) - (Vec4 globalAmbient) - cameraPos - loc - resources - - in mapM_ (Prelude.$rc) $ routines resources - - SDL.glSwapWindow (rWindow resources) - time2 <- getPOSIXTime - - let diff = threadDiff resources - (realToFrac $ time2 - time1) - when (diff > 0) (threadDelay $ round $ diff * 1000000) - time3 <- getPOSIXTime - let fps = realToFrac $ 1 / (time3 - time1) :: Double - - putStr $ printf "FPS: %.2f\r" fps - - return $ - if' (fps < 30) - ((setThreadDiff.(subtract 0.0001)) <..> threadDiff) - ((setThreadDiff.(+0.0001)) <..> threadDiff) resources + time1 <- getPOSIXTime + let cameraPos@(CameraPosition loc _ _) = rPosition resources + let lighty = ((/ 10) . fromIntegral . time) resources + let logist c = (1 / (1 + 2.71828 ** (- c * x))) * 0.9 + 0.1 + where + x = sine $ Degrees (lighty) + let globalAmbient :: (GLfloat, GLfloat, GLfloat, GLfloat) + globalAmbient = (logist 2 + 0.1, logist 10, (logist 15) + 0.1, (sine . Degrees) lighty) + let lightPos = + Vec4 + ( 50, + 1000000 * (sine . Degrees $ lighty), + -1000000 * (cosine . Degrees . (/ 10) . fromIntegral . time) resources, + 1 + ) + let l_mvMatrix = buildMVMatrix $ cameraPos + let normalMatrix = glslModelViewToNormalMatrix l_mvMatrix + + clearColor $= Color4 0 0 0 0 + clear [ColorBuffer, DepthBuffer] + printErrors "Display" + + let rc = + ResourcesClosure + l_mvMatrix + (pMatrix resources) + (l_mvMatrix `glslMatMul` lightPos) + (fromIntegral $ time resources) + (normalMatrix) + (Vec4 globalAmbient) + cameraPos + loc + resources + in mapM_ (Prelude.$ rc) $ routines resources + + SDL.glSwapWindow (rWindow resources) + time2 <- getPOSIXTime + + let diff = threadDiff resources - (realToFrac $ time2 - time1) + when (diff > 0) (threadDelay $ round $ diff * 1000000) + time3 <- getPOSIXTime + let fps = realToFrac $ 1 / (time3 - time1) :: Double + + putStr $ printf "FPS: %.2f\r" fps + + return $ + if' + (fps < 30) + ((setThreadDiff . (subtract 0.0001)) <..> threadDiff) + ((setThreadDiff . (+ 0.0001)) <..> threadDiff) + resources cameraToEuclidian :: CameraPosition -> Vec3 GLfloat -cameraToEuclidian (CameraPosition _ ph th) = V.normalize $ Vec3 $ toEuclidian (1,ph,th) +cameraToEuclidian (CameraPosition _ ph th) = V.normalize $ Vec3 $ toEuclidian (1, ph, th) resourcesVelocity :: Resources -> Vec3 GLfloat resourcesVelocity res = getSpeed res `vScale` cameraToEuclidian (rPosition res) resourcesUnderWater :: Resources -> IO Bool resourcesUnderWater res = do - let (CameraPosition (Vec3 (x,ch,y)) _ _) = rPosition res - (_,(w,h)) <- ArrIO.getBounds $ waterArray res - if x < 0 || y < 0 || x > int w || y > int h then return False else do - height <- ArrIO.readArray (waterArray res) (floor x, floor y) - return (height > ch && height >= 0) + let (CameraPosition (Vec3 (x, ch, y)) _ _) = rPosition res + (_, (w, h)) <- ArrIO.getBounds $ waterArray res + if x < 0 || y < 0 || x > int w || y > int h + then return False + else do + height <- ArrIO.readArray (waterArray res) (floor x, floor y) + return (height > ch && height >= 0) updateHandle :: Resources -> IO Resources updateHandle res = do - (positionUpdate res) $ setRPosition (rPosition res `cAdd` rDPosition res) $ - let new = ((+) `on` (Prelude.$ res)) timeSpeed time in - setTime new res - where (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') = - let x' = getVelocity res in - CameraPosition (x <+> x') (y + y') (z + z') + (positionUpdate res) $ + setRPosition (rPosition res `cAdd` rDPosition res) $ + let new = ((+) `on` (Prelude.$ res)) timeSpeed time + in setTime new res + where + (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') = + let x' = getVelocity res + in CameraPosition (x <+> x') (y + y') (z + z') reshape :: Int -> Int -> Resources -> IO Resources reshape w h res = - defaultReshape w h () >> do - let pMatrix' = perspectiveMatrix 50 (fromIntegral w / fromIntegral h) 0.1 10000 - return $ setPMatrix pMatrix' res + defaultReshape w h () >> do + let pMatrix' = perspectiveMatrix 50 (fromIntegral w / fromIntegral h) 0.1 10000 + return $ setPMatrix pMatrix' res loadProgramSafe' :: - (IsShaderSource a, - IsShaderSource b, - IsShaderSource c) => a -> b -> Maybe c -> IO Program + ( IsShaderSource a, + IsShaderSource b, + IsShaderSource c + ) => + a -> + b -> + Maybe c -> + IO Program loadProgramSafe' s1 s2 s3 = do - progMaybe <- loadProgramSafe s1 s2 s3 - when (isNothing progMaybe) $ exitWith (ExitFailure 111) - return $ fromJust progMaybe - -loadProgramFullSafe' :: - (IsShaderSource tc, IsShaderSource te, - IsShaderSource g, IsShaderSource v, - IsShaderSource f) => Maybe (tc, te) -> Maybe g -> v -> f -> IO Program + progMaybe <- loadProgramSafe s1 s2 s3 + when (isNothing progMaybe) $ exitWith (ExitFailure 111) + return $ fromJust progMaybe + +loadProgramFullSafe' :: + ( IsShaderSource tc, + IsShaderSource te, + IsShaderSource g, + IsShaderSource v, + IsShaderSource f + ) => + Maybe (tc, te) -> + Maybe g -> + v -> + f -> + IO Program loadProgramFullSafe' a b c d = do - progMaybe <- loadProgramFullSafe a b c d - when (isNothing progMaybe) $ exitWith (ExitFailure 111) - return $ fromJust progMaybe + progMaybe <- loadProgramFullSafe a b c d + when (isNothing progMaybe) $ exitWith (ExitFailure 111) + return $ fromJust progMaybe buildTerrainObject :: BuilderM GLfloat b -> IO (ResourcesClosure -> IO ()) buildTerrainObject builder = do - let terrainList = map ("terrain/"++) - [ "forest.png", "beach.png", - "oceanfloor.png", "grass.png", - "jungle.png", "mountains.png", - "tundra.png" ] - print terrainList - 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 ++ "]" - 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" - dYlocation <- get $ uniformLocation terrainProg "dY" - putStrLn $ "(dx,dy)=" ++! (dx,dy) - obj <- newDefaultGlyphObjectWithClosure builder () $ \_ -> do - currentProgram $= Just terrainProg - forM_ (zip [0..] lst) $ \(i,(loc,td)) -> - setupTexturing td loc i - uniform dXlocation $= Index1 (dx::GLfloat) - uniform dYlocation $= Index1 (dy::GLfloat) - printErrors "terrainObjectClosure" - - [lightposU, globalAmbientU, pjMatrixU, mvMatrixU, normalMatrixU, fogU] - <- getUniformsSafe terrainProg ["lightPos","globalAmbient","pjMatrix","mvMatrix","normalMatrix","fog"] - return $ \rc -> do - draw $ prepare obj $ \_ -> do - cullFace $= Just Front - uniform mvMatrixU $= rcMVMatrix rc - uniform pjMatrixU $= rcPMatrix rc - uniform lightposU $= rcLightPos rc - uniform normalMatrixU $= rcNormalMatrix rc - uniform globalAmbientU $= rcGlobalAmbient rc - bool <- (resourcesUnderWater $ rcResources rc) - if bool then |