diff options
| -rw-r--r-- | Final.hs | 30 | ||||
| -rw-r--r-- | Graphics/Glyph/Util.hs | 3 | ||||
| -rw-r--r-- | Resources.hs | 140 | ||||
| -rw-r--r-- | shaders/basic.frag | 4 | ||||
| -rw-r--r-- | shaders/sky.frag | 4 | ||||
| -rw-r--r-- | shaders/water.frag | 3 |
6 files changed, 148 insertions, 36 deletions
@@ -27,7 +27,6 @@ import Prelude as P import Debug.Trace import Data.Bits -import TileShow import Resources import System.Random import Debug.Trace @@ -35,15 +34,6 @@ import Debug.Trace import System.Environment import System.Exit -data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | - Tundra | Unknown deriving (Enum,Eq) -$(makeShow ''TileType) - - -data Tile = Tile { - tileType :: TileType, - elevation :: Int -} deriving Show buildArray :: SDL.Surface -> SDL.Surface -> IO (Array (Int,Int) Tile) buildArray terrain height = @@ -56,7 +46,7 @@ buildArray terrain height = ((word `shiftR`16) .&. 0xFF) + ((word `shiftR`24) .&. 0xFF) heightVal = (fromIntegral.sumit) (getPixelUnsafe x y height) - terrainVal' = Map.findWithDefault Main.Unknown terrainVal tileMap in + terrainVal' = Map.findWithDefault Resources.Unknown terrainVal tileMap in Tile terrainVal' heightVal list = map conv [(x,y) | x <- [0..w-1], y <- [0..h-1]] @@ -100,7 +90,7 @@ colorArray marr = do return ret -- elevation quad is corner verticices -getWaterQuads :: Array (Int,Int) Tile -> IOArray (Int,Int) Int -> IO ( BuilderM GLfloat () ) +getWaterQuads :: Array (Int,Int) Tile -> IOArray (Int,Int) Int -> IO ( Map.Map Int GLfloat, BuilderM GLfloat () ) getWaterQuads marr arr = do let (_,(w,h)) = bounds marr let elevationCacheIO :: IO (Map.Map Int (Int,Int,Int,Int,Int)) @@ -124,8 +114,12 @@ getWaterQuads marr arr = do return newmap ) (Map.empty::Map.Map Int (Int,Int,Int,Int,Int)) [(x,y) | x <- [0..w], y <- [0..h]] - dat <- (liftM Map.toList elevationCacheIO) - return . sequence_ $ for dat $ \(_, (elev,maxx,maxy,minx,miny)) -> do + elevMap <- elevationCacheIO + let elevMap2 = Map.map (\(elev,_,_,_,_) -> do + fromIntegral elev / 10) elevMap + + let dat = Map.toList elevMap + return (elevMap2,sequence_ $ for dat $ \(_, (elev,maxx,maxy,minx,miny)) -> do let mxx = fromIntegral maxx + 1 mnx = fromIntegral minx - 1 mxy = fromIntegral maxy + 1 @@ -135,7 +129,7 @@ getWaterQuads marr arr = do [(mxx,relev,mxy), (mxx,relev,mny), (mnx,relev,mny), - (mnx,relev,mxy)] + (mnx,relev,mxy)]) printArray :: Array (Int,Int) Tile -> IO () @@ -289,7 +283,9 @@ main = do let !jungleLocations = runMonadPlusBuilder $ createLocations arr stgen2 2 Jungle putStrLn $ "Jungle locations: " ++! jungleLocations - water <- getWaterQuads arr coloredArr + (mapping,water) <- getWaterQuads arr coloredArr + coloredArr2 <- mapArray (\idx -> if idx == 0 then -1 else Map.findWithDefault (-1) idx mapping) coloredArr + printShowArray coloredArr2 -- putStrLn $ "ForestLocations :" ++! forestLocations - makeResources surface (createBuilder arr) forestLocations jungleLocations water + makeResources surface (createBuilder arr) forestLocations jungleLocations water arr coloredArr2 >>= startPipeline reshape eventHandle displayHandle updateHandle; diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs index 78fd053..790b9f6 100644 --- a/Graphics/Glyph/Util.hs +++ b/Graphics/Glyph/Util.hs @@ -310,3 +310,6 @@ for = flip map distribMaybe :: Maybe (a,b) -> (Maybe a, Maybe b) distribMaybe Nothing = (Nothing,Nothing) distribMaybe (Just (a,b)) = (Just a, Just b) + +whenM :: IO Bool -> IO () -> IO () +whenM b = (>>=) b . flip when diff --git a/Resources.hs b/Resources.hs index d952a98..d7fcaac 100644 --- a/Resources.hs +++ b/Resources.hs @@ -42,12 +42,24 @@ import Foreign.Marshal.Alloc import System.Exit import System.FilePath import System.Random +import qualified Data.Array.IO as ArrIO import Models import Debug.Trace +import TileShow +import Data.Array import qualified Data.StateVar as SV +data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | + Tundra | Unknown deriving (Enum,Eq) +$(makeShow ''TileType) + +data Tile = Tile { + tileType :: TileType, + elevation :: Int +} deriving Show + data CameraPosition = CameraPosition { pEye :: Vec3 GLfloat, pTh :: GLfloat, @@ -71,9 +83,15 @@ data Resources = Resources { -- jungle :: GlyphObject (), -- waterObj :: GlyphObject (), - speed :: Int, + speed :: GLfloat, timeSpeed :: Int, - time :: Int + time :: Int, + + heightMap :: Array (Int,Int) Tile, + positionUpdate :: (Resources -> IO Resources), + speedFactor :: GLfloat, + dDown :: GLfloat, + waterArray :: ArrIO.IOArray (Int,Int) GLfloat } data ResourcesClosure = ResourcesClosure { @@ -85,10 +103,45 @@ data ResourcesClosure = ResourcesClosure { , rcGlobalAmbient :: Vec4 GLfloat , rcCameraPos :: CameraPosition , rcCameraLocation :: Vec3 GLfloat + , rcResources :: Resources } $(declareSetters ''Resources) +firstPerson :: Resources -> IO Resources +firstPerson res = + let (CameraPosition (Vec3 (x,curh,y)) th ph) = rPosition res + mix a b c = a * c + b * (1 - c) + (_,(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 + 0.2 + droph = curh - dDown res + in do + -- putStrLn $ "---------------" + -- putStrLn $ "(x,y)=" ++! (x,y) + -- putStrLn $ "(h1,h2,h3,h4)=" ++! (h1,h2,h3,h4) + -- putStrLn $ "(u,v)=" ++! (u,v) + -- putStrLn $ "mixu1=" ++! mixu1 + -- putStrLn $ "mixu2=" ++! mixu2 + -- putStrLn $ "Newheight=" ++! newh + if newh+0.2 > droph then + return $ setRPosition (CameraPosition (Vec3 (x,newh,y)) th ph) $ + setDDown 0 $ + if speed res > speedFactor res then + (setSpeed <..> speedFactor) res + else res + else + return $ setRPosition (CameraPosition (Vec3 (x, droph, y)) th ph) $ + setDDown (dDown res + 0.05) res + getUniformsSafe :: Program -> [String] -> IO [UniformLocation] getUniformsSafe prog uniforms = forM uniforms $ \uniform -> do @@ -140,13 +193,25 @@ eventHandle event res = do return $ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res KeyDown (Keysym SDLK_w _ _) -> - return $ setSpeed (speed res + 1) res + return $ setSpeed (speed res + speedFactor res) res KeyDown (Keysym SDLK_s _ _) -> - return $ setSpeed (speed res - 1) res + return $ setSpeed (speed res - speedFactor res) res KeyUp (Keysym SDLK_w _ _) -> - return $ setSpeed (speed res - 1) res + return $ setSpeed 0 res KeyUp (Keysym SDLK_s _ _) -> - return $ setSpeed (speed res + 1) res + 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 @@ -158,6 +223,15 @@ eventHandle event res = 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 displayHandle :: Resources -> IO Resources @@ -189,20 +263,35 @@ displayHandle resources = do (Vec4 globalAmbient) cameraPos (Vec3 $ toEuclidian (r,th,ph)) + resources + in mapM_ (Prelude.$rc) $ routines resources SDL.glSwapBuffers return 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) + +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) + updateHandle :: Resources -> IO Resources updateHandle res = do - return $ setRPosition (rPosition res `cAdd` rDPosition res) $ + (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 fri = fromIntegral - x' = (fri $ speed res) `vScale` (V.normalize $ Vec3 $ toEuclidian (1,y, z)) in - (CameraPosition (x <+> x') (y + y') (z + z')) + let x' = speed res `vScale` (V.normalize $ Vec3 $ toEuclidian (1,y, z)) in + (CameraPosition (x <+> x') (y + y') (z + z')) reshape :: Int -> Int -> Resources -> IO Resources reshape w h res = @@ -253,8 +342,8 @@ buildTerrainObject builder = do uniform dYlocation $= Index1 (dy::GLfloat) printErrors "terrainObjectClosure" - [lightposU, globalAmbientU, pjMatrixU, mvMatrixU, normalMatrixU] - <- getUniformsSafe terrainProg ["lightPos","globalAmbient","pjMatrix","mvMatrix","normalMatrix"] + [lightposU, globalAmbientU, pjMatrixU, mvMatrixU, normalMatrixU, fogU] + <- getUniformsSafe terrainProg ["lightPos","globalAmbient","pjMatrix","mvMatrix","normalMatrix","fog"] return $ \rc -> do draw $ prepare obj $ \_ -> do cullFace $= Just Front @@ -263,6 +352,10 @@ buildTerrainObject builder = do uniform lightposU $= rcLightPos rc uniform normalMatrixU $= rcNormalMatrix rc uniform globalAmbientU $= rcGlobalAmbient rc + bool <- (resourcesUnderWater $ rcResources rc) + if bool then + uniform fogU $= Index1 (0.9::GLfloat) else + uniform fogU $= Index1 (0.0::GLfloat) cloudProgram :: IO (ResourcesClosure -> IO ()) cloudProgram = do @@ -371,6 +464,7 @@ buildWaterObject builder = do setupTexturing skyTexture skyLocation 1 setupTexturing skyNightTexture skyNightLocation 2 ) + [fogU] <- getUniformsSafe waterProg ["fog"] return $ \rc -> do draw $ prepare obj $ \_ -> do cullFace $= Nothing @@ -381,12 +475,17 @@ buildWaterObject builder = do uniform (UniformLocation 8) $= rcLightPos rc uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0) uniform (UniformLocation 10) $= rcGlobalAmbient rc + bool <- (resourcesUnderWater $ rcResources rc) + if bool then + uniform fogU $= Index1 (0.9::GLfloat) else + uniform fogU $= Index1 (0.0::GLfloat) makeResources :: SDL.Surface -> BuilderM GLfloat b -> Seq.Seq GLfloat -> Seq.Seq GLfloat -> - BuilderM GLfloat a -> IO Resources -makeResources surf builder forestB jungleB water = do + BuilderM GLfloat a -> Array (Int,Int) Tile -> + ArrIO.IOArray (Int,Int) GLfloat -> IO Resources +makeResources surf builder forestB jungleB water arr waterarr = do let pMatrix' = perspectiveMatrix 50 1.8 0.1 100 let l_routines = sequence [ @@ -420,6 +519,11 @@ makeResources surf builder forestB jungleB water = do <*> pure 0 <*> pure 1 <*> pure 0 + <*> pure arr + <*> pure return + <*> pure 1 + <*> pure 0 + <*> pure waterarr printErrors :: String -> IO () printErrors ctx = @@ -484,8 +588,8 @@ skyboxObject = do glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE textureTopNight <- load "textures/skybox_top_night.png" >>= textureFromSurface - [lightposU] <- mapM (get . uniformLocation prog) - ["lightpos"] + [lightposU,multU] <- mapM (get . uniformLocation prog) + ["lightpos","mult"] topObj <- newDefaultGlyphObjectWithClosure (skyboxTop 1) () $ \_ -> do setupTexturing textureTop texLoc 2 setupTexturing textureTopNight texLocNight 3 @@ -508,6 +612,10 @@ skyboxObject = do uniform pmatLoc $= rcPMatrix rc uniform matLoc $= buildMVMatrix (CameraPosition (Vec3 (0,0,0)) th ph) uniform (UniformLocation 1) $= rcGlobalAmbient rc + bool <- (resourcesUnderWater $ rcResources rc) + if bool then + uniform multU $= Index1 (0.0::GLfloat) else + uniform multU $= Index1 (1.0::GLfloat) diff --git a/shaders/basic.frag b/shaders/basic.frag index a97caf8..61e57bf 100644 --- a/shaders/basic.frag +++ b/shaders/basic.frag @@ -12,6 +12,8 @@ uniform float dY ; uniform mat4 mvMatrix ; uniform mat4 pjMatrix ; +uniform float fog ; + in vec3 normal ; uniform sampler2D textures[8] ; @@ -81,5 +83,5 @@ void main() { float prod = dot( normalize(-newNorm), normalize(vec3(lightPos - position))); vec3 intensity = vec3(prod,prod,max(prod,0.4)) ; - frag_color = vec4(color * intensity,1) * vec4(normalize(globalAmbient.xyz),1.0); + frag_color = vec4(color * intensity / (-position.z*fog+1),1) * vec4(normalize(globalAmbient.xyz),1.0); } diff --git a/shaders/sky.frag b/shaders/sky.frag index 6d47adb..43b4265 100644 --- a/shaders/sky.frag +++ b/shaders/sky.frag @@ -13,6 +13,8 @@ uniform sampler2D night_tex ; in vec2 texcoord; in vec4 position ; +uniform float mult ; + float exp1( float x ) { return 2 / (1+exp(-x))-1; } @@ -28,6 +30,6 @@ void main() { mix(texture2D(night_tex,texcoord) * (1-globalAmbient.a), texture2D(texture,texcoord) * vec4(normalize(globalAmbient.xyz),1), (globalAmbient.a + 1) / 2) * 1.8 ; - frag_color = frag_color + mul ; + frag_color = (frag_color + mul)*mult ; } diff --git a/shaders/water.frag b/shaders/water.frag index 6c2aa2b..6e32796 100644 --- a/shaders/water.frag +++ b/shaders/water.frag @@ -12,6 +12,7 @@ uniform sampler2D texture ; uniform sampler2D skytex ; uniform sampler2D skynight ; uniform vec4 lightpos ; +uniform float fog ; in vec3 normal ; in vec4 position ; @@ -79,6 +80,6 @@ void main() { // frag_color = vec4( 0,0,1, 1.0 ); // frag_color = vec4(tex_x,tex_y,0,1.0) ; // vec4 color = sample(0,0); - frag_color = vec4(vec3(refcolor) * vec3(0.6,0.8,1.0),0.95) * vec4(normalize(globalAmbient.xyz),1.0); + frag_color = vec4(vec3(refcolor) * vec3(0.6,0.8,1.0) / (-position.z*fog+1),0.95) * vec4(normalize(globalAmbient.xyz),1.0); // frag_color = vec4(0,0,1,0.8) ; } |