path: root/src/Game/Internal.hs

{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{- |
 - Module      : Game.Internal
 - Description : 'hidden' functions
 - Copyright   : Andromeda 2025
 - License     : WTFPL
 - Maintainer  : Matrix @Andromeda:tchncs.de
 - Stability   : Experimental
 -}
module Game.Internal
  ( cursorPosHandler
  , drawObjects
  , initResources
  , keyPressed
  , loop
  , resizeWindow
  , shutdownWindow
  , updateCursorPos
  , updateKeyPressed
  , updateKeyReleased
  )
  where

import Game.Internal.LoadShaders
import Game.Internal.Types

import Control.Concurrent    (threadDelay)
import Control.Lens          ((^.), (+~), (&), (%~))
import Control.Monad         (when)
import Data.Fixed            (mod')
import Data.IORef            (atomicModifyIORef', IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.List             (delete)
import Foreign.Marshal.Array (withArray)
import Foreign.Ptr           (nullPtr, plusPtr)
import Foreign.Storable      (sizeOf, Storable)
import GHC.Float             (double2Float)

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      ( V3(..)
                             , _x
                             , _y
                             , _z
                             )

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

-- | loads models, shaders
initResources :: GLFW.Window -> [V3 GL.GLfloat] -> IO ([Object], GL.Program)
initResources window array = do
  -- create objects
  testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip
  testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip
  testObject2 <- createObject array 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" ++
  "out vec3 v_pos;\n" ++
  "void main()\n" ++
  "{\n" ++
  "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
  "  v_pos = a_vPos;\n" ++
  "}"
  
-- | 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 * v_pos, 1);\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
    )

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

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

  -- tick model
  modifyIORef' modelRef $ update dt
  model' <- readIORef modelRef

  -- view new model
  view window model'

  -- end frame timer, wait the difference between expected and actual
  Just frameEnd <- GLFW.getTime
  let
    dt = double2Float $ frameEnd - frameStart
    target = 1 / 60 :: Float
  when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000
  Just frameEnd' <- GLFW.getTime
  let
    dt' = double2Float $ frameEnd' - frameStart

  loop window dt' update view modelRef

-- | updates given a keypress. escape case is probably caught by GLFW in the
-- handler function itself
updateKeyPressed :: GLFW.Key -> Model -> Model
updateKeyPressed key model =
  model { keys = key:model.keys }

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

applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
applyToTuples f (x, y) (a, b) = (f x a, f y b)

-- | updates cursor
updateCursorPos :: Double -> Double -> Model ->  Model
updateCursorPos x y model =
  let
    pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos - y)) ** 2) ** 0.5
  in
  if pyth < 16 then
    model
      { cursorPos = (x, y)
      , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
      }
  else 
    model
      { cursorPos = (x, y)
      }

-- | 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 ()

-- | handles cursor position updates
cursorPosHandler :: Maybe (IORef Model) -> GLFW.CursorPosCallback
cursorPosHandler (Just modelRef) _ x y =
  modifyIORef' modelRef $ updateCursorPos x y
cursorPosHandler Nothing _ _ _ = return ()