nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Compare commits

base: nek0:master
Branches Tags
nek0:master
nek0:resourcetify
nek0:affectionate_class
nek0:multiwindow
..
compare: nek0:affectionate_class
Branches Tags
nek0:master
nek0:resourcetify
nek0:affectionate_class
nek0:multiwindow

No commits in common. "master" and "affectionate_class" have entirely different histories.
master ... affectiona

14 changed files with 277 additions and 317 deletions
Show stats Expand all files Collapse all files

1
.envrc
View file

@ -1 +0,0 @@
use flake

2
.gitignore vendored
View file

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

71
affection.cabal
View file

@ -16,7 +16,7 @@ homepage: https://github.com/nek0/affection#readme
license: LGPL-3
license-file: LICENSE
author: nek0
maintainer: nek0@nek0.eu
maintainer: nek0@chelnok.de
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://gitea.nek0.eu/nek0/affection.git
location: https://github.com/nek0/affection
flag verbose
description: Enable verbose debug messages
@ -99,10 +99,10 @@ library
-- , UndecidableInstances
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -threaded -Wall
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
@ -113,11 +113,9 @@ library
, glib
, bytestring
, OpenGL
, OpenGLRaw
, stm
, uuid
, vector
, resourcet
-- This example shows the message system. only makes sense when compiling with
-- verbose flag.
@ -127,11 +125,12 @@ executable example00
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
build-depends: base >=4.9 && < 5
, affection
, sdl2 >= 2.5
, stm
if !flag(examples)
if flag(examples)
build-depends: base >=4.9 && < 5
, affection
, sdl2 ^>= 2.5
, stm
else
buildable: False
-- A small game of life implementation
@ -142,18 +141,19 @@ executable example01
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
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)
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
buildable: False
-- Another small game of life implementation
@ -164,16 +164,17 @@ executable example02
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
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)
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
buildable: False

8
cabal.project
View file

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

18
default.nix Normal file
View file

@ -0,0 +1,18 @@
{ 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
View file

@ -1,60 +0,0 @@
{
"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
View file

@ -1,54 +0,0 @@
{
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});
};
});
}

9
notes/TODO.md Normal file
View file

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

126
shell.nix
View file

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

132
src/Affection.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
@ -16,22 +17,10 @@ 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
@ -42,88 +31,50 @@ 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{..} = runResourceT $ do
withAffection AffectionConfig{..} = 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…
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)))
do
renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $
logIO Warn "Linear texture filtering not enabled!"
-- construct window
liftIO $ logIO Debug "Creating Window(s)"
windows <-
windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
mapM
(\(_, 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
(\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
windowConfigs <*>
pure (map (\(_,_,z) -> z) 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
-- sync updates with monitor
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
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
-- print current used GL Version
version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
liftIO $ print (B.pack version)
-- get current time
liftIO $ logIO Debug "Getting Time"
execTime <- liftIO $ getTime Monotonic
-- get current time
execTime <- getTime Monotonic
liftIO $ logIO Debug "Loading initial data container"
-- construct game data object from provided Affectionate instance
(gameDataKey, gameData) <-
allocate
(liftIO $ loadState @us)
(liftIO . cleanUp)
gameData <- loadState @us
-- build state container
let initContainer = AffectionData
{ drawWindows = windows
@ -133,53 +84,41 @@ withAffection AffectionConfig{..} = runResourceT $ do
, sysTime = execTime
, pausedTime = False
}
-- initialize and run state
void $ liftIO $ runAffection initContainer
(_, _) <- runStateT
(A.runState
(do
liftIO $ logIO Debug "Running Pre-Loop stage"
liftIO $ logIO Debug "Starting Loop"
-- 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 . awWindow) windows
mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
-- save new time
ad3 <- get
when (sysTime ad == sysTime ad3) (
@ -189,16 +128,11 @@ withAffection AffectionConfig{..} = runResourceT $ do
)
)
)
-- Cleanup works
) initContainer
liftIO $ logIO Debug "Loop ended. Cleaning"
release gameDataKey
-- mapM_ (SDL.glDeleteContext . snd) contexts
-- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
cleanUp gameData
liftIO $ logIO Debug "Destroying Window"
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

3
src/Affection/MessageBus.hs
View file

@ -1,6 +1,9 @@
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

12
src/Affection/StateMachine.hs
View file

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

43
src/Affection/Types.hs
View file

@ -5,8 +5,6 @@ module Affection.Types
, AffectionData(..)
, AffectionStateInner
, AffectionState(..)
, AffectionWindow(..)
, AffectionContext(..)
, InitComponents(..)
, Angle
-- | SDL reexports
@ -25,7 +23,6 @@ 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)
@ -53,35 +50,35 @@ data InitComponents
-- | Main type for defining the look, feel and action of the whole application.
data AffectionData = AffectionData
{ 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?
{ 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?
}
-- | Inner 'StateT' monad for the update state
type AffectionStateInner sd m = StateT sd m
type AffectionStateInner sd a = StateT sd a
-- | Affection's state monad
newtype AffectionState sd m a = AffectionState
{ runState :: AffectionStateInner sd m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
type Affection a = AffectionState AffectionData ResIO a
type Affection a = AffectionState AffectionData IO a
type Angle = Double
data AffectionWindow = AffectionWindow
{ awWindow :: SDL.Window
, awReleaseKey :: ReleaseKey
, awMode :: SDL.WindowMode
}
data AffectionContext = AffectionContext
{ acContext :: SDL.GLContext
, acReleaseKey :: ReleaseKey
}

55
src/Affection/Util.hs
View file

@ -39,35 +39,32 @@ getDelta = gets deltaTime
toggleScreen :: Word -> Affection ()
toggleScreen windowIdent = do
ad <- get
(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))
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))
-- | Fit the GL Viewport to Window size
fitViewport