Compare commits

..

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

14 changed files with 277 additions and 317 deletions

1
.envrc
View file

@ -1 +0,0 @@
use flake

2
.gitignore vendored
View file

@ -16,5 +16,3 @@ 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@nek0.eu maintainer: nek0@chelnok.de
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://gitea.nek0.eu/nek0/affection.git location: https://github.com/nek0/affection
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: -threaded -Wall ghc-options: -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,11 +113,9 @@ 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.
@ -127,11 +125,12 @@ executable example00
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.9 && < 5 if flag(examples)
, affection build-depends: base >=4.9 && < 5
, sdl2 >= 2.5 , affection
, stm , sdl2 ^>= 2.5
if !flag(examples) , stm
else
buildable: False buildable: False
-- A small game of life implementation -- A small game of life implementation
@ -142,18 +141,19 @@ executable example01
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.9 && < 5 if flag(examples)
, affection build-depends: base >=4.9 && < 5
, sdl2 >= 2.5 , affection
, stm , sdl2 ^>= 2.5
, OpenGL , stm
, random , OpenGL
, containers , random
, linear , containers
, matrix , linear
, nanovg >= 0.6.0.0 , matrix
, deepseq , nanovg >= 0.6.0.0
if !flag(examples) , deepseq
else
buildable: False buildable: False
-- Another small game of life implementation -- Another small game of life implementation
@ -164,16 +164,17 @@ executable example02
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.9 && < 5 if flag(examples)
, affection build-depends: base >=4.9 && < 5
, sdl2 >= 2.5 , affection
, stm , sdl2 ^>= 2.5
, OpenGL , stm
, random , OpenGL
, containers , random
, linear , containers
, matrix , linear
, nanovg >= 0.6.0.0 , matrix
, deepseq , nanovg >= 0.6.0.0
if !flag(examples) , deepseq
else
buildable: False buildable: False

View file

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

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).
# ];
}

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
}

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 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 in
affection.env
if pkgs.lib.inNixShell then drv.env else drv

View file

@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
@ -16,22 +17,10 @@ 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
@ -42,88 +31,50 @@ 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{..} = runResourceT $ do withAffection AffectionConfig{..} = 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…
renderQuality <- SDL.get SDL.HintRenderScaleQuality do
when (renderQuality /= SDL.ScaleLinear) $ renderQuality <- SDL.get SDL.HintRenderScaleQuality
liftIO $ logIO Warn "Linear texture filtering not enabled!" when (renderQuality /= SDL.ScaleLinear) $
void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer))) logIO Warn "Linear texture filtering not enabled!"
-- construct window -- construct window
liftIO $ logIO Debug "Creating Window(s)" liftIO $ logIO Debug "Creating Window(s)"
windows <- windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
mapM mapM
(\(_, sdlWindowConfig, mode) -> do (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
(windowKey, window) <- windowConfigs <*>
allocate pure (map (\(_,_,z) -> z) windowConfigs)
(SDL.createWindow windowTitle sdlWindowConfig)
(\window -> do
logIO Debug "Destroying Window"
SDL.destroyWindow window
)
return $ AffectionWindow window windowKey mode
)
windowConfigs
-- Show windows mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
mapM_ (SDL.showWindow . awWindow) windows _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
contexts <- zip (map (\(x,_,_) -> x) windows) <$>
-- set modes of windows mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) 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
-- 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" liftIO $ logIO Debug "Getting Time"
execTime <- liftIO $ getTime Monotonic -- get current time
execTime <- 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
(gameDataKey, gameData) <- gameData <- loadState @us
allocate
(liftIO $ loadState @us)
(liftIO . cleanUp)
-- build state container -- build state container
let initContainer = AffectionData let initContainer = AffectionData
{ drawWindows = windows { drawWindows = windows
@ -133,53 +84,41 @@ withAffection AffectionConfig{..} = runResourceT $ do
, sysTime = execTime , sysTime = execTime
, pausedTime = False , pausedTime = False
} }
-- initialize and run state -- initialize and run state
void $ liftIO $ runAffection initContainer (_, _) <- runStateT
(A.runState
(do (do
liftIO $ logIO Debug "Running Pre-Loop stage" liftIO $ logIO Debug "Starting Loop"
-- 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 . awWindow) windows mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
-- save new time -- save new time
ad3 <- get ad3 <- get
when (sysTime ad == sysTime ad3) ( when (sysTime ad == sysTime ad3) (
@ -189,16 +128,11 @@ withAffection AffectionConfig{..} = runResourceT $ do
) )
) )
) )
-- Cleanup works ) initContainer
liftIO $ logIO Debug "Loop ended. Cleaning" liftIO $ logIO Debug "Loop ended. Cleaning"
release gameDataKey cleanUp gameData
-- mapM_ (SDL.glDeleteContext . snd) contexts liftIO $ logIO Debug "Destroying Window"
-- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows mapM_ (SDL.glDeleteContext . snd) contexts
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,6 +1,9 @@
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 us a where class StateMachine a where
-- | State load routine -- | State load routine
smLoad :: a -> us -> Affection () smLoad :: a -> Affection ()
-- | state update routine -- | state update routine
smUpdate :: a -> us -> Double -> Affection () smUpdate :: a -> Double -> Affection ()
-- | State event handler routine -- | State event handler routine
smEvent :: a -> us -> [SDL.EventPayload] -> Affection () smEvent :: a -> [SDL.EventPayload] -> Affection ()
-- | State draw routine -- | State draw routine
smDraw :: a -> us -> Affection () smDraw :: a -> Affection ()
-- | State clean routine -- | State clean routine
smClean :: a -> us -> Affection () smClean :: a -> Affection ()

