From d619daf6f6ca589b573b64f827fe7ca38fb7ab7e Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sat, 2 Jan 2021 19:39:51 +0000 Subject: Render terrain with lighting --- src/Vivant.hs | 69 +++++++++++++++++++++++++++++++++++++++------------ src/Vivant/Common.hs | 5 +++- src/Vivant/Noise.hs | 2 +- src/Vivant/Shader.hs | 4 +-- src/Vivant/Terrain.hs | 38 ++++++++++++++++++++-------- 5 files changed, 88 insertions(+), 30 deletions(-) diff --git a/src/Vivant.hs b/src/Vivant.hs index 323602f..a3973a5 100644 --- a/src/Vivant.hs +++ b/src/Vivant.hs @@ -14,7 +14,7 @@ module Main where -import Control.Lens ((.~), (^.)) +import Control.Lens ((.~), (^.), (%~)) import Control.Monad import qualified Data.ByteString as BS import Data.Fixed (mod') @@ -23,12 +23,12 @@ import Data.Int (Int32) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Vector.Storable as V -import Data.Word (Word32) +import Data.Word (Word32, Word8) import Foreign.C.Types import Foreign.Marshal.Alloc (free, malloc) import Foreign.Ptr import Foreign.Storable (poke, sizeOf) -import qualified Graphics.GL.Functions as GL (glUniformMatrix4fv) +import qualified Graphics.GL.Compatibility33 as GL import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL.GL.Shaders.Uniform as GL (UniformLocation (..)) import Linear @@ -44,6 +44,7 @@ import System.IO import Vivant.Shader (createProgram) import Vivant.Renderer import Vivant.Terrain +import Vivant.Noise screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -96,7 +97,8 @@ data MouseInputs = MouseInputs { mousePosition :: Point V2 Int32, mouseRelative :: V2 Int32, mousePositionOld :: Maybe (V2 Int32), - mousePressed :: Bool + mousePressed :: Bool, + mouseWheel :: Int32 } deriving (Show) @@ -106,7 +108,8 @@ initialMouse = { mousePosition = P (V2 400 300), mouseRelative = V2 0 0, mousePositionOld = Nothing, - mousePressed = False + mousePressed = False, + mouseWheel = 0 } main :: IO () @@ -137,6 +140,7 @@ main = do _ <- SDL.glCreateContext window + GL.depthFunc $= Just GL.Less GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight)) game <- initResources @@ -173,14 +177,19 @@ parseEvents :: Set SDL.Keysym -> MouseInputs -> IO (Set SDL.Keysym, MouseInputs) parseEvents keys mouse = do events <- SDL.pollEvents let events' = fmap SDL.eventPayload events - let isMoving = (> 0) . length $ filter mouseMoving events' let (k, m) = foldr handleEvents (keys, mouse) events' - return (if isMoving - then (k, m) - else (k, m {mouseRelative = V2 0 0})) + return + . changeIfIn events' mouseWheel (\(k, m) -> (k, m {mouseWheel = 0})) + $ changeIfIn events' mouseMoving (\(k, m) -> (k, m {mouseRelative = V2 0 0})) (k, m) where mouseMoving (SDL.MouseMotionEvent{}) = True mouseMoving _ = False + mouseWheel (SDL.MouseWheelEvent{}) = True + mouseWheel _ = False + changeIfIn events event modification initial = + if (> 0) . length $ filter event events + then initial + else modification initial handleEvents :: SDL.EventPayload -> @@ -201,7 +210,7 @@ handleEvents event (k, m) = SDL.mouseMotionEventRelMotion = vel } ) -> - (k, MouseInputs pos vel (mousePositionOld m) (mousePressed m)) + (k, MouseInputs pos vel (mousePositionOld m) (mousePressed m) (mouseWheel m)) SDL.MouseButtonEvent (SDL.MouseButtonEventData { SDL.mouseButtonEventMotion = SDL.Pressed @@ -212,6 +221,11 @@ handleEvents event (k, m) = { SDL.mouseButtonEventMotion = SDL.Released }) -> (k, m {mousePressed = False}) + SDL.MouseWheelEvent + (SDL.MouseWheelEventData + { SDL.mouseWheelEventPos = V2 x y + }) -> + (k, m {mouseWheel = y}) SDL.QuitEvent {} -> (Set.insert escapeKey k, m) _ -> (k, m) @@ -222,8 +236,8 @@ updateMouse mouse game = { gameCamera = (gameCamera game) { - cameraPos = newPos, - cameraFront = normalize (V3 0 0 0 ^-^ newPos), + cameraPos = newPos ^+^ (fromIntegral (mouseWheel mouse) *^ newFront), + cameraFront = newFront, cameraUp = newUp } } @@ -235,6 +249,26 @@ updateMouse mouse game = | otherwise = v newPos = rotation . cameraPos $ gameCamera game newUp = rotation . cameraUp $ gameCamera game + newFront = normalize (V3 0 0 0 ^-^ newPos) + +pixelRenderer :: Double -> Int -> Int -> Word8 +pixelRenderer n x y = + doubleToByte $ + ( ( perlin3 + permutation + ( (fromIntegral x - 32) / 4, + (fromIntegral y - 32) / 4, + n + ) + ) + + 1 + ) + / 2 + * 128 + +createTerrain :: [[Float]] +createTerrain = + fmap (\y -> fmap (\x -> fromIntegral (pixelRenderer 0 x y) / 15) [0..63]) [0..63] initResources :: IO Game initResources = do @@ -254,7 +288,7 @@ initResources = do viewP <- malloc projectionP <- malloc - terrain <- initTerrain [[1, 2, 3, 4], [3, 2, 1, 4], [2, 5, 2, 3], [3, 1, 2, 4]] prog + terrain <- initTerrain createTerrain prog return $ initialGameState @@ -273,6 +307,9 @@ toRadians = (*) (pi / 180) scaledMat :: V4 (V4 Float) -> V4 (V4 Float) scaledMat n = ((n * identity) & _w . _w .~ 1) +castV3 :: V3 a -> GL.Vector3 a +castV3 (V3 a b c) = GL.Vector3 a b c + draw :: Game -> IO () draw game@(Game {gameProgram = Just p, gameVao = Just v, gameTerrain = Just t}) = do tick <- ticks @@ -290,7 +327,7 @@ draw game@(Game {gameProgram = Just p, gameVao = Just v, gameTerrain = Just t}) cameraPosition = cameraPos camera targetPosition = cameraPosition ^+^ cameraFront camera viewMatrix = lookAt cameraPosition targetPosition (cameraUp camera) - projectionMatrix = perspective (toRadians 45) (640 / 480) 0.1 100 + projectionMatrix = perspective (toRadians 45) (640 / 480) 0.1 1000 poke (gameViewP game) viewMatrix poke (gameProjectionP game) projectionMatrix @@ -298,8 +335,8 @@ draw game@(Game {gameProgram = Just p, gameVao = Just v, gameTerrain = Just t}) GL.glUniformMatrix4fv view 1 1 (castPtr (gameViewP game)) GL.glUniformMatrix4fv projection 1 1 (castPtr (gameProjectionP game)) - ourColorLoc <- GL.uniformLocation p "ourColour" - GL.uniform ourColorLoc $= (GL.Vector4 (1 :: Float) 0.5 1 1) + ourColorLoc <- GL.uniformLocation p "light_pos" + GL.uniform ourColorLoc $= castV3 (cameraPos (gameCamera game)) render $ terrainRenderer t diff --git a/src/Vivant/Common.hs b/src/Vivant/Common.hs index fd90233..cf017ca 100644 --- a/src/Vivant/Common.hs +++ b/src/Vivant/Common.hs @@ -1,5 +1,5 @@ module Vivant.Common - (vectorSize) + (vectorSize, uncurry3) where import qualified Data.Vector.Storable as V @@ -7,3 +7,6 @@ import Foreign.Storable (sizeOf) vectorSize :: (Num b, V.Storable a) => V.Vector a -> b vectorSize array = fromIntegral $ V.length array * sizeOf (1.0 :: Float) + +uncurry3 :: (t1 -> t2 -> t3 -> t4) -> (t1, t2, t3) -> t4 +uncurry3 f (a, b, c) = f a b c diff --git a/src/Vivant/Noise.hs b/src/Vivant/Noise.hs index 32cd08e..bf2b197 100644 --- a/src/Vivant/Noise.hs +++ b/src/Vivant/Noise.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -module Vivant.Noise (Permutation (..), perlin3, permutation, mkPermutation) where +module Vivant.Noise (Permutation (..), perlin3, permutation, mkPermutation, doubleToByte) where import qualified Codec.Picture as P import Control.Arrow diff --git a/src/Vivant/Shader.hs b/src/Vivant/Shader.hs index aa884c6..4ba5c09 100644 --- a/src/Vivant/Shader.hs +++ b/src/Vivant/Shader.hs @@ -13,7 +13,7 @@ createProgram = do datadir <- getDataDir -- compile vertex shader vs <- GL.createShader GL.VertexShader - vsSource <- BS.readFile $ datadir <> "/shaders/triangle.vert" + vsSource <- BS.readFile $ datadir <> "/shaders/phong.vert.glsl" GL.shaderSourceBS vs $= vsSource GL.compileShader vs vsOK <- GL.get $ GL.compileStatus vs @@ -24,7 +24,7 @@ createProgram = do -- Do it again for the fragment shader fs <- GL.createShader GL.FragmentShader - fsSource <- BS.readFile $ datadir <> "/shaders/triangle.frag" + fsSource <- BS.readFile $ datadir <> "/shaders/phong.frag.glsl" GL.shaderSourceBS fs $= fsSource GL.compileShader fs fsOK <- GL.get $ GL.compileStatus fs diff --git a/src/Vivant/Terrain.hs b/src/Vivant/Terrain.hs index 3099177..befee88 100644 --- a/src/Vivant/Terrain.hs +++ b/src/Vivant/Terrain.hs @@ -8,7 +8,7 @@ import qualified Graphics.Rendering.OpenGL as GL import SDL (($=)) import Foreign.Marshal.Alloc (free, malloc) import Foreign.Ptr -import Vivant.Common (vectorSize) +import Vivant.Common (vectorSize, uncurry3) import Foreign.Storable (poke) import Linear @@ -16,27 +16,42 @@ data Terrain = Terrain { terrainWidth :: Int, terrainHeight :: Int, - terrainGeometry :: [[Int]], + terrainGeometry :: [[Float]], terrainRenderer :: Renderer } deriving (Show) +normal :: Num c => (c, c, c) -> (c, c, c) -> (c, c, c) -> (c, c, c) +normal a b c = + transform $ cross (uncurry3 V3 b ^-^ uncurry3 V3 a) (uncurry3 V3 c ^-^ uncurry3 V3 a) + where + transform (V3 a b c) = (a, b, c) + partition - :: (V.Storable a1, Integral a2, Num a1) => [[a2]] -> V.Vector a1 + :: (V.Storable a1, Enum a1, Num a1) => [[a1]] -> V.Vector a1 partition r = - V.fromList . fmap fromIntegral . concat . concat . + V.fromList . concat . concat . fmap (\(e, y) -> fmap (generateP y) $ zip (zip (uncurry zip e) $ tail (uncurry zip e)) [0..]) $ zip (zip r $ tail r) [0..] where generateP y (((z1, z2), (z3, z4)), x) = + let (n1x, n1y, n1z) = normal (x, y, z1) (x, y+1, z2) (x+1, y, z3) + (n2x, n2y, n2z) = normal (x+1, y+1, z4) (x, y+1, z2) (x+1, y, z3) + in [ x, y, z1 + , -n1x, -n1y, -n1z , x, y+1, z2 + , -n1x, -n1y, -n1z , x+1, y, z3 + , -n1x, -n1y, -n1z , x, y+1, z2 + , n2x, n2y, n2z , x+1, y, z3 + , n2x, n2y, n2z , x+1, y+1, z4 + , n2x, n2y, n2z ] -initTerrain :: [[Int]] -> GL.Program -> IO Terrain +initTerrain :: [[Float]] -> GL.Program -> IO Terrain initTerrain g p = do vao <- GL.genObjectName GL.bindVertexArrayObject $= Just vao @@ -48,17 +63,20 @@ initTerrain g p = do V.unsafeWith g' $ \ptr -> GL.bufferData GL.ArrayBuffer $= (vectorSize g', castPtr ptr, GL.StaticDraw) - setVertexAttribute p "position" 3 0 0 + setVertexAttribute p "position" 3 6 0 + setVertexAttribute p "normal" 3 6 3 GL.bindVertexArrayObject $= Nothing + let h = length g + w = length (head g) + modelMatrix = mkTransformation (axisAngle (V3 0 0 0) 0) + (V3 (- fromIntegral w / 2) (- fromIntegral h / 2) 0) + modelP <- malloc - let modelMatrix = mkTransformation (axisAngle (V3 0 0 0) 0) (V3 (-2.5) (-2.5) 0) poke modelP modelMatrix - let h = length g - w = length (head g) - return $ Terrain w h g (Renderer (Just p) (Just vao) modelP 72) + return $ Terrain w h g (Renderer (Just p) (Just vao) modelP ((w + 2) * (h + 2) * 8)) destroyTerrain :: Terrain -> IO () destroyTerrain t = -- cgit