From 33323700123f2e8a571cb5beeb5c5d91fcdffd5d Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 15 Oct 2020 18:49:04 +0200 Subject: [PATCH 01/22] add sync and GL infos --- src/Affection.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/src/Affection.hs b/src/Affection.hs index 2b1f908..48ea606 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -17,11 +17,21 @@ import qualified SDL import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Enum as SDL +import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) +import qualified Graphics.GL as GLRaw + +import Foreign.Marshal.Array + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 + import System.Clock import Control.Monad.Loops import Control.Monad.State.Strict +-- internal imports + import Affection.Types as A import Affection.Class as A import Affection.StateMachine as A @@ -31,9 +41,6 @@ import Affection.Subsystems as A import Affection.Logging as A -import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) - - -- | Main function which bootstraps everything else. withAffection :: forall us. (Affectionate us) @@ -50,6 +57,8 @@ withAffection AffectionConfig{..} = do SDL.initialize is -- give SDL render quality SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear + -- sync updates with monitor + SDL.swapInterval $= SDL.SynchronizedUpdates -- just checking… do renderQuality <- SDL.get SDL.HintRenderScaleQuality @@ -70,6 +79,9 @@ withAffection AffectionConfig{..} = do mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows liftIO $ logIO Debug "Getting Time" + -- print current used GL Version + version <- peerArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION + print (B.pack version) -- get current time execTime <- getTime Monotonic liftIO $ logIO Debug "Loading initial data container" From ef1ba1f988c16e38ec8e416c86d6ff117c724816 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 15 Oct 2020 19:39:32 +0200 Subject: [PATCH 02/22] add package --- affection.cabal | 1 + shell.nix | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/affection.cabal b/affection.cabal index 4a324e3..51d79a4 100644 --- a/affection.cabal +++ b/affection.cabal @@ -113,6 +113,7 @@ library , glib , bytestring , OpenGL + , OpenGLRAW , stm , uuid , vector diff --git a/shell.nix b/shell.nix index 6d4b133..9451c76 100644 --- a/shell.nix +++ b/shell.nix @@ -91,7 +91,7 @@ let f = { mkDerivation, base, bytestring, clock, containers, deepseq , linear, matrix, monad-loops, monad-parallel, mtl - , OpenGL, random, stdenv, stm, text, uuid, vector + , OpenGL, OpenGLRaw, random, stdenv, stm, text, uuid, vector }: mkDerivation { pname = "affection"; @@ -102,7 +102,7 @@ let isExecutable = true; libraryHaskellDepends = [ base bytestring clock containers glib linear monad-loops - monad-parallel mtl OpenGL sdl2 stm text uuid vector + monad-parallel mtl OpenGL OpenGLRaw sdl2 stm text uuid vector ]; executableHaskellDepends = [ base containers deepseq linear matrix nanovg OpenGL random sdl2 stm From 2ea955d37d6ffc764269acac4668d60a488ddbcc Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 15 Oct 2020 19:45:30 +0200 Subject: [PATCH 03/22] whopsie --- affection.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/affection.cabal b/affection.cabal index 51d79a4..7c16fc5 100644 --- a/affection.cabal +++ b/affection.cabal @@ -113,7 +113,7 @@ library , glib , bytestring , OpenGL - , OpenGLRAW + , OpenGLRaw , stm , uuid , vector From bca6fd69e112f85cebfb7a5265c54e995355e25d Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 16 Oct 2020 06:00:30 +0200 Subject: [PATCH 04/22] typo --- src/Affection.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Affection.hs b/src/Affection.hs index 48ea606..e3de186 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -80,7 +80,7 @@ withAffection AffectionConfig{..} = do -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows liftIO $ logIO Debug "Getting Time" -- print current used GL Version - version <- peerArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION + version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION print (B.pack version) -- get current time execTime <- getTime Monotonic From cd662da0b7dd9719ee681f058f03453cd2e2ee68 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 16 Oct 2020 06:06:39 +0200 Subject: [PATCH 05/22] move gl call after context creation --- src/Affection.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Affection.hs b/src/Affection.hs index e3de186..6d48afc 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -57,8 +57,6 @@ withAffection AffectionConfig{..} = do SDL.initialize is -- give SDL render quality SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear - -- sync updates with monitor - SDL.swapInterval $= SDL.SynchronizedUpdates -- just checking… do renderQuality <- SDL.get SDL.HintRenderScaleQuality @@ -77,6 +75,7 @@ withAffection AffectionConfig{..} = do 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 From ccd8b7eeaf067ac277c5e02c20f5d9ab35497744 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 5 Dec 2020 14:28:57 +0100 Subject: [PATCH 06/22] more verbose messages from engine on startup --- src/Affection.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Affection.hs b/src/Affection.hs index 6d48afc..6373bea 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -99,9 +99,10 @@ withAffection AffectionConfig{..} = do (_, _) <- runStateT (A.runState (do - liftIO $ logIO Debug "Starting Loop" + liftIO $ logIO Debug "Running Pre-Loop stage" -- run preLoop function from Affectionate preLoop gameData + liftIO $ logIO Debug "Starting Loop" whileM_ (hasNextStep gameData) (do -- get state From e81408e54fb623c11f2b1c59ebd7dd6aaf5d09ff Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 7 Dec 2020 00:42:33 +0100 Subject: [PATCH 07/22] notes turned obsolete. modular design preferred. --- notes/TODO.md | 9 --------- 1 file changed, 9 deletions(-) delete mode 100644 notes/TODO.md diff --git a/notes/TODO.md b/notes/TODO.md deleted file mode 100644 index 6a15c72..0000000 --- a/notes/TODO.md +++ /dev/null @@ -1,9 +0,0 @@ -# TODO - -Implement following things in approximately this Order: - -* Message bus -> DONE -* Console -* GUI -* Framework -* Everything else From 4a5cc6d0e0fad0d900e97c7fbb9675b4e9127549 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 3 Jan 2021 18:21:12 +0100 Subject: [PATCH 08/22] make affection strict --- src/Affection.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Affection.hs b/src/Affection.hs index 6373bea..64e8d29 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Strict #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} @@ -111,9 +111,9 @@ withAffection AffectionConfig{..} = do now <- liftIO $ getTime Monotonic let lastTime = sysTime ad -- compute dt and update elapsedTime - let !dt = fromIntegral + let dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) - !ne = elapsedTime ad + dt + ne = elapsedTime ad + dt -- update state data object with new time values put $ ad { elapsedTime = ne From eb3357cfacf0965cfd5f4dbb447f5afb16c70895 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 11 Jan 2021 12:01:24 +0100 Subject: [PATCH 09/22] remove double export --- src/Affection/MessageBus.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs index 6ae83e4..86a1ca1 100644 --- a/src/Affection/MessageBus.hs +++ b/src/Affection/MessageBus.hs @@ -1,9 +1,6 @@ module Affection.MessageBus ( module M - , module Msg ) where import Affection.MessageBus.Class as M import Affection.MessageBus.Message as M - -import Affection.MessageBus.Message as Msg From 2696dedbb4d98f939e05e9d5050d4392a0c16c73 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 12 May 2022 19:07:08 +0200 Subject: [PATCH 10/22] some little updates --- .gitignore | 2 + default.nix | 18 -------- shell.nix | 126 ++-------------------------------------------------- 3 files changed, 6 insertions(+), 140 deletions(-) delete mode 100644 default.nix diff --git a/.gitignore b/.gitignore index fa507cf..237cc52 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,5 @@ cabal.project.local* dist*/ report.html *.bak +.direnv/ +.envrc diff --git a/default.nix b/default.nix deleted file mode 100644 index 225fc5f..0000000 --- a/default.nix +++ /dev/null @@ -1,18 +0,0 @@ -{ pkgs ? import (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz)) -, haskellCompiler ? "ghc865" -}: - pkgs.haskell-nix.cabalProject { - src = pkgs.haskell-nix.haskellLib.cleanGit { src = pkgs.nix-gitignore.gitignoreSource [] ./.; }; - ghc = pkgs.buildPackages.pkgs.haskell-nix.compiler.${haskellCompiler}; - # pkg-def-extras = [ - # # Additional packages ontop of all those listed in `cabal.project` - # ]; - # modules = [ - # # Specific package overrides would go here for example: - # packages.cbors.package.ghcOptions = "-Werror"; - # packages.cbors.patches = [ ./one.patch ]; - # packages.cbors.flags.optimize-gmp = false; - # # It may be better to set flags in `cabal.project` instead - # # (`plan-to-nix` will include them as defaults). - # ]; - } diff --git a/shell.nix b/shell.nix index 9451c76..a4f6bdd 100644 --- a/shell.nix +++ b/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 From 9b7b1c6167b4fa516b91759ca86139ede07f231d Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 13 May 2022 16:13:12 +0200 Subject: [PATCH 11/22] fix unexpected eventlessness --- src/Affection.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Affection.hs b/src/Affection.hs index 64e8d29..e61cc93 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -120,6 +120,7 @@ withAffection AffectionConfig{..} = do , deltaTime = dt } -- poll events + liftIO SDL.pumpEvents evs <- preHandleEvents =<< liftIO SDL.pollEvents -- handle events handleEvents gameData evs From 17978b0bd75098aabe3e789b1b013b275818a430 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 9 Jul 2022 22:16:34 +0200 Subject: [PATCH 12/22] deconfuse the haskell language server --- hie.yaml | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 hie.yaml diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..04cd243 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: From 60d38217c8430ff106811d09351be66565a7a019 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 9 Jul 2022 23:26:37 +0200 Subject: [PATCH 13/22] hunting warnings and other nasties --- affection.cabal | 8 ++++---- src/Affection.hs | 8 +++++--- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/affection.cabal b/affection.cabal index 7c16fc5..1cec0ee 100644 --- a/affection.cabal +++ b/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 @@ -129,7 +129,7 @@ executable example00 if flag(examples) build-depends: base >=4.9 && < 5 , affection - , sdl2 ^>= 2.5 + , sdl2 >= 2.5 , stm else buildable: False @@ -145,7 +145,7 @@ executable example01 if flag(examples) build-depends: base >=4.9 && < 5 , affection - , sdl2 ^>= 2.5 + , sdl2 >= 2.5 , stm , OpenGL , random @@ -168,7 +168,7 @@ executable example02 if flag(examples) build-depends: base >=4.9 && < 5 , affection - , sdl2 ^>= 2.5 + , sdl2 >= 2.5 , stm , OpenGL , random diff --git a/src/Affection.hs b/src/Affection.hs index e61cc93..4a62193 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -23,7 +23,8 @@ 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 @@ -62,11 +63,12 @@ withAffection AffectionConfig{..} = do renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $ 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) <$> mapM - (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc)) + (SDL.createWindow windowTitle . (\(_,y,_) -> y)) windowConfigs <*> pure (map (\(_,_,z) -> z) windowConfigs) @@ -74,7 +76,7 @@ withAffection AffectionConfig{..} = do _ <- 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 + mapM_ (\w -> SDL.setWindowMode ((\(_,y,_) -> y) w) ((\(_,_,z) -> z) w)) windows -- sync updates with monitor -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows liftIO $ logIO Debug "Getting Time" From 1b8d754cd64f3a3b94dbf41a04a30b456a75230e Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 10 Jul 2022 04:18:22 +0200 Subject: [PATCH 14/22] introduce resourcet --- affection.cabal | 1 + cabal.project | 2 +- src/Affection.hs | 107 ++++++++++++++++++++++++++++++----------- src/Affection/Types.hs | 43 +++++++++-------- src/Affection/Util.hs | 55 +++++++++++---------- 5 files changed, 133 insertions(+), 75 deletions(-) diff --git a/affection.cabal b/affection.cabal index 1cec0ee..c5772cf 100644 --- a/affection.cabal +++ b/affection.cabal @@ -117,6 +117,7 @@ library , stm , uuid , vector + , resourcet -- This example shows the message system. only makes sense when compiling with -- verbose flag. diff --git a/cabal.project b/cabal.project index aac861d..7659ea4 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -constraints: affection +verbose +constraints: affection +verbose +examples profiling: true packages: ./. diff --git a/src/Affection.hs b/src/Affection.hs index 4a62193..e99f1e9 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} @@ -30,6 +29,7 @@ import System.Clock import Control.Monad.Loops import Control.Monad.State.Strict +import Control.Monad.Trans.Resource -- internal imports @@ -47,47 +47,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 - (SDL.createWindow windowTitle . (\(_,y,_) -> y)) - 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 -> SDL.setWindowMode ((\(_,y,_) -> y) w) ((\(_,_,z) -> z) 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 @@ -97,11 +133,12 @@ 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 preLoop gameData liftIO $ logIO Debug "Starting Loop" @@ -109,31 +146,40 @@ 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)) ne = elapsedTime ad + dt + -- update state data object with new time values put $ ad { 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) ( @@ -143,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/src/Affection/Types.hs b/src/Affection/Types.hs index a7d8eb4..e4fd82a 100644 --- a/src/Affection/Types.hs +++ b/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/src/Affection/Util.hs b/src/Affection/Util.hs index 763f0ee..465620c 100644 --- a/src/Affection/Util.hs +++ b/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 From 81a76d4eb34eaadee3585a2a1476db785858896c Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 14 Sep 2022 18:53:44 +0200 Subject: [PATCH 15/22] flakify --- flake.lock | 42 ++++++++++++++++++++++++++++++++++++++++++ flake.nix | 38 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+) create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..dd54bea --- /dev/null +++ b/flake.lock @@ -0,0 +1,42 @@ +{ + "nodes": { + "flake-utils": { + "locked": { + "lastModified": 1659877975, + "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1663173135, + "narHash": "sha256-QL4JZYUlbt0ex78w30XJ0h9idUMj0DBxppyDsoxEPjE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "5d1ddac9493642d7311a064351e643de9a0e24ee", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..8031d0d --- /dev/null +++ b/flake.nix @@ -0,0 +1,38 @@ +{ + 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 { + packages.${packageName} = # (ref:haskell-package-def) + haskellPackages.callCabal2nix packageName self rec { + # Dependency overrides go here + }; + + defaultPackage = self.packages.${system}.${packageName}; + + devShell = pkgs.mkShell { + buildInputs = with haskellPackages; [ + haskell-language-server + ghcid + cabal-install + ]; + inputsFrom = builtins.attrValues self.packages.${system}; + }; + }); +} + From af0dcc16da89d55122348edf6e0b89d13199bec6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 14 Sep 2022 19:29:46 +0200 Subject: [PATCH 16/22] fix typo --- flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/flake.nix b/flake.nix index 8031d0d..e586335 100644 --- a/flake.nix +++ b/flake.nix @@ -11,7 +11,7 @@ let pkgs = nixpkgs.legacyPackages.${system}; - haskellPackages = pkgs.haskellPackages; + haskellPackages = nixpkgs.haskellPackages; jailbreakUnbreak = pkg: pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); From b56ed86e45b2a8cdf811f2659644192a69ab5818 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 14 Sep 2022 19:30:22 +0200 Subject: [PATCH 17/22] revert --- flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/flake.nix b/flake.nix index e586335..8031d0d 100644 --- a/flake.nix +++ b/flake.nix @@ -11,7 +11,7 @@ let pkgs = nixpkgs.legacyPackages.${system}; - haskellPackages = nixpkgs.haskellPackages; + haskellPackages = pkgs.haskellPackages; jailbreakUnbreak = pkg: pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); From 04d6905de10d95adc228f401e9f809ff295676fd Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 1 Dec 2022 15:45:07 +0100 Subject: [PATCH 18/22] remove ballast --- cabal.project | 4 ---- 1 file changed, 4 deletions(-) delete mode 100644 cabal.project diff --git a/cabal.project b/cabal.project deleted file mode 100644 index 7659ea4..0000000 --- a/cabal.project +++ /dev/null @@ -1,4 +0,0 @@ -constraints: affection +verbose +examples -profiling: true -packages: - ./. From eda79eb626ae0a0035aa63da96d754b3058ca132 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 1 Dec 2022 15:45:21 +0100 Subject: [PATCH 19/22] fix flake --- flake.lock | 12 ++++++------ flake.nix | 7 +++++++ 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/flake.lock b/flake.lock index dd54bea..9e4b0d9 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,11 @@ "nodes": { "flake-utils": { "locked": { - "lastModified": 1659877975, - "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", + "lastModified": 1667395993, + "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", "owner": "numtide", "repo": "flake-utils", - "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", + "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", "type": "github" }, "original": { @@ -17,11 +17,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1663173135, - "narHash": "sha256-QL4JZYUlbt0ex78w30XJ0h9idUMj0DBxppyDsoxEPjE=", + "lastModified": 1669901374, + "narHash": "sha256-lObvfluyiZ9cgCMgKSrUOjzbx9Oap9949jlnNRPPYqg=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "5d1ddac9493642d7311a064351e643de9a0e24ee", + "rev": "1c5443f6cdce419174f198141bd76a3fd9502950", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 8031d0d..4ddf406 100644 --- a/flake.nix +++ b/flake.nix @@ -31,6 +31,13 @@ ghcid cabal-install ]; + nativeBuildInputs = with pkgs; [ + pkg-config + glib + SDL2 + freetype + glew + ]; inputsFrom = builtins.attrValues self.packages.${system}; }; }); From 76225dff4b38d6b4ab8248e75064e553d4c90b93 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 1 Dec 2022 16:23:43 +0100 Subject: [PATCH 20/22] more flakyness --- flake.nix | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/flake.nix b/flake.nix index 4ddf406..9f3818b 100644 --- a/flake.nix +++ b/flake.nix @@ -17,29 +17,30 @@ pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); packageName = "affection"; - in { + in rec { packages.${packageName} = # (ref:haskell-package-def) - haskellPackages.callCabal2nix packageName self rec { + haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" rec { # Dependency overrides go here }; defaultPackage = self.packages.${system}.${packageName}; - 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}; - }; + devShell = defaultPackage.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}; + #}; }); } From efbb9b4c5e3bc056bb4a6ca0147dca38b6f4b513 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 1 Dec 2022 16:34:40 +0100 Subject: [PATCH 21/22] remove ballast --- hie.yaml | 2 -- 1 file changed, 2 deletions(-) delete mode 100644 hie.yaml diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index 04cd243..0000000 --- a/hie.yaml +++ /dev/null @@ -1,2 +0,0 @@ -cradle: - cabal: From 5bef189c308df9dda1449a8305a7092fb5c77827 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 1 Dec 2022 19:56:25 +0100 Subject: [PATCH 22/22] get working flake --- affection.cabal | 61 +++++++++++++++++++++++-------------------------- flake.nix | 49 +++++++++++++++++++++++++-------------- 2 files changed, 61 insertions(+), 49 deletions(-) diff --git a/affection.cabal b/affection.cabal index c5772cf..a8f90b6 100644 --- a/affection.cabal +++ b/affection.cabal @@ -127,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 @@ -143,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 @@ -166,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/flake.nix b/flake.nix index 9f3818b..607ed9b 100644 --- a/flake.nix +++ b/flake.nix @@ -19,28 +19,43 @@ packageName = "affection"; in rec { packages.${packageName} = # (ref:haskell-package-def) - haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" rec { + haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" { # Dependency overrides go here }; defaultPackage = self.packages.${system}.${packageName}; - devShell = defaultPackage.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}; - #}; + 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}; + }; }); }