path: root/src/Game/Main.hs

{-# OPTIONS_GHC -fwarn-name-shadowing #-}
{- |
 - Module      : Game
 - Description : runs game
 - Copyright   : Andromeda 2025
 - License     : WTFPL
 - Maintainer  : Matrix @Andromeda:tchncs.de
 - Stability   : Experimental
 -}
module Game (main) where

import Game.LoadShaders

import Control.Concurrent    (threadDelay)
import Control.Monad         (when)
import Data.IORef            (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.List             (delete, nub)
import Foreign.Marshal.Array (withArray)
import Foreign.Ptr           (nullPtr, plusPtr)
import Foreign.Storable      (sizeOf, Storable)

import qualified Graphics.UI.GLFW          as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import           Graphics.Rendering.OpenGL as GL (($=))

import qualified Linear as L
import           Linear      (V2, V3, V4, M44, V2(..), V3(..), V4(..))

-- | Main function runs game
main :: IO ()
main = do
  GLFW.init
  GLFW.defaultWindowHints

  -- OpenGL core >=3.3
  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
  GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
  
  -- 4x MSAA
  GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 4

  -- create window
  monitor <- GLFW.getPrimaryMonitor
  Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing 
  GLFW.makeContextCurrent $ Just window

  -- add callbacks
  GLFW.setWindowCloseCallback window $ Just shutdownWindow
  GLFW.setWindowSizeCallback window $ Just resizeWindow
  GLFW.setKeyCallback window $ Just (keyPressed Nothing)

  (objects, program) <- initResources window

  -- init model
  let model =
        Model
          objects
          (Camera
            (V3 0 0 3)
            (V3 0 0 0)
            (V3 0 1 0)
            (V3 0 0 0)
          )
          program
          []
          (WorldProperties
            600
            300
          )
  modelRef <- newIORef model

  -- add key callback with io ref to model
  GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef

  loop window update view modelRef

--------------------------------------------------------------------------------
-- Arrays
--------------------------------------------------------------------------------

-- | centered unit square
testVertices :: [V3 GL.GLfloat]
testVertices =
  [ V3 (-0.5) (-0.5) 0
  , V3 0.5    (-0.5) 0
  , V3 (-0.5) 0.5    0
  , V3 0.5    0.5    0
  ]

--------------------------------------------------------------------------------
-- Shader creation and object initialisation
--------------------------------------------------------------------------------

-- | loads models, shaders
initResources :: GLFW.Window -> IO ([Object], GL.Program)
initResources window = do
  -- create objects
  testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) testVertices) 3 GL.TriangleStrip
  testObject1 <- createObject (map (+(V3 (1) (1) (1))) testVertices) 3 GL.TriangleStrip
  testObject2 <- createObject testVertices 3 GL.TriangleStrip
  let objects = [testObject0, testObject1, testObject2]

  -- load shaders
  program <- loadShaders
    [ ShaderInfo GL.VertexShader (StringSource vertShader)
    , ShaderInfo GL.FragmentShader (StringSource fragShader)
    ]
  GL.currentProgram $= Just program

  return (objects, program)

-- a_ vertex shader input
-- v_ varying
-- u_ uniform
-- o_ fragment shader output

-- | vertex shader
vertShader :: String
vertShader =
  "#version 330 core\n" ++
  "layout (location = 0) in vec3 a_vPos;\n" ++
  "uniform mat4 u_view;\n" ++
  "uniform mat4 u_projection;\n" ++
  "void main()\n" ++
  "{\n" ++
  "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
  "}"
  
-- | fragment shader
fragShader :: String
fragShader =
  "#version 330 core\n" ++
  "out vec4 o_vColor;\n" ++
  "void main()\n" ++
  "{\n" ++
  "  o_vColor = vec4(0.5, 0.5, 0.5, 1.0);\n" ++
  "}"

--------------------------------------------------------------------------------
-- Objects
--------------------------------------------------------------------------------

-- | calculates the size in memory of an array
sizeOfArray :: (Storable a, Num b) => [a] -> b
sizeOfArray [] = 0
sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x

-- | loads a given array into a given attribute index
createVBO
  :: Storable (a GL.GLfloat)
  => [a GL.GLfloat]
  -> GL.NumComponents
  -> GL.AttribLocation
  -> IO GL.BufferObject
createVBO array numComponents attribLocation = do
  -- vbo for buffer
  buffer <- GL.genObjectName
  GL.bindBuffer GL.ArrayBuffer $= Just buffer

  -- populate buffer
  withArray
    array
    $ \ptr ->
        GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)

  -- create attribute pointer to buffer
  GL.vertexAttribPointer attribLocation $=
    ( GL.ToFloat
    , GL.VertexArrayDescriptor
        numComponents
        GL.Float
        0
        (plusPtr nullPtr 0)
    )
  GL.vertexAttribArray attribLocation $= GL.Enabled

  return buffer

-- | creates an object from a given array; deals with vbos and everything
createObject
  :: Storable (a GL.GLfloat)
  => [a GL.GLfloat]
  -> GL.NumComponents
  -> GL.PrimitiveMode
  -> IO Object