View file

@ -5,8 +5,6 @@ module Affection.Types
, AffectionData(..) , AffectionData(..)
, AffectionStateInner , AffectionStateInner
, AffectionState(..) , AffectionState(..)
, AffectionWindow(..)
, AffectionContext(..)
, InitComponents(..) , InitComponents(..)
, Angle , Angle
-- | SDL reexports -- | SDL reexports
@ -25,7 +23,6 @@ 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)
@ -53,35 +50,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 :: [ AffectionWindow ] -- ^ SDL windows { drawWindows ::
, glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts [
, elapsedTime :: Double -- ^ Elapsed time in seconds ( Word -- --^ Window identifier
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick , SDL.Window -- --^ Window linked with identifier
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) , SDL.WindowMode -- -- ^ current screen mode
, 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 m = StateT sd m type AffectionStateInner sd a = StateT sd a
-- | 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, MonadResource) deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m) 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 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,35 +39,32 @@ getDelta = gets deltaTime
toggleScreen :: Word -> Affection () toggleScreen :: Word -> Affection ()
toggleScreen windowIdent = do toggleScreen windowIdent = do
ad <- get ad <- get
(stop, alteredWindowList) <- foldM let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad)
(\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do case mwindow of
if stop || num == windowIdent Just (ident, window, mode) -> do
then do newMode <- case mode of
newMode <- case mode of SDL.FullscreenDesktop -> do
SDL.FullscreenDesktop -> do SDL.setWindowMode window SDL.Windowed
liftIO $ SDL.setWindowMode window SDL.Windowed return SDL.Windowed
return SDL.Windowed SDL.Windowed -> do
SDL.Windowed -> do SDL.setWindowMode window SDL.FullscreenDesktop
liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop return SDL.FullscreenDesktop
return SDL.FullscreenDesktop x -> do
x -> do liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) return x
return x now <- liftIO $ getTime Monotonic
return (True, resWindows ++ [aw { awMode = newMode }]) put ad
else { sysTime = now
return (stop, resWindows ++ [aw]) , drawWindows = map
) (\e@(lid, win, _) ->
(False, []) if lid == ident
(zip [0..] (drawWindows ad)) then (lid, win, newMode)
if stop else e
then do )
now <- liftIO $ getTime Monotonic (drawWindows ad)
put ad }
{ sysTime = now Nothing -> do
, drawWindows = alteredWindowList liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
}
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