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 arrays = do
-  objects <-
-    listIOsToIOlist
-      [createObject arr 4 GL.TriangleStrip (GL.AttribLocation 0) | arr <- arrays]
-      []
+initResources :: [V4 GL.GLfloat] -> IO (Object, GL.Program)
+initResources arr = do
+  object <-
+    createObject arr 4 GL.Triangles (GL.AttribLocation 0)
+
+  -- 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
@@ -67,39 +73,83 @@ listIOsToIOlist (io : ios) out = do
 -- u_ uniform
 -- o_ fragment shader output
 
--- | vertex shader
 vertShader :: String
 vertShader =
-  "#version 330 core\n"
-    ++ "layout (location = 0) in vec4 a_vPos;\n"
-    ++ "uniform mat4 u_view;\n"
-    ++ "uniform mat4 u_projection;\n"
-    ++ "out vec3 v_pos;\n"
-    ++ glslProjectTo3d
-    ++ "void main()\n"
-    ++ "{\n"
-    ++ "  gl_Position = u_projection * u_view * vec4(projectTo3d(a_vPos), 1.0);\n"
-    ++ "  v_pos = a_vPos.xyz;\n"
-    ++ "}\n"
+  """
+  #version 330 core
+
+  layout (location = 0) in vec4 a_vPos;
+
+  uniform mat4 u_view;
+  uniform mat4 u_projection;
+  uniform vec4 u_cam;
+
+  out vec3 v_pos;
+  out float v_w;
+  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;
+  }
+  """
 
--- | fragment shader
 fragShader :: String
 fragShader =
