Compare commits

...

31 commits

Author SHA1 Message Date
nek0 d0465fa3e1 small update of flake and project URL 2023-11-24 18:42:15 +01:00
Amedeo Molnár 523265b2dc rework flake to include haskell build inputs 2023-04-20 10:33:18 +02:00
Amedeo Molnár f92949b7f0 make threaded 2023-04-20 10:32:51 +02:00
nek0 1976a6c4c1 add cabal.project 2023-04-20 07:05:50 +02:00
nek0 086eb3e1f2 flake update 2023-04-20 06:47:54 +02:00
nek0 818a1e424c add .envrc 2023-04-20 06:37:05 +02:00
nek0 445b5807e0 ignore result symlink 2023-03-25 21:51:50 +01:00
nek0 f7e7c9dcc8 update 2023-03-25 13:40:07 +01:00
nek0 5bef189c30 get working flake 2022-12-01 19:56:25 +01:00
nek0 efbb9b4c5e remove ballast 2022-12-01 16:34:40 +01:00
nek0 76225dff4b more flakyness 2022-12-01 16:23:43 +01:00
nek0 eda79eb626 fix flake 2022-12-01 15:45:21 +01:00
nek0 04d6905de1 remove ballast 2022-12-01 15:45:07 +01:00
nek0 b56ed86e45 revert 2022-09-14 19:30:22 +02:00
nek0 af0dcc16da fix typo 2022-09-14 19:29:46 +02:00
nek0 81a76d4eb3 flakify 2022-09-14 18:53:44 +02:00
nek0 1b8d754cd6 introduce resourcet 2022-07-10 04:18:22 +02:00
nek0 60d38217c8 hunting warnings and other nasties 2022-07-09 23:26:37 +02:00
nek0 17978b0bd7 deconfuse the haskell language server 2022-07-09 22:16:34 +02:00
nek0 9b7b1c6167 fix unexpected eventlessness 2022-05-13 16:13:12 +02:00
nek0 2696dedbb4 some little updates 2022-05-12 19:07:08 +02:00
nek0 eb3357cfac remove double export 2021-01-11 12:01:24 +01:00
nek0 4a5cc6d0e0 make affection strict 2021-01-03 18:21:12 +01:00
nek0 e81408e54f notes turned obsolete. modular design preferred. 2020-12-07 00:42:33 +01:00
nek0 ccd8b7eeaf more verbose messages from engine on startup 2020-12-05 14:28:57 +01:00
nek0 cd662da0b7 move gl call after context creation 2020-10-16 06:06:39 +02:00
nek0 bca6fd69e1 typo 2020-10-16 06:00:30 +02:00
nek0 2ea955d37d whopsie 2020-10-15 19:45:30 +02:00
nek0 ef1ba1f988 add package 2020-10-15 19:39:32 +02:00
nek0 3332370012 add sync and GL infos 2020-10-15 18:49:04 +02:00
nek0 fc6bfa1ca5 fix state machine 2020-05-04 21:31:42 +02:00
14 changed files with 317 additions and 277 deletions

1
.envrc Normal file
View file

@ -0,0 +1 @@
use flake

2
.gitignore vendored
View file

@ -16,3 +16,5 @@ cabal.project.local*
dist*/ dist*/
report.html report.html
*.bak *.bak
.direnv/
result

View file