createObject array numComponents primitiveMode = do
  -- vao for object
  vao <- GL.genObjectName
  GL.bindVertexArrayObject $= Just vao

  -- vbo for vertices
  createVBO array numComponents $ GL.AttribLocation 0

  return
    (Object
      vao
      (fromIntegral $ length array)
      numComponents
      primitiveMode
    )

-- | represents a single draw call
data Object =
  Object
    GL.VertexArrayObject
    GL.NumArrayIndices
    GL.NumComponents
    GL.PrimitiveMode

--------------------------------------------------------------------------------
-- Elm-like data structures
--------------------------------------------------------------------------------

-- | gameloop
loop
  :: GLFW.Window -- ^ window to display on
  -> (Model -> Model) -- ^ update function
  -> (GLFW.Window -> Model -> IO ()) -- ^ view function
  -> IORef Model -- ^ model
  -> IO ()
loop window update view modelRef = do
  -- start frame timer
  Just frameStart <- GLFW.getTime

  -- tick model
  model <- readIORef modelRef
  let model' = update model
  writeIORef modelRef model'

  -- view new model
  view window model'
  
  -- end frame timer, wait the difference between expected and actual
  Just frameEnd <- GLFW.getTime
  let
    dt = frameEnd - frameStart :: Double
    target = 1 / 30 :: Double
  when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000

  loop window update view modelRef

-- | update function
update :: Model -> Model
update model =
  updateVelocity
    $ updateAcceleration
        model

updateAcceleration :: Model -> Model
updateAcceleration model = model

updateVelocity :: Model -> Model
updateVelocity model = model
  

-- | updates given a keypress. escape case is probably caught by GLFW in the
-- handler function itself
updateKeyPressed :: GLFW.Key -> Model -> Model
updateKeyPressed
  key
  (Model
    objects
    camera
    program
    keys
    wprops
  ) =
  Model
    objects
    camera
    program
    (nub $ key:keys)
    wprops

-- | updates given a keyrelease. escape case is probably caught by GLFW in the
-- handler function itself
updateKeyReleased :: GLFW.Key -> Model -> Model
updateKeyReleased
  key
  (Model
    objects
    camera
    program
    keys
    wprops
  ) =
  Model
    objects
    camera
    program
    (delete key keys)
    wprops

-- | views the model
view :: GLFW.Window -> Model -> IO ()
view
  window
  (model@(Model
    objects
    (Camera
      camPos
      camTarget
      camUp
      velocity
    )
    program
    _
    _
  )) = do
  -- fit viewport to window
  (w, h) <- GLFW.getFramebufferSize window
  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))

  -- clear screen
  GL.clearColor $= GL.Color4 1 0 1 1
  GL.clear [GL.ColorBuffer, GL.DepthBuffer]

  -- apply transforms
  let
    viewMatrix = L.lookAt camPos camTarget camUp
    projectionMatrix = L.perspective 1.4 (fromIntegral w / fromIntegral h) 0.1 100

  viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat)
  viewLocation <- GL.get $ GL.uniformLocation program "u_view"
  GL.uniform viewLocation $= viewGLMatrix

  projectionGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat)
  projectionLocation <- GL.get $ GL.uniformLocation program "u_projection"
  GL.uniform projectionLocation $= projectionGLMatrix

  -- draw objects
  drawObjects objects

  -- swap to current buffer
  GLFW.swapBuffers window

  -- check for interrupts
  GLFW.pollEvents

toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat]
toGLMatrix
  (V4
    (V4 c00 c01 c02 c03)
    (V4 c10 c11 c12 c13)
    (V4 c20 c21 c22 c23)
    (V4 c30 c31 c32 c33)) =
  [ c00, c01, c02, c03
  , c10, c11, c12, c13
  , c20, c21, c22, c23
  , c30, c31, c32, c33
  ]

-- | gamestate
data Model =
  Model
    [Object]
    Camera
    GL.Program
    [GLFW.Key]
    WorldProperties

-- | camera
data Camera =
  Camera
    (V3 Float) -- ^ camera location
    (V3 Float) -- ^ camera target
    (V3 Float) -- ^ camera up vector
    (V3 Float) -- ^ velocity

data WorldProperties =
  WorldProperties
    Float -- ^ gravity `g`
    Float -- ^ floor friction

-- | draws objects
drawObjects :: [Object] -> IO ([Object])
drawObjects [] = return []
drawObjects
  ((Object vao numVertices _ primitiveMode):objects) = do
  GL.bindVertexArrayObject $= Just vao
  GL.drawArrays primitiveMode 0 numVertices
  drawObjects objects

--------------------------------------------------------------------------------
-- interrupts
--------------------------------------------------------------------------------

-- | shuts down GLFW
shutdownWindow :: GLFW.WindowCloseCallback
shutdownWindow window = do
  GLFW.destroyWindow window
  GLFW.terminate

-- | resizes viewport with window
resizeWindow :: GLFW.WindowSizeCallback
resizeWindow _ _ _ = return ()

-- | handles key presses
keyPressed :: Maybe (IORef Model) -> GLFW.KeyCallback
keyPressed _ window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ =
  shutdownWindow window
keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ =
  modifyIORef' modelRef $ updateKeyPressed key
keyPressed (Just modelRef) window key _ GLFW.KeyState'Released _ =
  modifyIORef' modelRef $ updateKeyReleased key
keyPressed _ _ _ _ _ _ = return ()