-  "#version 330 core\n"
-    ++ "out vec4 o_vColor;\n"
-    ++ "in vec3 v_pos;\n"
-    ++ "void main()\n"
-    ++ "{\n"
-    ++ "  o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
-    ++ "}\n"
+  """
+  #version 330 core
 
-glslProjectTo3d :: String
-glslProjectTo3d =
-  "vec3 projectTo3d(vec4 point)\n"
-    ++ "{\n"
-    ++ "  float perspective = 1.0 / (1.0 + point.w);\n"
-    ++ "  return perspective * point.xyz;\n"
-    ++ "}\n"
+  uniform vec4 u_cam;
+
+  out vec4 o_vColor;
+
+  in vec3 v_pos;
+  in float v_w;
+  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

@@ -11,7 +11,7 @@
 module Game.Internal.Types
   ( Object (..),
     toGLMatrix,
-    Model (camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop),
+    Model (camera, objects, cursorDeltaPos, cursorPos, keys, program, wprop),
     mkModel,
     Camera (camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime),
     mkCamera,
@@ -70,7 +70,6 @@ data Model = Model
     keys :: [GLFW.Key],
     -- | draw calls
     objects :: [Object],
-    -- | shader program
     program :: GL.Program,
     wprop :: WorldProperties
   }
@@ -84,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
@@ -108,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 (v3tov4 0) $ map (+ V3 a 0 0) cube | a <- take 100 [0, 2 ..]]
-      [hCube]
+      concat
+        ( [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
@@ -75,34 +83,13 @@ main = do
 --------------------------------------------------------------------------------
 -- Arrays
 --------------------------------------------------------------------------------
-top :: [V3 GL.GLfloat]
-top =
-  [ V3 p 0 p,
-    V3 p 0 m,
-    V3 m 0 p,
-    V3 m 0 m
-  ]
-
-side :: [V3 GL.GLfloat]
-side =
-  [ V3 0 p p,
-    V3 0 p m,
-    V3 0 m p,
-    V3 0 m m
-  ]
-
-front :: [V3 GL.GLfloat]
-front =
-  [ V3 p p 0,
-    V3 p m 0,
-    V3 m p 0,
-    V3 m m 0
-  ]
 
 m = (0 - p)
 
 p = 0.5
 
+g90 = pi / 2
+
 v3tov4 :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
 v3tov4 w (V3 x y z) = V4 x y z w
 
@@ -115,41 +102,77 @@ v3tov4'' w (V3 x y z) = V4 x w y z
 v3tov4''' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
 v3tov4''' w (V3 x y z) = V4 w x y z
 
--- | TODO optimise cube
-cube :: [V3 GL.GLfloat]
-cube =
-  [ V3 p p p, -- front
-    V3 p m p,
-    V3 m p p,
-    V3 m m p, -- down
-    V3 m m m,
-    V3 p m p,
-    V3 p m m, -- right
-    V3 p p m,
-    V3 p m p,
-    V3 p p p, -- up
-    V3 m p p,
-    V3 p p m,
-    V3 m p m, -- back
-    V3 p m m,
-    V3 p p m,
-    V3 m m m, -- left
-    V3 m p m,
-    V3 m m p,
-    V3 m p p
+rotate :: V3 GL.GLfloat -> GL.GLfloat -> V3 GL.GLfloat -> V3 GL.GLfloat
+rotate axis angle point = L.fromQuaternion (L.axisAngle axis angle) L.!* point
+
+rotate4 :: Int -> Int -> GL.GLfloat -> V4 GL.GLfloat -> V4 GL.GLfloat
+rotate4 i0 i1 angle (V4 x y z w) =
+  let coords = [x, y, z, w]
+      cos' = cos angle
+      sin' = sin angle
+      xi = coords !! i0
+      xj = coords !! i1
+      coords' =
+        [ if k == i0
+            then cos' * xi - sin' * xj
+            else
+              if k == i1
+                then sin' * xi + cos' * xj
+                else coords !! k
+        | k <- [0 .. 3]
+        ]
+   in V4 (coords' !! 0) (coords' !! 1) (coords' !! 2) (coords' !! 3)
+
+cycle3r :: V3 GL.GLfloat -> V3 GL.GLfloat
+cycle3r (V3 a b c) = V3 c a b
+
+cycle3l :: V3 GL.GLfloat -> V3 GL.GLfloat
+cycle3l (V3 a b c) = V3 b c a
+
+face :: [V3 GL.GLfloat]
+face =
+  [ V3 m m 0,
+    V3 p m 0,
+    V3 m p 0,
+    V3 m p 0,
+    V3 p m 0,
+    V3 p p 0
   ]
 
--- | TODO optimise hCube
+-- | cube, side length 1, centered on 0 0 0
+cube :: [V3 GL.GLfloat]
+cube =
+  concatMap
+    ( \faceSpec ->
+        map
+          (\v -> (rotate (fst faceSpec) g90 v) L.^+^ (rotate (fst faceSpec) g90 (snd faceSpec)))
+          face
+    )
+    [ (V3 0 0 1, V3 0 0 p),
+      (V3 0 1 0, V3 0 0 p),
+      (V3 1 0 0, V3 0 0 p),
+      (V3 0 0 (-1), V3 0 0 m), -- no clue
+      (V3 0 (-1) 0, V3 0 0 p),
+      (V3 (-1) 0 0, V3 0 0 p)
+    ]
+
 hCube :: [V4 GL.GLfloat]
 hCube =
-  (map (v3tov4 m) cube)
-    ++ (map (v3tov4 p) cube)
-    ++ (map (v3tov4' m) cube)
-    ++ (map (v3tov4' p) cube)
-    ++ (map (v3tov4'' m) cube)
-    ++ (map (v3tov4'' p) cube)
-    ++ (map (v3tov4''' m) cube)
-    ++ (map (v3tov4''' p) cube)
+  concatMap
+    ( \(w, i0, i1) ->
+        map
+          (rotate4 i0 i1 g90 . v3tov4 w)
+          cube
+    )
+    [ (p, 3, 0),
+      (p, 0, 3),
+      (p, 1, 3),
+      (p, 2, 3),
+      (m, 3, 0),
+      (m, 0, 3),
+      (m, 1, 3),
+      (m, 2, 3)
+    ]
 
 --------------------------------------------------------------------------------
 -- Elm-like data structures
@@ -158,10 +181,32 @@ hCube =
 -- | update function
 update :: Float -> Model -> Model
 update dt model =
-  updateVelocity dt $
-    updateAcceleration dt $
-      updateSpeed dt $
-        updateCameraAngle 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 =
@@ -215,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 $
@@ -246,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
                       }
                 }
@@ -256,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)
           }
     }
 
@@ -299,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 - forward)
+          (model.camera.camPos ^. _xyz)
+          ((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