broken

src/Game/LoadShaders.hs

@@ -0,0 +1,89 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  LoadShaders
+-- Copyright   :  (c) Sven Panne 2013
+-- License     :  BSD3
+--
+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
+-- Stability   :  stable
+-- Portability :  portable
+--
+-- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The
+-- Red Book Authors.
+--
+--------------------------------------------------------------------------------
+
+module Game.LoadShaders (
+   ShaderSource(..), ShaderInfo(..), loadShaders
+) where
+
+import Control.Exception
+import Control.Monad
+import qualified Data.ByteString as B
+import Graphics.Rendering.OpenGL
+
+--------------------------------------------------------------------------------
+
+-- | The source of the shader source code.
+
+data ShaderSource =
+     ByteStringSource B.ByteString
+     -- ^ The shader source code is directly given as a 'B.ByteString'.
+   | StringSource String
+     -- ^ The shader source code is directly given as a 'String'.
+   | FileSource FilePath
+     -- ^ The shader source code is located in the file at the given 'FilePath'.
+   deriving ( Eq, Ord, Show )
+
+getSource :: ShaderSource -> IO B.ByteString
+getSource (ByteStringSource bs) = return bs
+getSource (StringSource str) = return $ packUtf8 str
+getSource (FileSource path) = B.readFile path
+
+--------------------------------------------------------------------------------
+
+-- | A description of a shader: The type of the shader plus its source code.
+
+data ShaderInfo = ShaderInfo ShaderType ShaderSource
+   deriving ( Eq, Ord, Show )
+
+--------------------------------------------------------------------------------
+
+-- | Create a new program object from the given shaders, throwing an
+-- 'IOException' if something goes wrong.
+
+loadShaders :: [ShaderInfo] -> IO Program
+loadShaders infos =
+   createProgram `bracketOnError` deleteObjectName $ \program -> do
+      loadCompileAttach program infos
+      linkAndCheck program
+      return program
+
+linkAndCheck :: Program -> IO ()
+linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
+
+loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
+loadCompileAttach _ [] = return ()
+loadCompileAttach program (ShaderInfo shType source : infos) =
+   createShader shType `bracketOnError` deleteObjectName $ \shader -> do
+      src <- getSource source
+      shaderSourceBS shader $= src
+      compileAndCheck shader
+      attachShader program shader
+      loadCompileAttach program infos
+
+compileAndCheck :: Shader -> IO ()
+compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
+
+checked :: (t -> IO ())
+        -> (t -> GettableStateVar Bool)
+        -> (t -> GettableStateVar String)
+        -> String
+        -> t
+        -> IO ()
+checked action getStatus getInfoLog message object = do
+   action object
+   ok <- get (getStatus object)
+   unless ok $ do
+      infoLog <- get (getInfoLog object)
+      fail (message ++ " log: " ++ infoLog)

src/Game/Main.hs

@@ -1,6 +1,351 @@
+{-# 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 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
-  putStrLn "Hallo Welt"
-  return ()
+  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 5)
+            (V3 0 0 0)
+            (V3 0 1 0)
+          )
+          program
+  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, 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 / 60 :: Double
+  when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000
+
+  loop window update view modelRef
+
+-- | update function
+update :: Model -> Model
+update 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@(Model
+    objects
+    (Camera
+      (V3 cPx cPy cPz)
+      (V3 cTx cTy cTz)
+      camUp
+    )
+    program
+  )) =
+  let dP = 0.2 in
+    case key of
+      GLFW.Key'W -> Model objects (Camera (V3 cPx cPy (cPz - dP)) (V3 cTx cTy (cTz - dP)) camUp) program
+      GLFW.Key'S -> Model objects (Camera (V3 cPx cPy (cPz + dP)) (V3 cTx cTy (cTz + dP)) camUp) program
+      GLFW.Key'A -> Model objects (Camera (V3 (cPx - dP) cPy cPz) (V3 (cTx - dP) cTy cTz) camUp) program
+      GLFW.Key'D -> Model objects (Camera (V3 (cPx + dP) cPy cPz) (V3 (cTx + dP) cTy cTz) camUp) program
+      _ -> model
+
+-- | views the model
+view :: GLFW.Window -> Model -> IO ()
+view window (model@(Model objects (Camera camPos camTarget camUp) 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 (fromIntegral w / fromIntegral h) 0.1 100
+
+  viewGLMatrix <- GL.newMatrix GL.ColumnMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat)
+  viewLocation <- GL.get $ GL.uniformLocation program "u_view"
+  GL.uniform viewLocation $= viewGLMatrix
+
+  projectionGLMatrix <- GL.newMatrix GL.ColumnMajor $ 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
+
+-- | camera
+data Camera =
+  Camera
+    (V3 Float) -- ^ camera location
+    (V3 Float) -- ^ camera target
+    (V3 Float) -- ^ camera up vector
+
+-- | 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 _ _ _ _ _ _ = return ()