@ -16,7 +16,7 @@ homepage: https://github.com/nek0/affection#readme
license: LGPL-3 license: LGPL-3
license-file: LICENSE license-file: LICENSE
author: nek0 author: nek0
maintainer: nek0@chelnok.de maintainer: nek0@nek0.eu
category: Game category: Game
build-type: Simple build-type: Simple
extra-source-files: ChangeLog.md extra-source-files: ChangeLog.md
@ -29,7 +29,7 @@ cabal-version: >=2.0
source-repository head source-repository head
type: git type: git
location: https://github.com/nek0/affection location: https://gitea.nek0.eu/nek0/affection.git
flag verbose flag verbose
description: Enable verbose debug messages description: Enable verbose debug messages
@ -99,10 +99,10 @@ library
-- , UndecidableInstances -- , UndecidableInstances
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -threaded -Wall
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 && < 5 build-depends: base >=4.9 && < 5
, sdl2 ^>= 2.5 , sdl2 >= 2.5
, linear , linear
, text , text
, mtl , mtl
@ -113,9 +113,11 @@ library
, glib , glib
, bytestring , bytestring
, OpenGL , OpenGL
, OpenGLRaw
, stm , stm
, uuid , uuid
, vector , vector
, resourcet
-- This example shows the message system. only makes sense when compiling with -- This example shows the message system. only makes sense when compiling with
-- verbose flag. -- verbose flag.
@ -125,12 +127,11 @@ executable example00
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
if flag(examples) build-depends: base >=4.9 && < 5
build-depends: base >=4.9 && < 5 , affection
, affection , sdl2 >= 2.5
, sdl2 ^>= 2.5 , stm
, stm if !flag(examples)
else
buildable: False buildable: False
-- A small game of life implementation -- A small game of life implementation
@ -141,19 +142,18 @@ executable example01
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
if flag(examples) build-depends: base >=4.9 && < 5
build-depends: base >=4.9 && < 5 , affection
, affection , sdl2 >= 2.5
, sdl2 ^>= 2.5 , stm
, stm , OpenGL
, OpenGL , random
, random , containers
, containers , linear
, linear , matrix
, matrix , nanovg >= 0.6.0.0
, nanovg >= 0.6.0.0 , deepseq
, deepseq if !flag(examples)
else
buildable: False buildable: False
-- Another small game of life implementation -- Another small game of life implementation
@ -164,17 +164,16 @@ executable example02
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
if flag(examples) build-depends: base >=4.9 && < 5
build-depends: base >=4.9 && < 5 , affection
, affection , sdl2 >= 2.5
, sdl2 ^>= 2.5 , stm
, stm , OpenGL
, OpenGL , random
, random , containers
, containers , linear
, linear , matrix
, matrix , nanovg >= 0.6.0.0
, nanovg >= 0.6.0.0 , deepseq
, deepseq if !flag(examples)
else
buildable: False buildable: False

View file

