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*/
report.html
*.bak
.direnv/
result

View file

@ -16,7 +16,7 @@ homepage: https://github.com/nek0/affection#readme
license: LGPL-3
license-file: LICENSE
author: nek0
maintainer: nek0@chelnok.de
maintainer: nek0@nek0.eu
category: Game
build-type: Simple
extra-source-files: ChangeLog.md
@ -29,7 +29,7 @@ cabal-version: >=2.0
source-repository head
type: git
location: https://github.com/nek0/affection
location: https://gitea.nek0.eu/nek0/affection.git
flag verbose
description: Enable verbose debug messages
@ -99,10 +99,10 @@ library
-- , UndecidableInstances
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
ghc-options: -threaded -Wall
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && < 5
, sdl2 ^>= 2.5
, sdl2 >= 2.5
, linear
, text
, mtl
@ -113,9 +113,11 @@ library
, glib
, bytestring
, OpenGL
, OpenGLRaw
, stm
, uuid
, vector
, resourcet
-- This example shows the message system. only makes sense when compiling with
-- verbose flag.
@ -125,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
@ -141,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
@ -164,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

View file

@ -1,4 +1,4 @@
constraints: affection +verbose
profiling: true
packages:
./.
packages: ./*.cabal
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
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, 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 {});
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

View file

@ -1,6 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
@ -17,10 +16,22 @@ 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 Data.String (fromString)
import System.Clock
import Control.Monad.Loops
import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
-- internal imports
import Affection.Types as A
import Affection.Class as A
@ -31,50 +42,88 @@ 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)
=> 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
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
-- 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
-- sync updates with monitor
-- 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
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
@ -84,41 +133,53 @@ withAffection AffectionConfig{..} = do
, sysTime = execTime
, pausedTime = False
}
-- initialize and run state
(_, _) <- runStateT
(A.runState
void $ liftIO $ runAffection initContainer
(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
ad <- get
-- Measure time difference form last run
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
, 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) (
@ -128,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

View file

@ -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

View file

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

View file

@ -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
}

View file

@ -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