Andromeda/hs-game
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
andromeda
2026-02-08 15:08:46 +01:00
parent 4d59cd7569
commit 602507a605
4 changed files with 148 additions and 59 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
flake.nix
View File

@@ -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 {

125
src/Game/Internal.hs
View File

@@ -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.Triangles (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
@@ -69,44 +75,81 @@ listIOsToIOlist (io : ios) out = do
vertShader :: String
vertShader =
unlines
[ "#version 330 core",
"layout (location = 0) in vec4 a_vPos;",
"uniform mat4 u_view;",
"uniform mat4 u_projection;",
"out vec3 v_pos;",
glslProjectTo3d,
"void main()",
"{",
" vec3 vPos = projectTo3d(a_vPos);",
" gl_Position = u_projection * u_view * vec4(vPos, 1.0);",
" v_pos = vPos;",
"}"
]
"""
#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;
}
"""
fragShader :: String
fragShader =
unlines
[ "#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);",
"}"
]
"""
#version 330 core
glslProjectTo3d :: String
glslProjectTo3d =
unlines
[ "vec3 projectTo3d(vec4 point)",
"{",
" float perspective = 1.0 / (1.0 + point.w);",
" return perspective * point.xyz;",
"}"
]
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

4
src/Game/Internal/Types.hs
View File

@@ -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 ->

74
src/Main.hs
View File

@@ -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 ..]]
++ [map (+ V4 a 0 0 0) hCube | a <- take 100 [0, (-2) ..]]
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
@@ -173,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 =
@@ -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 - 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