Render terrain with lighting

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 =