diff options
Diffstat (limited to 'Resources.hs')
| -rw-r--r-- | Resources.hs | 266 |
1 files changed, 231 insertions, 35 deletions
diff --git a/Resources.hs b/Resources.hs index 009bdac..d446796 100644 --- a/Resources.hs +++ b/Resources.hs @@ -36,6 +36,12 @@ 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 {- Types of terrain which are possible -} data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | @@ -80,17 +86,32 @@ data Resources = Resources { routines :: [ResourcesClosure -> IO ()], - speed :: GLfloat, timeSpeed :: Int, time :: Int, 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 } + +setThreadDiff :: Double -> Resources -> Resources +setThreadDiff f r = r { threadDiff = f } + setRSurface :: SDL.Window -> Resources -> Resources setRSurface x r = r { rWindow = x } @@ -109,8 +130,8 @@ 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 } +setSpeedDirection :: Vec3 GLfloat -> Resources -> Resources +setSpeedDirection x r = r { speedDirection = x } setTimeSpeed :: Int -> Resources -> Resources setTimeSpeed x r = r { timeSpeed = x } @@ -133,6 +154,29 @@ setDDown x r = r { dDown = 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) + +cameraForward :: CameraPosition -> Vec3 GLfloat +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 + +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 + +data CameraMode = Oracle | FirstPerson deriving Eq {- Central data type for rendering each frame -} data ResourcesClosure = ResourcesClosure { @@ -151,7 +195,7 @@ data ResourcesClosure = ResourcesClosure { - person -} firstPerson :: Resources -> IO Resources firstPerson res = - let (CameraPosition (Vec3 (x,curh,y)) th ph) = rPosition 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) ) @@ -162,19 +206,21 @@ firstPerson res = v = y - (int $ (floor y::Int)) mixu1 = mix h3 h1 u mixu2 = mix h4 h2 u - newh = mix mixu2 mixu1 v + 0.2 + 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 $ - if (newh+0.2 > droph) then - setRPosition (CameraPosition (Vec3 (x,newh,y)) th ph) $ - setDDown 0 $ - if speed res > speedFactor res then - (setSpeed <..> speedFactor) res - else res + 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 setRPosition (CameraPosition (Vec3 (x, droph, y)) th ph) $ - setDDown (dDown res + 0.05) res + setDDown (dDown res + 0.03) res {- A function which will explode if a uniform - does not exist for the shader given, otherwis, @@ -192,11 +238,9 @@ getUniformsSafe prog uniforms = {- Builds an model view matrix given the - camera position of the scene -} buildMVMatrix :: CameraPosition -> Mat4 GLfloat -buildMVMatrix (CameraPosition eye th ph) = - let up = if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0) - where ph' = (floor ph::Int) `mod` 360 in - let lookat = eye <+> (Vec3 $ toEuclidian (1,th,ph)) in - lookAtMatrix eye lookat up +buildMVMatrix camera@(CameraPosition eye _ _) = + let lookat = eye <+> cameraForward camera in + lookAtMatrix eye lookat (cameraUp camera) {- Called after each frame to crunch throught the - events -} @@ -204,28 +248,66 @@ 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.Pressed, SDL.ScancodeW) -> setPh 2 (SDL.Released, SDL.ScancodeW) -> setPh 0 - (SDL.Pressed, SDL.ScancodeA) -> setTh (-1) + (SDL.Pressed, SDL.ScancodeA) -> setTh (-2) (SDL.Released, SDL.ScancodeA) -> setTh 0 - (SDL.Pressed, SDL.ScancodeS) -> setPh (-1) + (SDL.Pressed, SDL.ScancodeS) -> setPh (-2) (SDL.Released, SDL.ScancodeS) -> setPh 0 - (SDL.Pressed, SDL.ScancodeD) -> setTh 1 + (SDL.Pressed, SDL.ScancodeD) -> setTh 2 (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 + (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 @@ -291,6 +373,65 @@ eventHandle event = case event of -- 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 @@ -302,6 +443,7 @@ eventHandle event = case event of {- 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 @@ -333,13 +475,25 @@ displayHandle resources = do in mapM_ (Prelude.$rc) $ routines resources SDL.glSwapWindow (rWindow resources) - return 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) resourcesVelocity :: Resources -> Vec3 GLfloat -resourcesVelocity res = speed res `vScale` cameraToEuclidian (rPosition res) +resourcesVelocity res = getSpeed res `vScale` cameraToEuclidian (rPosition res) resourcesUnderWater :: Resources -> IO Bool resourcesUnderWater res = do @@ -355,8 +509,8 @@ updateHandle res = do let new = ((+) `on` (Prelude.$ res)) timeSpeed time in setTime new res where (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') = - let x' = speed res `vScale` (V.normalize $ Vec3 $ toEuclidian (1,y, z)) in - (CameraPosition (x <+> x') (y + y') (z + z')) + let x' = getVelocity res in + CameraPosition (x <+> x') (y + y') (z + z') reshape :: Int -> Int -> Resources -> IO Resources reshape w h res = @@ -449,6 +603,41 @@ buildTerrainObject builder = do -- uniform lightposU $= rcLightPos rc -- setupTexturing3D density densityU 0 +buildSnowVal :: Array (Int,Int) Tile -> StdGen -> BuilderM GLfloat () +buildSnowVal arr gen = + let (_,(w,h)) = bounds arr + run :: [Int] -> (Int,Int) -> BuilderM GLfloat [Int] + run rs (x,y) = do + let (seed:npart:t) = rs + nStdGen = mkStdGen seed + height = elevation (arr ! (x,y)) + when (tileType (arr ! (x,y)) == Tundra) $ + forM_ (take (npart`mod`50) $ chunkList3 $ randomRs (0::GLfloat,1) nStdGen ) $ \(a,b,c) -> do + let (x',y') = (int x + a, int y + b) + bVertex3 (x',c*100,y') + bColor4 (int $ height `div` 10,1, 0, 0) + + return t + in + + foldM_ run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]] + +buildSnowObject :: Array (Int,Int) Tile -> StdGen -> IO (ResourcesClosure -> IO ()) +buildSnowObject arr gen = do + snowProgram <- loadProgramSafe' "shaders/snow.vert" "shaders/snow.frag" (Just "shaders/snow.geom") + obj <- + liftM (flip setPrimitiveMode Ex.Points) $ + newDefaultGlyphObjectWithClosure (buildSnowVal arr gen) () $ \_ -> do + currentProgram $= Just snowProgram + + [globalAmbientU,pjMatrixU,mvMatrixU,timeU] <- + getUniformsSafe snowProgram ["globalAmbient","pjMatrix","mvMatrix","time"] + return $ \rc -> do + draw $ (prepare obj) $ \_ -> do + uniform mvMatrixU $= rcMVMatrix rc + uniform pjMatrixU $= rcPMatrix rc + uniform timeU $= (Index1 $ (rcTime rc/75)) + uniform globalAmbientU $= rcGlobalAmbient rc buildForestObject :: Seq.Seq GLfloat -> String -> String -> IO (ResourcesClosure -> IO ()) buildForestObject a_seq obj tex = @@ -533,7 +722,7 @@ buildWaterObject builder = do uniform (UniformLocation 5) $= rcMVMatrix rc uniform (UniformLocation 7) $= rcNormalMatrix rc uniform (UniformLocation 8) $= rcLightPos rc - uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0) + uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0); uniform (UniformLocation 10) $= rcGlobalAmbient rc bool <- (resourcesUnderWater $ rcResources rc) if bool then @@ -546,8 +735,10 @@ makeResources :: SDL.Window -> BuilderM GLfloat b -> BuilderM GLfloat a -> Array (Int,Int) Tile -> ArrIO.IOArray (Int,Int) GLfloat -> IO Resources makeResources window builder forestB jungleB water arr waterarr = do + hSetBuffering stdout NoBuffering let pMatrix' = perspectiveMatrix 50 1.8 0.1 100 + stdgen <- newStdGen let l_routines = sequence [ skyboxObject, (return $ \_ -> do @@ -558,15 +749,16 @@ makeResources window builder forestB jungleB water arr waterarr = do blend $= Enabled cullFace $= Just Back blendFunc $= (GL.SrcAlpha,OneMinusSrcAlpha)), + buildWaterObject water, buildForestObject forestB "tree.obj" "textures/wood_low.png", buildForestObject jungleB "jungletree.obj" "textures/jungle_tree.png", - buildWaterObject water + buildSnowObject arr stdgen -- cloudProgram ] Resources <$> pure window <*> do CameraPosition - <$> pure (Vec3 (10,10,2)) + <$> pure (Vec3 (10,10,-10)) <*> pure 0 <*> pure 0 <*> do CameraPosition @@ -576,14 +768,18 @@ makeResources window builder forestB jungleB water arr waterarr = do <*> pure pMatrix' <*> pure pMatrix' <*> l_routines - <*> pure 0 <*> pure 1 <*> pure 0 <*> pure arr <*> pure return <*> pure 1 + <*> pure 1 + <*> pure (Vec3 (0,0,0)) <*> pure 0 <*> pure waterarr + <*> pure 0 + <*> pure Oracle + <*> pure 0.033 printErrors :: String -> IO () printErrors ctx = |