better projection, transparency; 4d camera, controls r/f for +/-w

flake.nix

@@ -11,7 +11,9 @@
     pkgs = nixpkgs.legacyPackages.${system};
   in {
     packages.${system} = {
-      default = pkgs.haskellPackages.callCabal2nix "hs-game" ./. {};
+      default =
+        pkgs.haskell.packages.ghc912.callCabal2nix "hs-game" ./. {
+        };
     };
     devShells.${system} = {
       default = pkgs.mkShell {

src/Game/Internal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE MultilineStrings #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 
@@ -42,19 +43,24 @@ import Linear (V3 (..), V4 (..))
 -- Shader creation and object initialisation
 --------------------------------------------------------------------------------
 
-initResources :: [[V4 GL.GLfloat]] -> IO ([Object], GL.Program)
+initResources :: [V4 GL.GLfloat] -> IO (Object, GL.Program)
-initResources arrays = do
+initResources arr = do
-  objects <-
+  object <-
-    listIOsToIOlist
+    createObject arr 4 GL.Triangles (GL.AttribLocation 0)
-      [createObject arr 4 GL.Triangles (GL.AttribLocation 0) | arr <- arrays]
+
-      []
+  -- compile shader program
   program <-
     loadShaders
       [ ShaderInfo GL.VertexShader (StringSource vertShader),
         ShaderInfo GL.FragmentShader (StringSource fragShader)
       ]
   GL.currentProgram $= Just program
-  return (objects, program)
+
+  -- alpha
+  GL.blend $= GL.Enabled
+  GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+
+  return (object, program)
 
 listIOsToIOlist :: [IO a] -> [a] -> IO [a]
 listIOsToIOlist [] out = return out
@@ -69,44 +75,81 @@ listIOsToIOlist (io : ios) out = do
 
 vertShader :: String
 vertShader =
-  unlines
+  """
-    [ "#version 330 core",
+  #version 330 core
-      "layout (location = 0) in vec4 a_vPos;",
+
-      "uniform mat4 u_view;",
+  layout (location = 0) in vec4 a_vPos;
-      "uniform mat4 u_projection;",
+
-      "out vec3 v_pos;",
+  uniform mat4 u_view;
-      glslProjectTo3d,
+  uniform mat4 u_projection;
-      "void main()",
+  uniform vec4 u_cam;
-      "{",
+
-      "  vec3 vPos = projectTo3d(a_vPos);",
+  out vec3 v_pos;
-      "  gl_Position = u_projection * u_view * vec4(vPos, 1.0);",
+  out float v_w;
-      "  v_pos = vPos;",
+  out float v_alpha;
-      "}"
+
-    ]
+  vec3 orthoFrom4d(vec4 point)
+  {
+    return point.xyz;
+  }
+
+  // creates a simple 3d coordinate from a 4d
+  vec3 projectFrom4d(vec4 point)
+  {
+    // TODO don't do camera ops in shader, prefer linear algebra
+    // also use a reasonable projection for god's sake
+    vec4 view = abs(u_cam - point);
+    float perspective = 1.0 / abs(u_cam.w - view.w);
+
+    return perspective * (point.xyz);
+  }
+
+  void main()
+  {
+    vec3 vPos = orthoFrom4d(a_vPos);
+
+    // TODO don't set constant inside of shader :/
+    float wHorizon = 3;
+    float alpha = (wHorizon - abs(u_cam.w - a_vPos.w)) / wHorizon;
+
+    // cull invisible things
+    if (alpha < -1) {
+      gl_Position = vec4(0.0);
+      alpha = 0.0;
+    } else {
+      alpha = max(alpha, 0.0);
+      gl_Position = u_projection * u_view * vec4(vPos, 1.0);
+    }
+
+    v_pos = vPos;
+    v_w = a_vPos.w;
+    v_alpha = alpha;
+  }
+  """
 
 fragShader :: String
 fragShader =
-  unlines
+  """
-    [ "#version 330 core",
+  #version 330 core
-      "out vec4 o_vColor;",
-      "in vec3 v_pos;",
-      "void main()",
-      "{",
-      "  // yoinked from https://stackoverflow.com/questions/14980712/how-to-get-flat-normals-on-a-cube/14981446#14981446",
-      "  vec3 norm = normalize(cross(dFdx(v_pos), dFdy(v_pos)));",
-      "  o_vColor = vec4((0.5 + 0.5 * norm) / 2, 1.0);",
-      "}"
-    ]
 
-glslProjectTo3d :: String
+  uniform vec4 u_cam;
-glslProjectTo3d =
+
-  unlines
+  out vec4 o_vColor;
-    [ "vec3 projectTo3d(vec4 point)",
+
-      "{",
+  in vec3 v_pos;
-      "  float perspective = 1.0 / (1.0 + point.w);",
+  in float v_w;
-      "  return perspective * point.xyz;",
+  in float v_alpha;
-      "}"
+
-    ]
+  void main()
+  {
+    // the normal vector of the face
+    // yoinked from https://stackoverflow.com/questions/14980712/how-to-get-flat-normals-on-a-cube/14981446#14981446
+    vec3 norm = normalize(cross(dFdx(v_pos), dFdy(v_pos)));
+
+    // creates a color based on the normal direction
+    o_vColor = vec4((0.5 + 0.5 * norm) / 2, v_alpha);
+  }
+  """
 
 --------------------------------------------------------------------------------
 -- Objects

src/Game/Internal/Types.hs

@@ -83,7 +83,7 @@ mkModel camera objects program wprop =
 -- | camera
 data Camera = Camera
   { -- | position in world space
-    camPos :: V3 Float,
+    camPos :: V4 Float,
     -- | pitch in radians, up positive
     camPitch :: Float,
     -- | yaw in radians, right positive
@@ -107,7 +107,7 @@ data Camera = Camera
 
 -- | smart constructor for Camera
 mkCamera ::
-  V3 Float ->
+  V4 Float ->
   Float ->
   Float ->
   V3 Float ->

src/Main.hs

@@ -22,7 +22,7 @@ import Game.Internal.Types
 import Graphics.Rendering.OpenGL (($=))
 import qualified Graphics.Rendering.OpenGL as GL
 import qualified Graphics.UI.GLFW as GLFW
-import Linear (V3 (..), V4 (..), (*^), _y)
+import Linear (V3 (..), V4 (..), (*^), _w, _xyz, _y)
 import qualified Linear as L
 
 -- | Main function runs game
@@ -36,6 +36,7 @@ main = do
   GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
   -- MSAA
   GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8
+  -- alpha
   -- create window
   monitor <- GLFW.getPrimaryMonitor
   Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing
@@ -46,15 +47,22 @@ main = do
   GLFW.setKeyCallback window $ Just (keyPressed Nothing)
   GLFW.setCursorInputMode window GLFW.CursorInputMode'Hidden
   GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)
-  (objects, program) <-
+  (object, program) <-
     initResources $
-      [map (\v -> (V4 a 0 a 0) + (rotate4 0 3 (a * g90 / 6) v)) hCube | a <- take 100 [0, 2 ..]]
+      concat
-        ++ [map (+ V4 a 0 0 0) hCube | a <- take 100 [0, (-2) ..]]
+        ( [hCube]
+            ++ [map (\v -> (V4 a 0 0 a) + (rotate4 0 1 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
+            ++ [map (\v -> (V4 a 2 0 a) + (rotate4 0 2 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
+            ++ [map (\v -> (V4 a 4 0 a) + (rotate4 0 3 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
+            ++ [map (\v -> (V4 a (-2) 0 a) + (rotate4 1 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
+            ++ [map (\v -> (V4 a (-4) 0 a) + (rotate4 2 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
+            ++ [map (\v -> (V4 a (-6) 0 a) + (rotate4 3 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
+        )
 
   let model =
         mkModel
           ( mkCamera
-              (V3 0 0 3) -- camPos
+              (V4 0 0 3 0) -- camPos
               0 -- pitch
               0 -- yaw
               (V3 0 0 (-1)) -- reference vector
@@ -63,7 +71,7 @@ main = do
               16 -- strafe strength
               12 -- jump strength
           )
-          objects
+          [object]
           program
           (mkWorldProperties 2 0.16 (V3 0 1 0))
   modelRef <- newIORef model
@@ -173,11 +181,33 @@ hCube =
 -- | update function
 update :: Float -> Model -> Model
 update dt model =
+  updateW dt $
     updateVelocity dt $
       updateAcceleration dt $
         updateSpeed dt $
           updateCameraAngle dt model
 
+updateW :: Float -> Model -> Model
+updateW dt model =
+  if elem GLFW.Key'R model.keys
+    then
+      model
+        { camera =
+            model.camera
+              { camPos = model.camera.camPos + (V4 0 0 0 (dt * dt * model.camera.strafeStrength))
+              }
+        }
+    else
+      if elem GLFW.Key'F model.keys
+        then
+          model
+            { camera =
+                model.camera
+                  { camPos = model.camera.camPos - (V4 0 0 0 (dt * dt * model.camera.strafeStrength))
+                  }
+            }
+        else model
+
 updateSpeed :: Float -> Model -> Model
 updateSpeed dt model =
   if elem GLFW.Key'T model.keys
@@ -230,7 +260,7 @@ updateAcceleration dt model =
           then V3 0 (0 - model.wprop.g * model.camera.airTime) 0
           else V3 0 0 0
       camVel' = friction * (model.camera.camVel + movement' + jump)
-      aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0
+      aboveGround = ((model.camera.camPos ^. _xyz) + dt L.*^ camVel') ^. _y > 0
    in if (elem GLFW.Key'Space model.keys) && (model.camera.hasJumped == False)
         then
           updateAcceleration dt $
@@ -261,7 +291,7 @@ updateAcceleration dt model =
                     model.camera
                       { airTime = 0,
                         camVel = camVel' * (V3 1 0 1),
-                        camPos = model.camera.camPos * (V3 1 0 1),
+                        camPos = model.camera.camPos * (V4 1 0 1 1),
                         hasJumped = aboveGround
                       }
                 }
@@ -271,7 +301,7 @@ updateVelocity dt model =
   model
     { camera =
         model.camera
-          { camPos = model.camera.camPos + dt L.*^ model.camera.camVel
+          { camPos = V4 1 1 1 (model.camera.camPos ^. _w) * (L.point $ (model.camera.camPos ^. _xyz) + dt L.*^ model.camera.camVel)
           }
     }
 
@@ -314,23 +344,37 @@ view window model = do
       forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw)
       viewMatrix =
         L.lookAt
-          model.camera.camPos
+          (model.camera.camPos ^. _xyz)
-          (model.camera.camPos - forward)
+          ((model.camera.camPos ^. _xyz) - forward)
           model.wprop.up
       projectionMatrix =
         L.perspective 1.2 (fromIntegral w / fromIntegral h) 0.01 1000
+
   viewGLMatrix <-
     GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix ::
       IO
         (GL.GLmatrix GL.GLfloat)
+
+  -- load 3d view matrix
   viewLocation <- GL.get $ GL.uniformLocation model.program "u_view"
   GL.uniform viewLocation $= viewGLMatrix
+
   projectionGLMatrix <-
     GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix ::
       IO
         (GL.GLmatrix GL.GLfloat)
+
+  -- load 3d projection matrix
   projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection"
   GL.uniform projectionLocation $= projectionGLMatrix
+
+  let camx = (\(V4 x _ _ _) -> x) model.camera.camPos
+      camy = (\(V4 _ y _ _) -> y) model.camera.camPos
+      camz = (\(V4 _ _ z _) -> z) model.camera.camPos
+      camw = (\(V4 _ _ _ w) -> w) model.camera.camPos
+  camWLocation <- GL.get $ GL.uniformLocation model.program "u_cam"
+  GL.uniform camWLocation $= GL.Vector4 camx camy camz camw
+
   -- draw objects; returns IO []
   _ <- drawObjects model.objects
   -- swap to current buffer