diff --git a/extern/affection/.gitignore b/extern/affection/.gitignore index fa507cf..237cc52 100644 --- a/extern/affection/.gitignore +++ b/extern/affection/.gitignore @@ -16,3 +16,5 @@ cabal.project.local* dist*/ report.html *.bak +.direnv/ +.envrc diff --git a/extern/affection/affection.cabal b/extern/affection/affection.cabal index 7c16fc5..a8f90b6 100644 --- a/extern/affection/affection.cabal +++ b/extern/affection/affection.cabal @@ -102,7 +102,7 @@ library ghc-options: -Wall -- Other library packages from which modules are imported. build-depends: base >=4.9 && < 5 - , sdl2 ^>= 2.5 + , sdl2 >= 2.5 , linear , text , mtl @@ -117,6 +117,7 @@ library , stm , uuid , vector + , resourcet -- This example shows the message system. only makes sense when compiling with -- verbose flag. @@ -126,12 +127,11 @@ executable example00 ghc-options: -threaded -Wall default-language: Haskell2010 default-extensions: OverloadedStrings - if flag(examples) - build-depends: base >=4.9 && < 5 - , affection - , sdl2 ^>= 2.5 - , stm - else + build-depends: base >=4.9 && < 5 + , affection + , sdl2 >= 2.5 + , stm + if !flag(examples) buildable: False -- A small game of life implementation @@ -142,19 +142,18 @@ executable example01 ghc-options: -threaded -Wall default-language: Haskell2010 default-extensions: OverloadedStrings - if flag(examples) - build-depends: base >=4.9 && < 5 - , affection - , sdl2 ^>= 2.5 - , stm - , OpenGL - , random - , containers - , linear - , matrix - , nanovg >= 0.6.0.0 - , deepseq - else + build-depends: base >=4.9 && < 5 + , affection + , sdl2 >= 2.5 + , stm + , OpenGL + , random + , containers + , linear + , matrix + , nanovg >= 0.6.0.0 + , deepseq + if !flag(examples) buildable: False -- Another small game of life implementation @@ -165,17 +164,16 @@ executable example02 ghc-options: -threaded -Wall default-language: Haskell2010 default-extensions: OverloadedStrings - if flag(examples) - build-depends: base >=4.9 && < 5 - , affection - , sdl2 ^>= 2.5 - , stm - , OpenGL - , random - , containers - , linear - , matrix - , nanovg >= 0.6.0.0 - , deepseq - else + build-depends: base >=4.9 && < 5 + , affection + , sdl2 >= 2.5 + , stm + , OpenGL + , random + , containers + , linear + , matrix + , nanovg >= 0.6.0.0 + , deepseq + if !flag(examples) buildable: False diff --git a/extern/affection/shell.nix b/extern/affection/shell.nix index 9451c76..a4f6bdd 100644 --- a/extern/affection/shell.nix +++ b/extern/affection/shell.nix @@ -1,125 +1,7 @@ -{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: +{ pkgs ? import {}}: let - - inherit (nixpkgs) pkgs; - - nanovg = with haskellPackages; callPackage ( - { mkDerivation, base, bytestring, c2hs, containers, glew - , hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector - }: - mkDerivation { - pname = "nanovg"; - version = "0.6.0.0"; - sha256 = "e35a2772f2a2e71916013cab70eeb8eedd6f66b5490ddf7ce237c8c76895d496"; - revision = "1"; - editedCabalFile = "1lhfsq50r9bdby7mfscw8ih3wsz2m19lr2a2z9b6diaf5kz76vij"; - isLibrary = true; - isExecutable = true; - doCheck = false; - libraryHaskellDepends = [ base bytestring containers text vector ]; - librarySystemDepends = [ glew libGL libGLU ]; - libraryPkgconfigDepends = [ glew ]; - libraryToolDepends = [ c2hs ]; - testHaskellDepends = [ base containers hspec inline-c QuickCheck ]; - homepage = "https://github.com/cocreature/nanovg-hs"; - description = "Haskell bindings for nanovg"; - license = stdenv.lib.licenses.isc; - }) {}; - - glib = with haskellPackages; callPackage( - { mkDerivation, base, bytestring, Cabal, containers, glib - , stdenv, text, utf8-string, gtk2hs-buildtools - }: - mkDerivation { - pname = "glib"; - version = "0.13.8.0"; - sha256 = "9cce6fb44e3c30de2bd330a6902955e3a5fce7b6e9ce41a4afb70e3a7d6e61a2"; - setupHaskellDepends = [ base Cabal gtk2hs-buildtools ]; - libraryHaskellDepends = [ - base bytestring containers text utf8-string - ]; - libraryPkgconfigDepends = [ pkgs.glib ]; - homepage = "http://projects.haskell.org/gtk2hs/"; - description = "Binding to the GLIB library for Gtk2Hs"; - license = stdenv.lib.licenses.lgpl21; - }) {}; - - #gtk2hs-buildtools = with haskellPackages; callPackage( - # { mkDerivation, alex, array, base, Cabal, containers, directory - # , filepath, happy, hashtables, pretty, process, random, stdenv - # }: - # mkDerivation { - # pname = "gtk2hs-buildtools"; - # version = "0.13.4.0"; - # src = ../gtk2hs/tools; - # isLibrary = true; - # isExecutable = true; - # enableSeparateDataOutput = true; - # libraryHaskellDepends = [ - # array base Cabal containers directory filepath hashtables pretty - # process random - # ]; - # libraryToolDepends = [ alex happy ]; - # executableHaskellDepends = [ base ]; - # homepage = "http://projects.haskell.org/gtk2hs/"; - # description = "Tools to build the Gtk2Hs suite of User Interface libraries"; - # license = stdenv.lib.licenses.gpl2; - # }) {}; - - sdl2 = with haskellPackages; callPackage( - { mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2 - , StateVar, stdenv, text, transformers, vector, weigh - }: - mkDerivation { - pname = "sdl2"; - version = "2.5.1.0"; - sha256 = "fc1d3d4276b2c4f835a5311075abb240385aae7edad8760f6bda55ed8271ed20"; - isLibrary = true; - isExecutable = true; - enableSeparateDataOutput = true; - libraryHaskellDepends = [ - base bytestring exceptions linear StateVar text transformers vector - ]; - librarySystemDepends = [ SDL2 ]; - libraryPkgconfigDepends = [ SDL2 ]; - testHaskellDepends = [ base deepseq linear vector weigh ]; - description = "Both high- and low-level bindings to the SDL library (version 2.0.6+)."; - license = stdenv.lib.licenses.bsd3; - doCheck = false; - }) {}; - - f = { mkDerivation, base, bytestring, clock, containers, deepseq - , linear, matrix, monad-loops, monad-parallel, mtl - , OpenGL, OpenGLRaw, random, stdenv, stm, text, uuid, vector - }: - mkDerivation { - pname = "affection"; - version = "0.0.0.9"; - src = ./.; - configureFlags = [ "-fexamples" ]; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - base bytestring clock containers glib linear monad-loops - monad-parallel mtl OpenGL OpenGLRaw sdl2 stm text uuid vector - ]; - executableHaskellDepends = [ - base containers deepseq linear matrix nanovg OpenGL random sdl2 stm - ]; - homepage = "https://github.com/nek0/affection#readme"; - description = "A simple Game Engine using SDL"; - license = stdenv.lib.licenses.lgpl3; - }; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; - - drv = variant (haskellPackages.callPackage f {}); - + affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {}; + gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir; in - - if pkgs.lib.inNixShell then drv.env else drv + affection.env diff --git a/extern/affection/src/Affection.hs b/extern/affection/src/Affection.hs index 64e8d29..333c117 100644 --- a/extern/affection/src/Affection.hs +++ b/extern/affection/src/Affection.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} @@ -23,12 +22,16 @@ import qualified Graphics.GL as GLRaw import Foreign.Marshal.Array import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 + +import Data.String (fromString) import System.Clock import Control.Monad.Loops import Control.Monad.State.Strict +import Control.Monad.Trans.Resource + +-- internal imports -- internal imports @@ -46,46 +49,83 @@ withAffection :: forall us. (Affectionate us) => AffectionConfig us -- ^ Configuration of the Game and its engine. -> IO () -withAffection AffectionConfig{..} = do +withAffection AffectionConfig{..} = runResourceT $ do liftIO $ logIO Debug "Affection starting" liftIO $ logIO Debug "Initializing SDL" + -- intialiaze SDL case initComponents of All -> SDL.initializeAll Only is -> SDL.initialize is + -- give SDL render quality SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear + -- just checking… - do - renderQuality <- SDL.get SDL.HintRenderScaleQuality - when (renderQuality /= SDL.ScaleLinear) $ - logIO Warn "Linear texture filtering not enabled!" + renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + liftIO $ logIO Warn "Linear texture filtering not enabled!" + void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer))) + -- construct window liftIO $ logIO Debug "Creating Window(s)" - windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$> + windows <- mapM - (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc)) - windowConfigs <*> - pure (map (\(_,_,z) -> z) windowConfigs) + (\(_, sdlWindowConfig, mode) -> do + (windowKey, window) <- + allocate + (SDL.createWindow windowTitle sdlWindowConfig) + (\window -> do + logIO Debug "Destroying Window" + SDL.destroyWindow window + ) + return $ AffectionWindow window windowKey mode + ) + windowConfigs + + -- Show windows + mapM_ (SDL.showWindow . awWindow) windows + + -- set modes of windows + mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows + + -- Make GL context shareable + void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 + + -- Create OpenGL contexts + contexts <- + mapM + (\(AffectionWindow window _ _) -> do + (contextKey, context) <- + allocate + (SDL.glCreateContext window) + (\context -> do + logIO Debug "Destroying context" + SDL.glDeleteContext context + ) + return $ AffectionContext context contextKey + ) + windows - mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows - _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 - contexts <- zip (map (\(x,_,_) -> x) windows) <$> - mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows - mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows -- sync updates with monitor -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows - liftIO $ logIO Debug "Getting Time" + -- print current used GL Version - version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION - print (B.pack version) + version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION + liftIO $ print (B.pack version) + -- get current time - execTime <- getTime Monotonic + liftIO $ logIO Debug "Getting Time" + execTime <- liftIO $ getTime Monotonic liftIO $ logIO Debug "Loading initial data container" + -- construct game data object from provided Affectionate instance - gameData <- loadState @us + (gameDataKey, gameData) <- + allocate + (liftIO $ loadState @us) + (liftIO . cleanUp) -- build state container let initContainer = AffectionData { drawWindows = windows @@ -95,9 +135,9 @@ withAffection AffectionConfig{..} = do , sysTime = execTime , pausedTime = False } + -- initialize and run state - (_, _) <- runStateT - (A.runState + void $ liftIO $ runAffection initContainer (do liftIO $ logIO Debug "Running Pre-Loop stage" -- run preLoop function from Affectionate @@ -107,9 +147,11 @@ withAffection AffectionConfig{..} = do (do -- get state ad <- get + -- Measure time difference form last run now <- liftIO $ getTime Monotonic let lastTime = sysTime ad + -- compute dt and update elapsedTime let dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) @@ -119,18 +161,25 @@ withAffection AffectionConfig{..} = do { elapsedTime = ne , deltaTime = dt } + -- poll events + liftIO SDL.pumpEvents evs <- preHandleEvents =<< liftIO SDL.pollEvents + -- handle events handleEvents gameData evs + -- execute user defined update loop unless (pausedTime ad) (update gameData dt) + -- clear GL buffer >> execute user defined draw loop >> flush GL buffer liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] draw gameData liftIO GL.flush + -- actual displaying of newly drawn frame - mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows + mapM_ (SDL.glSwapWindow . awWindow) windows + -- save new time ad3 <- get when (sysTime ad == sysTime ad3) ( @@ -140,11 +189,16 @@ withAffection AffectionConfig{..} = do ) ) ) - ) initContainer + -- Cleanup works liftIO $ logIO Debug "Loop ended. Cleaning" - cleanUp gameData - liftIO $ logIO Debug "Destroying Window" - mapM_ (SDL.glDeleteContext . snd) contexts - mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows + release gameDataKey + -- mapM_ (SDL.glDeleteContext . snd) contexts + -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows -- SDL.quit -- <- This causes segfaults depending on hardware liftIO $ logIO Debug "This is the end" + +runAffection + :: AffectionData + -> AffectionState AffectionData ResIO a + -> IO (a, AffectionData) +runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState diff --git a/extern/affection/src/Affection/Types.hs b/extern/affection/src/Affection/Types.hs index a7d8eb4..e4fd82a 100644 --- a/extern/affection/src/Affection/Types.hs +++ b/extern/affection/src/Affection/Types.hs @@ -5,6 +5,8 @@ module Affection.Types , AffectionData(..) , AffectionStateInner , AffectionState(..) + , AffectionWindow(..) + , AffectionContext(..) , InitComponents(..) , Angle -- | SDL reexports @@ -23,6 +25,7 @@ import qualified Data.Text as T import Control.Monad.IO.Class import Control.Monad.State.Strict +import Control.Monad.Trans.Resource import qualified Control.Monad.Parallel as MP import System.Clock (TimeSpec) @@ -50,35 +53,35 @@ data InitComponents -- | Main type for defining the look, feel and action of the whole application. data AffectionData = AffectionData - { drawWindows :: - [ - ( Word -- --^ Window identifier - , SDL.Window -- --^ Window linked with identifier - , SDL.WindowMode -- -- ^ current screen mode - ) - ] -- ^ SDL windows - , glContext :: - [ - ( Word -- --^ Window identifier - , SDL.GLContext -- --^ Associated OpenGL context - ) - ] -- ^ OpenGL rendering contexts - , elapsedTime :: Double -- ^ Elapsed time in seconds - , deltaTime :: Double -- ^ Elapsed time in seconds since last tick - , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) - , pausedTime :: Bool -- ^ Should the update loop be executed? + { drawWindows :: [ AffectionWindow ] -- ^ SDL windows + , glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts + , elapsedTime :: Double -- ^ Elapsed time in seconds + , deltaTime :: Double -- ^ Elapsed time in seconds since last tick + , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) + , pausedTime :: Bool -- ^ Should the update loop be executed? } -- | Inner 'StateT' monad for the update state -type AffectionStateInner sd a = StateT sd a +type AffectionStateInner sd m = StateT sd m -- | Affection's state monad newtype AffectionState sd m a = AffectionState { runState :: AffectionStateInner sd m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadState sd) + deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource) instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m) -type Affection a = AffectionState AffectionData IO a +type Affection a = AffectionState AffectionData ResIO a type Angle = Double + +data AffectionWindow = AffectionWindow + { awWindow :: SDL.Window + , awReleaseKey :: ReleaseKey + , awMode :: SDL.WindowMode + } + +data AffectionContext = AffectionContext + { acContext :: SDL.GLContext + , acReleaseKey :: ReleaseKey + } diff --git a/extern/affection/src/Affection/Util.hs b/extern/affection/src/Affection/Util.hs index 763f0ee..465620c 100644 --- a/extern/affection/src/Affection/Util.hs +++ b/extern/affection/src/Affection/Util.hs @@ -39,32 +39,35 @@ getDelta = gets deltaTime toggleScreen :: Word -> Affection () toggleScreen windowIdent = do ad <- get - let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad) - case mwindow of - Just (ident, window, mode) -> do - newMode <- case mode of - SDL.FullscreenDesktop -> do - SDL.setWindowMode window SDL.Windowed - return SDL.Windowed - SDL.Windowed -> do - SDL.setWindowMode window SDL.FullscreenDesktop - return SDL.FullscreenDesktop - x -> do - liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) - return x - now <- liftIO $ getTime Monotonic - put ad - { sysTime = now - , drawWindows = map - (\e@(lid, win, _) -> - if lid == ident - then (lid, win, newMode) - else e - ) - (drawWindows ad) - } - Nothing -> do - liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent)) + (stop, alteredWindowList) <- foldM + (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do + if stop || num == windowIdent + then do + newMode <- case mode of + SDL.FullscreenDesktop -> do + liftIO $ SDL.setWindowMode window SDL.Windowed + return SDL.Windowed + SDL.Windowed -> do + liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop + return SDL.FullscreenDesktop + x -> do + liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) + return x + return (True, resWindows ++ [aw { awMode = newMode }]) + else + return (stop, resWindows ++ [aw]) + ) + (False, []) + (zip [0..] (drawWindows ad)) + if stop + then do + now <- liftIO $ getTime Monotonic + put ad + { sysTime = now + , drawWindows = alteredWindowList + } + else + liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent)) -- | Fit the GL Viewport to Window size fitViewport diff --git a/extern/flake.lock b/extern/flake.lock new file mode 100644 index 0000000..9e4b0d9 --- /dev/null +++ b/extern/flake.lock @@ -0,0 +1,42 @@ +{ + "nodes": { + "flake-utils": { + "locked": { + "lastModified": 1667395993, + "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1669901374, + "narHash": "sha256-lObvfluyiZ9cgCMgKSrUOjzbx9Oap9949jlnNRPPYqg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1c5443f6cdce419174f198141bd76a3fd9502950", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/extern/flake.nix b/extern/flake.nix new file mode 100644 index 0000000..607ed9b --- /dev/null +++ b/extern/flake.nix @@ -0,0 +1,61 @@ +{ + description = "A game stub written in Haskell"; + + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs"; + flake-utils.url = "github:numtide/flake-utils"; + }; + + outputs = { self, nixpkgs, flake-utils }: + flake-utils.lib.eachDefaultSystem (system: + let + pkgs = nixpkgs.legacyPackages.${system}; + + haskellPackages = pkgs.haskellPackages; + + jailbreakUnbreak = pkg: + pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); + + packageName = "affection"; + in rec { + packages.${packageName} = # (ref:haskell-package-def) + haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" { + # Dependency overrides go here + }; + + defaultPackage = self.packages.${system}.${packageName}; + + apps = { + example00 = { + type = "app"; + program = "${self.packages.${system}.${packageName}}/bin/example00"; + }; + example01 = { + type = "app"; + program = "${self.packages.${system}.${packageName}}/bin/example01"; + }; + example02 = { + type = "app"; + program = "${self.packages.${system}.${packageName}}/bin/example02"; + }; + }; + + #devShell = packages.${packageName}.env; + devShell = pkgs.mkShell { + buildInputs = with haskellPackages; [ + haskell-language-server + ghcid + cabal-install + ]; + nativeBuildInputs = with pkgs; [ + pkg-config + glib + SDL2 + freetype + glew + ]; + inputsFrom = builtins.attrValues self.packages.${system}; + }; + }); +} +