@ -1,4 +1,4 @@
constraints: affection +verbose packages: ./*.cabal
profiling: true
packages: package affection
./. flags: +examples

View file

@ -1,18 +0,0 @@
{ pkgs ? import <nixpkgs> (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).
# ];
}

60
flake.lock Normal file
View file

@ -0,0 +1,60 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1694529238,
"narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1700844339,
"narHash": "sha256-VRlPYk0eRn1ao75hoA99LGehYhxZH5RlkP1YXpVROHM=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "33576fdfce2d11204067d6cfa99a2f990ef2169a",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

54
flake.nix Normal file
View file

@ -0,0 +1,54 @@
{
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 = haskellPackages.shellFor {
packages = p: [ defaultPackage ];
withHoogle = true;
buildInputs = with haskellPackages; [
haskell-language-server
ghcid
cabal-install
] ++ (builtins.attrValues self.packages.${system});
};
});
}

View file

@ -1,9 +0,0 @@
# TODO
Implement following things in approximately this Order:
* Message bus -> DONE
* Console
* GUI
* Framework
* Everything else

126
shell.nix
View file

@ -1,125 +1,7 @@
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }: { pkgs ? import <nixpkgs> {}}:
let let
affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
inherit (nixpkgs) pkgs; gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
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, 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 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 {});
in in
affection.env
if pkgs.lib.inNixShell then drv.env else drv

View file

@ -1,6 +1,5 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE Strict #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
@ -17,10 +16,22 @@ import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL 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 Data.String (fromString)
import System.Clock import System.Clock
import Control.Monad.Loops import Control.Monad.Loops
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
-- internal imports
import Affection.Types as A import Affection.Types as A
import Affection.Class as A import Affection.Class as A
@ -31,50 +42,88 @@ import Affection.Subsystems as A
import Affection.Logging as A import Affection.Logging as A
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- | Main function which bootstraps everything else. -- | Main function which bootstraps everything else.
withAffection withAffection
:: forall us. (Affectionate us) :: forall us. (Affectionate us)
=> AffectionConfig us -- ^ Configuration of the Game and its engine. => AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO () -> IO ()
withAffection AffectionConfig{..} = do withAffection AffectionConfig{..} = runResourceT $ do
liftIO $ logIO Debug "Affection starting" liftIO $ logIO Debug "Affection starting"
liftIO $ logIO Debug "Initializing SDL" liftIO $ logIO Debug "Initializing SDL"
-- intialiaze SDL -- intialiaze SDL
case initComponents of case initComponents of
All -> All ->
SDL.initializeAll SDL.initializeAll
Only is -> Only is ->
SDL.initialize is SDL.initialize is
-- give SDL render quality -- give SDL render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- just checking… -- just checking…
do renderQuality <- SDL.get SDL.HintRenderScaleQuality
renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $
when (renderQuality /= SDL.ScaleLinear) $ liftIO $ logIO Warn "Linear texture filtering not enabled!"
logIO Warn "Linear texture filtering not enabled!" void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
-- construct window -- construct window
liftIO $ logIO Debug "Creating Window(s)" liftIO $ logIO Debug "Creating Window(s)"
windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$> windows <-
mapM mapM
(\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc)) (\(_, sdlWindowConfig, mode) -> do
windowConfigs <*> (windowKey, window) <-
pure (map (\(_,_,z) -> z) windowConfigs) allocate
(SDL.createWindow windowTitle sdlWindowConfig)
(\window -> do
logIO Debug "Destroying Window"
SDL.destroyWindow window
)
return $ AffectionWindow window windowKey mode
)
windowConfigs
mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows -- Show windows
_ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 mapM_ (SDL.showWindow . awWindow) windows
contexts <- zip (map (\(x,_,_) -> x) windows) <$>
mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows -- set modes of windows
mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) 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
-- sync updates with monitor
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
liftIO $ logIO Debug "Getting Time"
-- print current used GL Version
version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
liftIO $ print (B.pack version)
-- get current time -- get current time
execTime <- getTime Monotonic liftIO $ logIO Debug "Getting Time"
execTime <- liftIO $ getTime Monotonic
liftIO $ logIO Debug "Loading initial data container" liftIO $ logIO Debug "Loading initial data container"
-- construct game data object from provided Affectionate instance -- construct game data object from provided Affectionate instance
gameData <- loadState @us (gameDataKey, gameData) <-
allocate
(liftIO $ loadState @us)
(liftIO . cleanUp)
-- build state container -- build state container
let initContainer = AffectionData let initContainer = AffectionData
{ drawWindows = windows { drawWindows = windows
@ -84,41 +133,53 @@ withAffection AffectionConfig{..} = do
, sysTime = execTime , sysTime = execTime
, pausedTime = False , pausedTime = False
} }
-- initialize and run state -- initialize and run state
(_, _) <- runStateT void $ liftIO $ runAffection initContainer
(A.runState
(do (do
liftIO $ logIO Debug "Starting Loop" liftIO $ logIO Debug "Running Pre-Loop stage"
-- run preLoop function from Affectionate -- run preLoop function from Affectionate
preLoop gameData preLoop gameData
liftIO $ logIO Debug "Starting Loop"
whileM_ (hasNextStep gameData) whileM_ (hasNextStep gameData)
(do (do
-- get state -- get state
ad <- get ad <- get
-- Measure time difference form last run -- Measure time difference form last run
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic
let lastTime = sysTime ad let lastTime = sysTime ad
-- compute dt and update elapsedTime -- compute dt and update elapsedTime
let !dt = fromIntegral let dt = fromIntegral
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
!ne = elapsedTime ad + dt ne = elapsedTime ad + dt
-- update state data object with new time values -- update state data object with new time values
put $ ad put $ ad
{ elapsedTime = ne { elapsedTime = ne
, deltaTime = dt , deltaTime = dt
} }
-- poll events -- poll events
liftIO SDL.pumpEvents
evs <- preHandleEvents =<< liftIO SDL.pollEvents evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- handle events -- handle events
handleEvents gameData evs handleEvents gameData evs
-- execute user defined update loop -- execute user defined update loop
unless (pausedTime ad) (update gameData dt) unless (pausedTime ad) (update gameData dt)
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
draw gameData draw gameData
liftIO GL.flush liftIO GL.flush
-- actual displaying of newly drawn frame -- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows mapM_ (SDL.glSwapWindow . awWindow) windows
-- save new time -- save new time
ad3 <- get ad3 <- get
when (sysTime ad == sysTime ad3) ( when (sysTime ad == sysTime ad3) (
@ -128,11 +189,16 @@ withAffection AffectionConfig{..} = do
) )
) )
) )
) initContainer -- Cleanup works
liftIO $ logIO Debug "Loop ended. Cleaning" liftIO $ logIO Debug "Loop ended. Cleaning"
cleanUp gameData release gameDataKey
liftIO $ logIO Debug "Destroying Window" -- mapM_ (SDL.glDeleteContext . snd) contexts
mapM_ (SDL.glDeleteContext . snd) contexts -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
-- SDL.quit -- <- This causes segfaults depending on hardware -- SDL.quit -- <- This causes segfaults depending on hardware
liftIO $ logIO Debug "This is the end" 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

View file

@ -1,9 +1,6 @@
module Affection.MessageBus module Affection.MessageBus
( module M ( module M
, module Msg
) where ) where
import Affection.MessageBus.Class as M import Affection.MessageBus.Class as M
import Affection.MessageBus.Message as M import Affection.MessageBus.Message as M
import Affection.MessageBus.Message as Msg

View file

@ -7,14 +7,14 @@ import Affection.Types
import qualified SDL import qualified SDL
-- | Typeclass for simple scaffolding of a state machine -- | Typeclass for simple scaffolding of a state machine
class StateMachine a where class StateMachine us a where
-- | State load routine -- | State load routine
smLoad :: a -> Affection () smLoad :: a -> us -> Affection ()
-- | state update routine -- | state update routine
smUpdate :: a -> Double -> Affection () smUpdate :: a -> us -> Double -> Affection ()
-- | State event handler routine -- | State event handler routine
smEvent :: a -> [SDL.EventPayload] -> Affection () smEvent :: a -> us -> [SDL.EventPayload] -> Affection ()
-- | State draw routine -- | State draw routine
smDraw :: a -> Affection () smDraw :: a -> us -> Affection ()
-- | State clean routine -- | State clean routine
smClean :: a -> Affection () smClean :: a -> us -> Affection ()

View file

@ -5,6 +5,8 @@ module Affection.Types
, AffectionData(..) , AffectionData(..)
, AffectionStateInner , AffectionStateInner
, AffectionState(..) , AffectionState(..)
, AffectionWindow(..)
, AffectionContext(..)
, InitComponents(..) , InitComponents(..)
, Angle , Angle
-- | SDL reexports -- | SDL reexports
@ -23,6 +25,7 @@ import qualified Data.Text as T
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
import qualified Control.Monad.Parallel as MP import qualified Control.Monad.Parallel as MP
import System.Clock (TimeSpec) import System.Clock (TimeSpec)
@ -50,35 +53,35 @@ data InitComponents
-- | Main type for defining the look, feel and action of the whole application. -- | Main type for defining the look, feel and action of the whole application.
data AffectionData = AffectionData data AffectionData = AffectionData
{ drawWindows :: { drawWindows :: [ AffectionWindow ] -- ^ SDL windows
[ , glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts
( Word -- --^ Window identifier , elapsedTime :: Double -- ^ Elapsed time in seconds
, SDL.Window -- --^ Window linked with identifier , deltaTime :: Double -- ^ Elapsed time in seconds since last tick
, SDL.WindowMode -- -- ^ current screen mode , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
) , pausedTime :: Bool -- ^ Should the update loop be executed?
] -- ^ 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?
} }
-- | Inner 'StateT' monad for the update state -- | 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 -- | Affection's state monad
newtype AffectionState sd m a = AffectionState newtype AffectionState sd m a = AffectionState
{ runState :: AffectionStateInner sd m a } { 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) 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 type Angle = Double
data AffectionWindow = AffectionWindow
{ awWindow :: SDL.Window
, awReleaseKey :: ReleaseKey
, awMode :: SDL.WindowMode
}
data AffectionContext = AffectionContext
{ acContext :: SDL.GLContext
, acReleaseKey :: ReleaseKey
}

View file

@ -39,32 +39,35 @@ getDelta = gets deltaTime
toggleScreen :: Word -> Affection () toggleScreen :: Word -> Affection ()
toggleScreen windowIdent = do toggleScreen windowIdent = do
ad <- get ad <- get
let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad) (stop, alteredWindowList) <- foldM
case mwindow of (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
Just (ident, window, mode) -> do if stop || num == windowIdent
newMode <- case mode of then do
SDL.FullscreenDesktop -> do newMode <- case mode of
SDL.setWindowMode window SDL.Windowed SDL.FullscreenDesktop -> do
return SDL.Windowed liftIO $ SDL.setWindowMode window SDL.Windowed
SDL.Windowed -> do return SDL.Windowed
SDL.setWindowMode window SDL.FullscreenDesktop SDL.Windowed -> do
return SDL.FullscreenDesktop liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
x -> do return SDL.FullscreenDesktop
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) x -> do
return x liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
now <- liftIO $ getTime Monotonic return x
put ad return (True, resWindows ++ [aw { awMode = newMode }])
{ sysTime = now else
, drawWindows = map return (stop, resWindows ++ [aw])
(\e@(lid, win, _) -> )
if lid == ident (False, [])
then (lid, win, newMode) (zip [0..] (drawWindows ad))
else e if stop
) then do
(drawWindows ad) now <- liftIO $ getTime Monotonic
} put ad
Nothing -> do { sysTime = now
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent)) , drawWindows = alteredWindowList
}
else
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
-- | Fit the GL Viewport to Window size -- | Fit the GL Viewport to Window size
fitViewport fitViewport