diff options
| -rw-r--r-- | src/Game/LoadShaders.hs | 89 | ||||
| -rw-r--r-- | src/Game/Main.hs | 349 |
2 files changed, 436 insertions, 2 deletions
diff --git a/src/Game/LoadShaders.hs b/src/Game/LoadShaders.hs new file mode 100644 index 0000000..3d24e78 --- /dev/null +++ b/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) diff --git a/src/Game/Main.hs b/src/Game/Main.hs index 839ea70..e73b24e 100644 --- a/src/Game/Main.hs +++ b/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 () |