diff --git a/extern/affection/.gitignore b/extern/affection/.gitignore
new file mode 100644
index 0000000..fa507cf
--- /dev/null
+++ b/extern/affection/.gitignore
@@ -0,0 +1,18 @@
+*.hi
+*.o
+.hsenv*
+.stack-work
+.git
+.cabal-sandbox/
+cabal.sandbox.config
+dist/
+*.prof
+*.aux
+*.hp
+*.ps
+*.swp
+.ghc*
+cabal.project.local*
+dist*/
+report.html
+*.bak
diff --git a/extern/affection/ChangeLog.md b/extern/affection/ChangeLog.md
new file mode 100644
index 0000000..dd649b3
--- /dev/null
+++ b/extern/affection/ChangeLog.md
@@ -0,0 +1,5 @@
+# Revision history for affection
+
+## 0.0.0.7 -- 2017-12-23
+
+* Release with working scaffold for engine subsystems.
diff --git a/extern/affection/LICENSE b/extern/affection/LICENSE
new file mode 100644
index 0000000..31afd6d
--- /dev/null
+++ b/extern/affection/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/extern/affection/README.md b/extern/affection/README.md
new file mode 100644
index 0000000..4664f5f
--- /dev/null
+++ b/extern/affection/README.md
@@ -0,0 +1,8 @@
+# ![Affection logo](./affection.svg)
+
+A simple Game Engine in Haskell using SDL
+
+## Disclaimer
+
+This Engine is not stable yet. Things may change. horribly.
+Even minor version bumps may break the API.
diff --git a/extern/affection/Setup.hs b/extern/affection/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/extern/affection/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/extern/affection/affection.cabal b/extern/affection/affection.cabal
new file mode 100644
index 0000000..4a324e3
--- /dev/null
+++ b/extern/affection/affection.cabal
@@ -0,0 +1,180 @@
+name: affection
+
+-- The package version. See the Haskell package versioning policy (PVP)
+-- for standards guiding when and how versions should be incremented.
+-- http://www.haskell.org/haskellwiki/Package_versioning_policy
+-- PVP summary: +-+------- breaking API changes
+-- | | +----- non-breaking API additions
+-- | | | +--- code changes with no API change
+version: 0.0.0.10
+synopsis: A simple Game Engine using SDL
+description: This package contains Affection, a simple game engine
+ written in Haskell using SDL.
+ This Engine is still work in progress and even minor
+ version bumps may contain breaking api changes.
+homepage: https://github.com/nek0/affection#readme
+license: LGPL-3
+license-file: LICENSE
+author: nek0
+maintainer: nek0@chelnok.de
+category: Game
+build-type: Simple
+extra-source-files: ChangeLog.md
+
+-- Extra files to be distributed with the package, such as examples or a
+-- README.
+-- extra-source-files:
+
+cabal-version: >=2.0
+
+source-repository head
+ type: git
+ location: https://github.com/nek0/affection
+
+flag verbose
+ description: Enable verbose debug messages
+ default: False
+ manual: True
+
+flag debug
+ description: Enable debug messages
+ default: False
+ manual: True
+
+flag warn
+ description: Enable warning messages
+ default: False
+ manual: True
+
+flag error
+ description: Enable error messages
+ default: False
+ manual: True
+
+flag examples
+ description: Build example programs
+ default: False
+
+library
+ if flag(verbose)
+ cpp-options: -DVERBOSE
+ if flag(debug)
+ cpp-options: -DDEBUG
+ if flag(warn)
+ cpp-options: -DWARN
+ if flag(error)
+ cpp-options: -DERROR
+ exposed-modules: Affection
+ , Affection.Logging
+ , Affection.Types
+ , Affection.Class
+ , Affection.StateMachine
+ , Affection.Util
+ , Affection.MessageBus
+ , Affection.MessageBus.Class
+ , Affection.MessageBus.Message
+ , Affection.MessageBus.Message.Class
+ , Affection.MessageBus.Message.WindowMessage
+ , Affection.MessageBus.Message.KeyboardMessage
+ , Affection.MessageBus.Message.MouseMessage
+ , Affection.MessageBus.Message.JoystickMessage
+ , Affection.Subsystems
+ , Affection.Subsystems.Class
+ , Affection.Subsystems.AffectionWindow
+ , Affection.Subsystems.AffectionKeyboard
+ , Affection.Subsystems.AffectionMouse
+ , Affection.Subsystems.AffectionJoystick
+ default-extensions: OverloadedStrings
+ , TypeFamilies
+ , AllowAmbiguousTypes
+
+ -- Modules included in this library but not exported.
+ -- other-modules:
+
+ -- LANGUAGE extensions used by modules in this package.
+ -- other-extensions: GADTs
+ -- , KindSignatures
+ -- , FlexibleInstances
+ -- , MultiParamTypeClasses
+ -- , UndecidableInstances
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -Wall
+ -- Other library packages from which modules are imported.
+ build-depends: base >=4.9 && < 5
+ , sdl2 ^>= 2.5
+ , linear
+ , text
+ , mtl
+ , monad-loops
+ , monad-parallel
+ , containers
+ , clock >= 0.8
+ , glib
+ , bytestring
+ , OpenGL
+ , stm
+ , uuid
+ , vector
+
+-- This example shows the message system. only makes sense when compiling with
+-- verbose flag.
+executable example00
+ hs-source-dirs: examples/example00
+ main-is: Main.hs
+ 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
+ buildable: False
+
+-- A small game of life implementation
+executable example01
+ hs-source-dirs: examples/example01
+ main-is: Main.hs
+ other-modules: Types
+ 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
+ buildable: False
+
+-- Another small game of life implementation
+executable example02
+ hs-source-dirs: examples/example02
+ main-is: Main.hs
+ other-modules: Types
+ 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
+ buildable: False
diff --git a/extern/affection/affection.nix b/extern/affection/affection.nix
new file mode 100644
index 0000000..9085818
--- /dev/null
+++ b/extern/affection/affection.nix
@@ -0,0 +1,18 @@
+{ mkDerivation, base, bytestring, clock, containers, glib, linear
+, monad-loops, monad-parallel, mtl, OpenGL, sdl2, stdenv, stm, text
+, uuid, vector
+}:
+mkDerivation {
+ pname = "affection";
+ version = "0.0.0.9";
+ src = ./.;
+ isLibrary = true;
+ isExecutable = true;
+ libraryHaskellDepends = [
+ base bytestring clock containers glib linear monad-loops
+ monad-parallel mtl OpenGL sdl2 stm text uuid vector
+ ];
+ homepage = "https://github.com/nek0/affection#readme";
+ description = "A simple Game Engine using SDL";
+ license = stdenv.lib.licenses.lgpl3;
+}
diff --git a/extern/affection/affection.svg b/extern/affection/affection.svg
new file mode 100644
index 0000000..22cbb76
--- /dev/null
+++ b/extern/affection/affection.svg
@@ -0,0 +1,106 @@
+
+
diff --git a/extern/affection/cabal.project b/extern/affection/cabal.project
new file mode 100644
index 0000000..aac861d
--- /dev/null
+++ b/extern/affection/cabal.project
@@ -0,0 +1,4 @@
+constraints: affection +verbose
+profiling: true
+packages:
+ ./.
diff --git a/extern/affection/default.nix b/extern/affection/default.nix
new file mode 100644
index 0000000..225fc5f
--- /dev/null
+++ b/extern/affection/default.nix
@@ -0,0 +1,18 @@
+{ pkgs ? import (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz))
+, haskellCompiler ? "ghc865"
+}:
+ pkgs.haskell-nix.cabalProject {
+ src = pkgs.haskell-nix.haskellLib.cleanGit { src = pkgs.nix-gitignore.gitignoreSource [] ./.; };
+ ghc = pkgs.buildPackages.pkgs.haskell-nix.compiler.${haskellCompiler};
+ # pkg-def-extras = [
+ # # Additional packages ontop of all those listed in `cabal.project`
+ # ];
+ # modules = [
+ # # Specific package overrides would go here for example:
+ # packages.cbors.package.ghcOptions = "-Werror";
+ # packages.cbors.patches = [ ./one.patch ];
+ # packages.cbors.flags.optimize-gmp = false;
+ # # It may be better to set flags in `cabal.project` instead
+ # # (`plan-to-nix` will include them as defaults).
+ # ];
+ }
diff --git a/extern/affection/examples/example00/Main.hs b/extern/affection/examples/example00/Main.hs
new file mode 100644
index 0000000..3f8acfb
--- /dev/null
+++ b/extern/affection/examples/example00/Main.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Main where
+
+import Affection as A
+
+import Control.Concurrent.STM
+import Control.Concurrent.MVar
+import Control.Monad
+
+import qualified SDL
+
+import Data.Maybe (isJust, fromJust)
+import Data.String
+
+data StateData = StateData
+ { sdSubs :: Subsystems
+ , sdJoys :: MVar [SDL.Joystick]
+ , doNextStep :: MVar Bool
+ }
+
+instance Affectionate StateData where
+ loadState = load
+ preLoop = pre
+ handleEvents = handle
+ update = Main.update
+ draw = Main.draw
+ cleanUp = clean
+ hasNextStep = liftIO . readMVar . doNextStep
+
+data Subsystems = Subsystems
+ { subWindow :: Main.Window
+ , subMouse :: Main.Mouse
+ , subKeyboard :: Main.Keyboard
+ , subJoystick :: Main.Joystick
+ }
+
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
+newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
+newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])
+
+instance Participant Main.Window where
+ type Mesg Main.Window = WindowMessage
+
+ partSubscribers (Window t) = generalSubscribers t
+
+ partSubscribe (Window t) = generalSubscribe t
+
+ partUnSubscribe (Window t) = generalUnSubscribe t
+
+instance SDLSubsystem Main.Window where
+ consumeSDLEvents = consumeSDLWindowEvents
+
+instance Participant Mouse where
+ type Mesg Mouse = MouseMessage
+
+ partSubscribers (Mouse t) = generalSubscribers t
+
+ partSubscribe (Mouse t) = generalSubscribe t
+
+ partUnSubscribe (Mouse t) = generalUnSubscribe t
+
+instance SDLSubsystem Mouse where
+ consumeSDLEvents = consumeSDLMouseEvents
+
+instance Participant Keyboard where
+ type Mesg Keyboard = KeyboardMessage
+
+ partSubscribers (Keyboard t) = generalSubscribers t
+
+ partSubscribe (Keyboard t) = generalSubscribe t
+
+ partUnSubscribe (Keyboard t) = generalUnSubscribe t
+
+instance SDLSubsystem Keyboard where
+ consumeSDLEvents = consumeSDLKeyboardEvents
+
+instance Participant Joystick where
+ type Mesg Joystick = JoystickMessage
+
+ partSubscribers (Joystick t) = generalSubscribers t
+
+ partSubscribe (Joystick t) = generalSubscribe t
+
+ partUnSubscribe (Joystick t) = generalUnSubscribe t
+
+instance SDLSubsystem Joystick where
+ consumeSDLEvents = consumeSDLJoystickEvents
+
+main :: IO ()
+main = do
+ logIO Debug "Starting"
+ let conf = AffectionConfig
+ { initComponents = All
+ , windowTitle = "affection: example00"
+ , windowConfigs =
+ [
+ ( 0
+ , SDL.defaultWindow
+ { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+ { SDL.glProfile = SDL.Core SDL.Normal 3 3
+ }
+ }
+ , SDL.Windowed
+ )
+ ]
+ } :: AffectionConfig StateData
+ withAffection conf
+
+load :: IO StateData
+load =
+ StateData <$> (Subsystems
+ <$> (Window <$> newTVarIO [])
+ <*> (Mouse <$> newTVarIO [])
+ <*> (Keyboard <$> newTVarIO [])
+ <*> (Joystick <$> newTVarIO [])
+ )
+ <*> newMVar []
+ <*> newMVar True
+
+pre :: StateData -> Affection ()
+pre sd = do
+ _ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
+ _ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
+ _ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
+ return ()
+
+exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
+exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) =
+ case SDL.keysymKeycode sym of
+ SDL.KeycodeQ -> do
+ liftIO $ logIO Debug "Yo dog I heard..."
+ void $ liftIO $ swapMVar nextStep False
+ _ -> return ()
+
+exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
+exitOnWindowClose nextStep wm =
+ case wm of
+ MsgWindowClose _ _ -> do
+ liftIO $ logIO Debug "I heard another one..."
+ void $ liftIO $ swapMVar nextStep False
+ _ -> return ()
+
+joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
+joyConnectDisconnect mvjs msg = do
+ mj <- joystickAutoConnect msg
+ when (isJust mj) $ do
+ js <- liftIO $ readMVar mvjs
+ void $ liftIO $ swapMVar mvjs (fromJust mj : js)
+ js <- liftIO $ readMVar mvjs
+ njs <- joystickAutoDisconnect js msg
+ liftIO $ putMVar mvjs njs
+
+handle :: StateData -> [SDL.EventPayload] -> Affection ()
+handle sd es = do
+ let (Subsystems a b c d) = sdSubs sd
+ leftovers <- consumeSDLEvents a
+ =<< consumeSDLEvents b
+ =<< consumeSDLEvents c
+ =<< consumeSDLEvents d es
+ mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
+ leftovers
+
+update :: StateData -> Double -> Affection ()
+update _ _ = return ()
+
+draw :: StateData -> Affection ()
+draw _ = return ()
+
+clean :: StateData -> IO ()
+clean _ = return ()
+
+generalSubscribers
+ :: TVar [(UUID, msg -> Affection ())]
+ -> Affection [msg -> Affection ()]
+generalSubscribers t = do
+ subTups <- liftIO $ readTVarIO t
+ return $ map snd subTups
+
+generalSubscribe
+ :: TVar [(UUID, msg -> Affection ())]
+ -> (msg -> Affection())
+ -> Affection UUID
+generalSubscribe t funct = do
+ uuid <- genUUID
+ liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+ return uuid
+
+generalUnSubscribe
+ :: TVar [(UUID, msg -> Affection ())]
+ -> UUID
+ -> Affection ()
+generalUnSubscribe t uuid =
+ liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
diff --git a/extern/affection/examples/example01/Main.hs b/extern/affection/examples/example01/Main.hs
new file mode 100644
index 0000000..87484cd
--- /dev/null
+++ b/extern/affection/examples/example01/Main.hs
@@ -0,0 +1,251 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+import Affection as A
+import qualified SDL
+
+import Control.Concurrent.STM
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.DeepSeq (deepseq)
+
+import Data.Matrix as M
+import qualified Data.Set as S
+import Data.String
+
+import System.Random (randomRIO)
+
+import NanoVG hiding (V2(..))
+
+import Foreign.C.Types (CInt(..))
+
+-- internal imports
+
+import Types
+
+instance Affectionate UserData where
+ loadState = load
+ preLoop = pre
+ handleEvents = handle
+ update = Main.update
+ draw = Main.draw
+ cleanUp = clean
+ hasNextStep = liftIO . readMVar . doNextStep
+
+foreign import ccall unsafe "glewInit"
+ glewInit :: IO CInt
+
+main :: IO ()
+main = do
+ logIO A.Debug "Starting"
+ let conf = AffectionConfig
+ { initComponents = All
+ , windowTitle = "affection: example01"
+ , windowConfigs =
+ [
+ ( 0
+ , SDL.defaultWindow
+ { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+ { SDL.glProfile = SDL.Core SDL.Normal 3 3
+ }
+ , SDL.windowInitialSize = SDL.V2 600 600
+ , SDL.windowResizable = True
+ }
+ , SDL.Windowed
+ )
+ ]
+ } :: AffectionConfig UserData
+ withAffection conf
+
+load :: IO UserData
+load = do
+ -- emptyMatrix <- zero 60 60
+ liftIO $ logIO A.Debug "init GLEW"
+ _ <- glewInit
+ liftIO $ logIO A.Debug "making random"
+ randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+ liftIO $ logIO A.Debug "creating context"
+ nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
+ let fullMatrix = fromList 60 60 randList
+ -- logIO A.Debug $ prettyMatrix fullMatrix
+ empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
+ empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
+ step <- newMVar True
+ (\life food time -> UserData
+ { subsystems = Subsystems
+ (Window empty1)
+ (Keyboard empty3)
+ , lifeMat = life
+ , foodMat = food
+ , timeMat = time
+ , nano = nanoCtx
+ , doNextStep = step
+ }
+ )
+ <$> newMVar fullMatrix
+ <*> (newMVar (fromList 60 60 (repeat 10)))
+ <*> (newMVar (M.zero 60 60))
+
+pre :: UserData -> Affection ()
+pre ud = do
+ void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
+ void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
+ void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
+ void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
+ void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
+ void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
+
+toggleFullScreen :: KeyboardMessage -> Affection ()
+toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
+ | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
+ | otherwise = return ()
+toggleFullScreen _ = return ()
+
+exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
+exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
+ case SDL.keysymKeycode sym of
+ SDL.KeycodeEscape -> do
+ liftIO $ logIO A.Debug "Yo dog I heard..."
+ void $ liftIO $ swapMVar step False
+ _ -> return ()
+exitOnEsc _ _ = return ()
+
+reloadOnR :: UserData -> KeyboardMessage -> Affection ()
+reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
+ case SDL.keysymKeycode sym of
+ SDL.KeycodeR -> reload ud
+ _ -> return ()
+
+reload :: UserData -> Affection ()
+reload ud = do
+ randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+ let fullMatrix = fromList 60 60 randList
+ void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
+ void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10))
+ void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
+
+showFPS :: KeyboardMessage -> Affection ()
+showFPS (MsgKeyboardEvent _ _ _ _ sym) =
+ case SDL.keysymKeycode sym of
+ SDL.KeycodeF -> do
+ dt <- getDelta
+ liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
+ _ -> return ()
+
+exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
+exitOnWindowClose step wm =
+ case wm of
+ MsgWindowClose _ _ -> do
+ liftIO $ logIO A.Debug "I heard another one..."
+ void $ liftIO $ swapMVar step False
+ _ -> return ()
+
+handle :: UserData -> [SDL.EventPayload] -> Affection ()
+handle ud es = do
+ let (Subsystems a b) = subsystems ud
+ _ <- consumeSDLEvents a =<< consumeSDLEvents b es
+ return ()
+
+update :: UserData -> Double -> Affection ()
+update ud _ = do
+ -- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt)))
+ pastLife <- liftIO $ readMVar (lifeMat ud)
+ pastFood <- liftIO $ readMVar (foodMat ud)
+ pastTime <- liftIO $ readMVar (timeMat ud)
+ newList <- mapM (\coord -> do
+ let x = (coord `mod` 60) + 1
+ y = (coord `div` 60) + 1
+ subm
+ | x == 1 && y == 1 =
+ (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife)
+ <->
+ (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
+ | x == 1 && y == 60 =
+ (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
+ <->
+ (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
+ | x == 60 && y == 1 =
+ (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
+ <->
+ (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
+ | x == 60 && y == 60 =
+ (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
+ <->
+ (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
+ | x == 1 =
+ (submatrix (y - 1) (y + 1) 60 60 pastLife)
+ <|>
+ (submatrix (y - 1) (y + 1) 1 2 pastLife)
+ | y == 1 =
+ (submatrix 60 60 (x - 1) (x + 1) pastLife)
+ <->
+ (submatrix 1 2 (x - 1) (x + 1) pastLife)
+ | x == 60 =
+ (submatrix (y - 1) (y + 1) 59 60 pastLife)
+ <|>
+ (submatrix (y - 1) (y + 1) 1 1 pastLife)
+ | y == 60 =
+ (submatrix 59 60 (x -1 ) (x + 1) pastLife)
+ <->
+ (submatrix 1 1 (x - 1) (x + 1) pastLife)
+ | otherwise =
+ (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
+ life = countLife subm
+ if pastLife M.! (y, x) == 1
+ then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
+ then return (1, (pastFood M.! (y, x)) - 1, 0)
+ else return (0, pastFood M.! (y, x), 0)
+ else if life == 3 && pastFood M.! (y, x) > 0
+ then return (1, (pastFood M.! (y, x)) - 1, 0)
+ else return
+ ( (0 :: Word)
+ , if pastTime M.! (y, x) > 10
+ then min 10 ((pastFood M.! (y, x)) + 1)
+ else min 10 (pastFood M.! (y, x))
+ , pastTime M.! (y, x) + 1
+ )
+ ) [0..3599]
+ let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
+ newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)
+ newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
+ if newLifeMat == M.zero 60 60
+ then
+ reload ud
+ else do
+ ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
+ void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
+ void $ liftIO $ swapMVar (timeMat ud) newTimeMat
+
+countLife :: Matrix Word -> Word
+countLife mat = res - (mat M.! (2, 2))
+ where
+ res = foldr (flip (+)) 0 mat
+
+draw :: UserData -> Affection ()
+draw ud = do
+ life <- liftIO $ readMVar (lifeMat ud)
+ food <- liftIO $ readMVar (foodMat ud)
+ liftIO $ do
+ beginFrame (nano ud) 600 600 1
+ save (nano ud)
+ mapM_ (\coord -> do
+ let x = coord `mod` 60
+ y = coord `div` 60
+ ctx = nano ud
+ mult = life M.! (x + 1, y + 1)
+ -- logIO A.Debug $ show mult
+ beginPath ctx
+ rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
+ if mult == 1
+ then
+ fillColor ctx (rgba 255 255 255 255)
+ else
+ fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255)
+ fill ctx
+ ) [0..3599]
+ restore (nano ud)
+ endFrame (nano ud)
+
+clean :: UserData -> IO ()
+clean _ = return ()
diff --git a/extern/affection/examples/example01/Types.hs b/extern/affection/examples/example01/Types.hs
new file mode 100644
index 0000000..e56d7ae
--- /dev/null
+++ b/extern/affection/examples/example01/Types.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Types where
+
+import Affection
+
+import Data.Matrix as M
+
+import NanoVG
+
+import Control.Concurrent.STM
+import Control.Concurrent.MVar
+
+data UserData = UserData
+ { lifeMat :: MVar (Matrix Word)
+ , foodMat :: MVar (Matrix Word)
+ , timeMat :: MVar (Matrix Word)
+ , subsystems :: Subsystems
+ , nano :: Context
+ , doNextStep :: MVar Bool
+ }
+
+data Subsystems = Subsystems
+ { subWindow :: Types.Window
+ , subKeyboard :: Types.Keyboard
+ }
+
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
+
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
+
+instance Participant Types.Window where
+ type Mesg Types.Window = WindowMessage
+
+ partSubscribers (Window t) = do
+ subTups <- liftIO $ readTVarIO t
+ return $ map snd subTups
+
+ partSubscribe (Window t) = generalSubscribe t
+
+ partUnSubscribe (Window t) = generalUnSubscribe t
+
+instance SDLSubsystem Types.Window where
+ consumeSDLEvents = consumeSDLWindowEvents
+
+instance Participant Keyboard where
+ type Mesg Keyboard = KeyboardMessage
+
+ partSubscribers (Keyboard t) = do
+ subTups <- liftIO $ readTVarIO t
+ return $ map snd subTups
+
+ partSubscribe (Keyboard t) = generalSubscribe t
+
+ partUnSubscribe (Keyboard t) = generalUnSubscribe t
+
+instance SDLSubsystem Keyboard where
+ consumeSDLEvents = consumeSDLKeyboardEvents
+
+generalSubscribe
+ :: TVar [(UUID, msg -> Affection ())]
+ -> (msg -> Affection ())
+ -> Affection UUID
+generalSubscribe t funct = do
+ uuid <- genUUID
+ liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+ return uuid
+
+generalUnSubscribe
+ :: TVar [(UUID, msg -> Affection ())]
+ -> UUID
+ -> Affection ()
+generalUnSubscribe t uuid =
+ liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
+ where
+ filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
+ filterMsg (u, _) p = u /= p
diff --git a/extern/affection/examples/example02/Main.hs b/extern/affection/examples/example02/Main.hs
new file mode 100644
index 0000000..7fc079e
--- /dev/null
+++ b/extern/affection/examples/example02/Main.hs
@@ -0,0 +1,253 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+import Affection as A
+import qualified SDL
+
+import Control.Concurrent.STM
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.DeepSeq (deepseq)
+
+import Data.Matrix as M
+import qualified Data.Set as S
+import Data.String
+
+import System.Random (randomRIO)
+
+import NanoVG hiding (V2(..))
+
+import Foreign.C.Types (CInt(..))
+
+-- internal imports
+
+import Types
+
+instance Affectionate UserData where
+ loadState = load
+ preLoop = pre
+ handleEvents = handle
+ update = Main.update
+ draw = Main.draw
+ cleanUp = clean
+ hasNextStep = liftIO . readMVar . doNextStep
+
+foreign import ccall unsafe "glewInit"
+ glewInit :: IO CInt
+
+maxFood :: Word
+maxFood = 255
+
+main :: IO ()
+main = do
+ logIO A.Debug "Starting"
+ let conf = AffectionConfig
+ { initComponents = All
+ , windowTitle = "affection: example01"
+ , windowConfigs =
+ [
+ ( 0
+ , SDL.defaultWindow
+ { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+ { SDL.glProfile = SDL.Core SDL.Normal 3 3
+ }
+ , SDL.windowInitialSize = SDL.V2 600 600
+ , SDL.windowResizable = True
+ }
+ , SDL.Windowed
+ )
+ ]
+ } :: AffectionConfig UserData
+ withAffection conf
+
+load :: IO UserData
+load = do
+ -- emptyMatrix <- zero 60 60
+ liftIO $ logIO A.Debug "init GLEW"
+ _ <- glewInit
+ liftIO $ logIO A.Debug "making random"
+ randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+ liftIO $ logIO A.Debug "creating context"
+ nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
+ let fullMatrix = fromList 60 60 randList
+ -- logIO A.Debug $ prettyMatrix fullMatrix
+ empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
+ empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
+ (\life food time nextStep -> UserData
+ { subsystems = Subsystems
+ (Window empty1)
+ (Keyboard empty3)
+ , lifeMat = life
+ , foodMat = food
+ , timeMat = time
+ , nano = nanoCtx
+ , doNextStep = nextStep
+ }
+ )
+ <$> newMVar fullMatrix
+ <*> newMVar (fromList 60 60 (repeat maxFood))
+ <*> newMVar (M.zero 60 60)
+ <*> newMVar True
+
+pre :: UserData -> Affection ()
+pre ud = do
+ void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
+ void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
+ void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
+ void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
+ void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
+ void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
+
+toggleFullScreen :: KeyboardMessage -> Affection ()
+toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
+ | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
+ | otherwise = return ()
+toggleFullScreen _ = return ()
+
+exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
+exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
+ case SDL.keysymKeycode sym of
+ SDL.KeycodeEscape -> do
+ liftIO $ logIO A.Debug "Yo dog I heard..."
+ void $ liftIO $ swapMVar step False
+ _ -> return ()
+exitOnEsc _ _ = return ()
+
+reloadOnR :: UserData -> KeyboardMessage -> Affection ()
+reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
+ case SDL.keysymKeycode sym of
+ SDL.KeycodeR -> reload ud
+ _ -> return ()
+
+reload :: UserData -> Affection ()
+reload ud = do
+ randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+ let fullMatrix = fromList 60 60 randList
+ void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
+ void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat maxFood))
+ void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
+
+showFPS :: KeyboardMessage -> Affection ()
+showFPS (MsgKeyboardEvent _ _ _ _ sym) =
+ case SDL.keysymKeycode sym of
+ SDL.KeycodeF -> do
+ dt <- getDelta
+ liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
+ _ -> return ()
+
+exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
+exitOnWindowClose step wm =
+ case wm of
+ MsgWindowClose _ _ -> do
+ liftIO $ logIO A.Debug "I heard another one..."
+ void $ liftIO $ swapMVar step False
+ _ -> return ()
+
+handle :: UserData -> [SDL.EventPayload] -> Affection ()
+handle ud es = do
+ let (Subsystems a b) = subsystems ud
+ _ <- consumeSDLEvents a =<< consumeSDLEvents b es
+ return ()
+
+update :: UserData -> Double -> Affection ()
+update ud _ = do
+ pastLife <- liftIO $ readMVar (lifeMat ud)
+ pastFood <- liftIO $ readMVar (foodMat ud)
+ pastTime <- liftIO $ readMVar (timeMat ud)
+ newList <- mapM (\coord -> do
+ let x = (coord `mod` 60) + 1
+ y = (coord `div` 60) + 1
+ subm
+ | x == 1 && y == 1 =
+ (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife)
+ <->
+ (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
+ | x == 1 && y == 60 =
+ (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
+ <->
+ (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
+ | x == 60 && y == 1 =
+ (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
+ <->
+ (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
+ | x == 60 && y == 60 =
+ (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
+ <->
+ (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
+ | x == 1 =
+ (submatrix (y - 1) (y + 1) 60 60 pastLife)
+ <|>
+ (submatrix (y - 1) (y + 1) 1 2 pastLife)
+ | y == 1 =
+ (submatrix 60 60 (x - 1) (x + 1) pastLife)
+ <->
+ (submatrix 1 2 (x - 1) (x + 1) pastLife)
+ | x == 60 =
+ (submatrix (y - 1) (y + 1) 59 60 pastLife)
+ <|>
+ (submatrix (y - 1) (y + 1) 1 1 pastLife)
+ | y == 60 =
+ (submatrix 59 60 (x -1 ) (x + 1) pastLife)
+ <->
+ (submatrix 1 1 (x - 1) (x + 1) pastLife)
+ | otherwise =
+ (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
+ life = countLife subm
+ if pastLife M.! (y, x) == 1
+ then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
+ then return (1, (pastFood M.! (y, x)) - 1, 0)
+ else return (0, pastFood M.! (y, x), 0)
+ else if life == 3 && pastFood M.! (y, x) > 0
+ then return (1, (pastFood M.! (y, x)) - 1, 0)
+ else return
+ ( 0 :: Word
+ , if pastTime M.! (y, x) > 10
+ then min maxFood ((pastFood M.! (y, x)) + 1)
+ else min maxFood (pastFood M.! (y, x))
+ , pastTime M.! (y, x) + 1
+ )
+ ) [0..3599]
+ let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
+ newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)
+ newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
+ if newLifeMat == M.zero 60 60
+ then
+ reload ud
+ else do
+ ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
+ void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
+ void $ liftIO $ swapMVar (timeMat ud) newTimeMat
+ void $ liftIO $ swapMVar (foodMat ud) newFoodMat
+
+countLife :: Matrix Word -> Word
+countLife mat = res - (mat M.! (2, 2))
+ where
+ res = foldr (flip (+)) 0 mat
+
+draw :: UserData -> Affection ()
+draw ud = liftIO $ do
+ pastLife <- readMVar (lifeMat ud)
+ pastFood <- readMVar (foodMat ud)
+ beginFrame (nano ud) 600 600 1
+ save (nano ud)
+ mapM_ (\coord -> do
+ let x = coord `mod` 60
+ y = coord `div` 60
+ ctx = nano ud
+ multiplicator = pastLife M.! (x + 1, y + 1)
+ -- logIO A.Debug $ show mult
+ beginPath ctx
+ rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
+ if multiplicator == 1
+ then
+ fillColor ctx (rgba 255 255 255 255)
+ else
+ fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255)
+ fill ctx
+ ) [0..3599]
+ restore (nano ud)
+ endFrame (nano ud)
+
+clean :: UserData -> IO ()
+clean _ = return ()
diff --git a/extern/affection/examples/example02/Types.hs b/extern/affection/examples/example02/Types.hs
new file mode 100644
index 0000000..e56d7ae
--- /dev/null
+++ b/extern/affection/examples/example02/Types.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Types where
+
+import Affection
+
+import Data.Matrix as M
+
+import NanoVG
+
+import Control.Concurrent.STM
+import Control.Concurrent.MVar
+
+data UserData = UserData
+ { lifeMat :: MVar (Matrix Word)
+ , foodMat :: MVar (Matrix Word)
+ , timeMat :: MVar (Matrix Word)
+ , subsystems :: Subsystems
+ , nano :: Context
+ , doNextStep :: MVar Bool
+ }
+
+data Subsystems = Subsystems
+ { subWindow :: Types.Window
+ , subKeyboard :: Types.Keyboard
+ }
+
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
+
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
+
+instance Participant Types.Window where
+ type Mesg Types.Window = WindowMessage
+
+ partSubscribers (Window t) = do
+ subTups <- liftIO $ readTVarIO t
+ return $ map snd subTups
+
+ partSubscribe (Window t) = generalSubscribe t
+
+ partUnSubscribe (Window t) = generalUnSubscribe t
+
+instance SDLSubsystem Types.Window where
+ consumeSDLEvents = consumeSDLWindowEvents
+
+instance Participant Keyboard where
+ type Mesg Keyboard = KeyboardMessage
+
+ partSubscribers (Keyboard t) = do
+ subTups <- liftIO $ readTVarIO t
+ return $ map snd subTups
+
+ partSubscribe (Keyboard t) = generalSubscribe t
+
+ partUnSubscribe (Keyboard t) = generalUnSubscribe t
+
+instance SDLSubsystem Keyboard where
+ consumeSDLEvents = consumeSDLKeyboardEvents
+
+generalSubscribe
+ :: TVar [(UUID, msg -> Affection ())]
+ -> (msg -> Affection ())
+ -> Affection UUID
+generalSubscribe t funct = do
+ uuid <- genUUID
+ liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+ return uuid
+
+generalUnSubscribe
+ :: TVar [(UUID, msg -> Affection ())]
+ -> UUID
+ -> Affection ()
+generalUnSubscribe t uuid =
+ liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
+ where
+ filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
+ filterMsg (u, _) p = u /= p
diff --git a/extern/affection/notes/TODO.md b/extern/affection/notes/TODO.md
new file mode 100644
index 0000000..6a15c72
--- /dev/null
+++ b/extern/affection/notes/TODO.md
@@ -0,0 +1,9 @@
+# TODO
+
+Implement following things in approximately this Order:
+
+* Message bus -> DONE
+* Console
+* GUI
+* Framework
+* Everything else
diff --git a/extern/affection/shell.nix b/extern/affection/shell.nix
new file mode 100644
index 0000000..6d4b133
--- /dev/null
+++ b/extern/affection/shell.nix
@@ -0,0 +1,125 @@
+{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }:
+
+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 {});
+
+in
+
+ if pkgs.lib.inNixShell then drv.env else drv
diff --git a/extern/affection/src/Affection.hs b/extern/affection/src/Affection.hs
new file mode 100644
index 0000000..2b1f908
--- /dev/null
+++ b/extern/affection/src/Affection.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+module Affection
+ ( withAffection
+ , get
+ , put
+ , liftIO
+ , module A
+ ) where
+
+import SDL (($=))
+import qualified SDL
+import qualified SDL.Raw.Video as SDL (glSetAttribute)
+import qualified SDL.Raw.Enum as SDL
+
+import System.Clock
+
+import Control.Monad.Loops
+import Control.Monad.State.Strict
+
+import Affection.Types as A
+import Affection.Class as A
+import Affection.StateMachine as A
+import Affection.Util as A
+import Affection.MessageBus as A
+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
+ 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!"
+ -- construct window
+ liftIO $ logIO Debug "Creating Window(s)"
+ windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
+ mapM
+ (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
+ windowConfigs <*>
+ pure (map (\(_,_,z) -> z) 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
+ -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
+ liftIO $ logIO Debug "Getting Time"
+ -- get current time
+ execTime <- getTime Monotonic
+ liftIO $ logIO Debug "Loading initial data container"
+ -- construct game data object from provided Affectionate instance
+ gameData <- loadState @us
+ -- build state container
+ let initContainer = AffectionData
+ { drawWindows = windows
+ , glContext = contexts
+ , elapsedTime = 0
+ , deltaTime = 0
+ , sysTime = execTime
+ , pausedTime = False
+ }
+ -- initialize and run state
+ (_, _) <- runStateT
+ (A.runState
+ (do
+ liftIO $ logIO Debug "Starting Loop"
+ -- run preLoop function from Affectionate
+ preLoop gameData
+ 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
+ (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
+ !ne = elapsedTime ad + dt
+ -- update state data object with new time values
+ put $ ad
+ { elapsedTime = ne
+ , deltaTime = dt
+ }
+ -- poll events
+ 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
+ -- save new time
+ ad3 <- get
+ when (sysTime ad == sysTime ad3) (
+ put ad3
+ { sysTime = now
+ }
+ )
+ )
+ )
+ ) initContainer
+ liftIO $ logIO Debug "Loop ended. Cleaning"
+ 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"
diff --git a/extern/affection/src/Affection/Class.hs b/extern/affection/src/Affection/Class.hs
new file mode 100644
index 0000000..bb09229
--- /dev/null
+++ b/extern/affection/src/Affection/Class.hs
@@ -0,0 +1,21 @@
+module Affection.Class where
+
+import qualified SDL
+
+import Affection.Types as A
+
+class Affectionate a where
+
+ loadState :: IO a
+
+ preLoop :: a -> Affection ()
+
+ handleEvents :: a -> [SDL.EventPayload] -> Affection ()
+
+ update :: a -> Double -> Affection ()
+
+ draw :: a -> Affection ()
+
+ cleanUp :: a -> IO ()
+
+ hasNextStep :: a -> Affection Bool
diff --git a/extern/affection/src/Affection/Logging.hs b/extern/affection/src/Affection/Logging.hs
new file mode 100644
index 0000000..6155d2b
--- /dev/null
+++ b/extern/affection/src/Affection/Logging.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE CPP #-}
+-- | This module defines the logging capability of Affection, whis is derived
+-- from "Debug.Trace".
+module Affection.Logging where
+
+import qualified Data.Text as T
+
+import Debug.Trace
+
+-- | The log level definition
+data LogLevel
+ = Verbose -- ^ Log everything
+ | Debug -- ^ Log Debug messages and above
+ | Warn -- ^ Log only Warnings and errors
+ | Error -- ^ Log only errors
+
+-- | Pure logging function
+log
+ :: LogLevel -- ^ Log level to log to
+ -> T.Text -- ^ The message string
+ -> a -- ^ Arbitrary datatype to return
+ -> a -- ^ Returned data
+#if defined(VERBOSE)
+log Verbose s = trace ("VERBOSE: " ++ T.unpack s)
+#endif
+#if defined(DEBUG) || defined(VERBOSE)
+log Debug s = trace ("DEBUG: " ++ T.unpack s)
+#endif
+#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
+log Warn s = trace ("WARN: " ++ T.unpack s)
+#endif
+#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
+log Error s = trace ("ERROR: " ++ T.unpack s)
+#endif
+log _ _ = id
+
+-- | Manadic logging function residing in the 'IO' Monad
+logIO
+ :: LogLevel -- ^ Log level to log to
+ -> T.Text -- ^ The message string
+ -> IO ()
+#if defined(VERBOSE)
+logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s)
+#endif
+#if defined(DEBUG) || defined(VERBOSE)
+logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s)
+#endif
+#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
+logIO Warn s = traceIO ("WARN: " ++ T.unpack s)
+#endif
+#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
+logIO Error s = traceIO ("ERROR: " ++ T.unpack s)
+#endif
+logIO _ _ = return ()
diff --git a/extern/affection/src/Affection/MessageBus.hs b/extern/affection/src/Affection/MessageBus.hs
new file mode 100644
index 0000000..6ae83e4
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus.hs
@@ -0,0 +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
diff --git a/extern/affection/src/Affection/MessageBus/Class.hs b/extern/affection/src/Affection/MessageBus/Class.hs
new file mode 100644
index 0000000..9a16f94
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus/Class.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Affection.MessageBus.Class
+ ( Participant(..)
+ , genUUID
+ , UUID
+ ) where
+
+import Affection.MessageBus.Message
+import Affection.Types
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.UUID
+import Data.UUID.V4
+
+import Data.String as S (fromString)
+
+import Affection.Logging
+
+-- | This typeclass defines the behaviour of a participant in the message system
+class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where
+ -- | Message datatype
+ type Mesg prt :: *
+
+ -- | Function to get the list of subscribers from the participant
+ partSubscribers
+ :: prt
+ -- ^ the 'Participant''s subscriber storage
+ -> Affection [Mesg prt -> Affection ()]
+ -- ^ List of Subscriber functions
+
+ -- | Subscribe to the 'Participant''s events
+ partSubscribe
+ :: prt
+ -- ^ The 'Participant''s subscriber storage
+ -> (Mesg prt -> Affection ())
+ -- ^ What to do in case of a 'Message'
+ -- (Subscriber function)
+ -> Affection UUID
+ -- ^ 'UUID' of the registered subscriber Function
+
+ -- | Unsubscribe a Subscriber function from Participant
+ partUnSubscribe
+ :: prt
+ -- ^ The 'Participant''s subscriber storage to unsubscribe from
+ -> UUID
+ -- ^ The subscriber function's 'UUID'
+ -> Affection ()
+
+ -- | Get the 'Participant' to emit a 'Message' on all of its subscribers
+ partEmit
+ :: prt
+ -- ^ The 'Participant''s subscriber storage
+ -> Mesg prt
+ -- ^ The 'Message' to emit
+ -> Affection ()
+ partEmit p m = do
+ liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m)
+ l <- partSubscribers p
+ mapM_ ($ m) l
+
+-- | Helper function to generate new 'UUID's
+genUUID :: Affection UUID
+genUUID = liftIO nextRandom
diff --git a/extern/affection/src/Affection/MessageBus/Message.hs b/extern/affection/src/Affection/MessageBus/Message.hs
new file mode 100644
index 0000000..abf0f0c
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus/Message.hs
@@ -0,0 +1,9 @@
+module Affection.MessageBus.Message
+ ( module M
+ ) where
+
+import Affection.MessageBus.Message.Class as M
+import Affection.MessageBus.Message.WindowMessage as M
+import Affection.MessageBus.Message.KeyboardMessage as M
+import Affection.MessageBus.Message.MouseMessage as M
+import Affection.MessageBus.Message.JoystickMessage as M
diff --git a/extern/affection/src/Affection/MessageBus/Message/Class.hs b/extern/affection/src/Affection/MessageBus/Message/Class.hs
new file mode 100644
index 0000000..3da6039
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus/Message/Class.hs
@@ -0,0 +1,6 @@
+module Affection.MessageBus.Message.Class where
+
+-- | Typeclass definition for messages
+class Message msg where
+ -- | return the time when the message was sent
+ msgTime :: msg -> Double
diff --git a/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs b/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs
new file mode 100644
index 0000000..45fb34e
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs
@@ -0,0 +1,67 @@
+module Affection.MessageBus.Message.JoystickMessage
+ ( JoystickMessage(..)
+ -- | Vector export
+ , Linear.V2
+ -- | SDL exports
+ , SDL.JoyHatPosition
+ , SDL.JoyButtonState
+ , SDL.JoyDeviceConnection
+ -- | Number exports
+ , Word8
+ , Int16
+ , Int32
+ ) where
+
+import Affection.MessageBus.Message.Class
+
+import Data.Word (Word8)
+import Data.Int (Int32, Int16)
+
+import qualified SDL
+
+import Linear (V2(..))
+
+-- | Datatype for handling all possible joystick events handed over from sdl2
+data JoystickMessage
+ -- | Movement of a Joystick axis
+ = MsgJoystickAxis
+ { msgJAWhen :: Double -- ^ Time of event
+ , msgJAWhich :: Int32 -- ^ Joystick identifier
+ , msgJAAxis :: Word8 -- ^ Axis identifier
+ , msgJAValue :: Int16 -- ^ Axis value
+ }
+ -- | Movement of a joystick ball controller
+ | MsgJoystickBall
+ { msgJBWhen :: Double -- ^ Time of event
+ , msgJBWhich :: Int32 -- ^ Joystick identifier
+ , msgJBBall :: Word8 -- ^ Ball identifier
+ , msgJBRelMotion :: V2 Int16 -- ^ Motion relative to previous position
+ }
+ -- | Movement of joystick hat controller
+ | MsgJoystickHat
+ { msgJHWhen :: Double -- ^ Time of event
+ , msgJHWhich :: Int32 -- ^ Joystick identifier
+ , msgJHHat :: Word8 -- ^ Hat identifier
+ , msgJHPosition :: SDL.JoyHatPosition -- ^ New hat position
+ }
+ -- | Joystick button event
+ | MsgJoystickButton
+ { msgJBWhen :: Double -- ^ Time of event
+ , msgJBWhich :: Int32 -- ^ Joystick identifier
+ , msgJBButton :: Word8 -- ^ Button identifier
+ , msgJBState :: SDL.JoyButtonState -- ^ New Button state
+ }
+ -- | Joystick device event
+ | MsgJoystickDevice
+ { msgJDWhen :: Double -- ^ Time of event
+ , msgJDWhich :: Int32 -- ^ Joystick identifier
+ , msgJDConnection :: SDL.JoyDeviceConnection -- ^ Connection status
+ }
+ deriving (Show)
+
+instance Message JoystickMessage where
+ msgTime (MsgJoystickAxis t _ _ _) = t
+ msgTime (MsgJoystickBall t _ _ _) = t
+ msgTime (MsgJoystickHat t _ _ _) = t
+ msgTime (MsgJoystickButton t _ _ _) = t
+ msgTime (MsgJoystickDevice t _ _) = t
diff --git a/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs b/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs
new file mode 100644
index 0000000..9caef1f
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs
@@ -0,0 +1,26 @@
+module Affection.MessageBus.Message.KeyboardMessage
+ ( KeyboardMessage(..)
+ -- | SDL reexports
+ , SDL.Window
+ , SDL.InputMotion
+ , SDL.Keysym
+ ) where
+
+import Affection.MessageBus.Message.Class
+
+import qualified SDL
+
+-- | Dataatype for handling all keyboard events haded down from SDL2
+data KeyboardMessage
+ -- | Arbitrary Keyboard event
+ = MsgKeyboardEvent
+ { msgKbdWhen :: Double -- ^ Message time
+ , msgKbdWindow :: Maybe SDL.Window -- ^ Affected Window
+ , msgKbdKeyMotion :: SDL.InputMotion -- ^ Input motion of button (pressed/released)
+ , msgKbdKeyRepeat :: Bool -- ^ Is this a repeated event?
+ , msgKbdKeysym :: SDL.Keysym -- ^ The button's 'SDL.Keysym'
+ }
+ deriving (Show)
+
+instance Message KeyboardMessage where
+ msgTime (MsgKeyboardEvent t _ _ _ _) = t
diff --git a/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs b/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs
new file mode 100644
index 0000000..a13baff
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs
@@ -0,0 +1,54 @@
+module Affection.MessageBus.Message.MouseMessage
+ ( MouseMessage(..)
+ -- | SDL reexports
+ , SDL.Window
+ , SDL.MouseDevice
+ , SDL.MouseButton
+ , SDL.InputMotion
+ , SDL.MouseScrollDirection
+ ) where
+
+import Affection.MessageBus.Message.Class
+
+import Data.Word (Word8)
+import Data.Int (Int32)
+
+import qualified SDL
+
+import Linear (V2(..))
+
+-- Datatype for handling mouse events handed down from SDL2
+data MouseMessage
+ -- | Mouse motion event
+ = MsgMouseMotion
+ { msgMMWhen :: Double -- ^ Message time
+ , msgMMWindow :: Maybe SDL.Window -- ^ Focused window (if any)
+ , msgMMWhich :: SDL.MouseDevice -- ^ Mouse device identifier
+ , msgMMState :: [SDL.MouseButton] -- ^ List of pressed mouse buttons
+ , msgMMPos :: V2 Int32 -- ^ Absolute mouse positiom
+ , msgMMRelMotion :: V2 Int32 -- ^ Mouse movement relative to previous position
+ }
+ -- | Mouse button event
+ | MsgMouseButton
+ { msgMBWhen :: Double -- ^ Message time
+ , msgMBWindow :: Maybe SDL.Window -- ^ Focused window (if any)
+ , msgMBMotion :: SDL.InputMotion -- ^ Button's input motion
+ , msgMBWhich :: SDL.MouseDevice -- ^ Mouse device identifier
+ , msgMBButton :: SDL.MouseButton -- ^ Affected mouse button
+ , msgMBClicks :: Word8 -- ^ Number of clicks
+ , msgMBPos :: V2 Int32 -- ^ Absolute mouse position
+ }
+ -- | Mouse wheel event
+ | MsgMouseWheel
+ { msgMWWhen :: Double -- ^ Message time
+ , msgMWWhindow :: Maybe SDL.Window -- ^ Focused window (if any)
+ , msgMWWhich :: SDL.MouseDevice -- ^ Mouse device identifier
+ , msgMWPos :: V2 Int32 -- ^ Absolute mouse position
+ , msgMWDIrection :: SDL.MouseScrollDirection -- ^ Scroll direction
+ }
+ deriving (Show)
+
+instance Message MouseMessage where
+ msgTime (MsgMouseMotion t _ _ _ _ _) = t
+ msgTime (MsgMouseButton t _ _ _ _ _ _) = t
+ msgTime (MsgMouseWheel t _ _ _ _) = t
diff --git a/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs b/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs
new file mode 100644
index 0000000..994f023
--- /dev/null
+++ b/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs
@@ -0,0 +1,106 @@
+module Affection.MessageBus.Message.WindowMessage
+ ( WindowMessage(..)
+ -- | SDL reexports
+ , SDL.Window
+ ) where
+
+import Affection.MessageBus.Message.Class
+
+import Data.Int (Int32)
+
+import qualified SDL
+
+import Linear (V2(..))
+
+-- | Datatype for handling Window events handed down rom SDL2
+data WindowMessage
+ -- | Window show event
+ = MsgWindowShow
+ { msgWSWhen :: Double -- ^ Message time
+ , msgWSWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window hide event
+ | MsgWindowHide
+ { msgWHWhen :: Double -- ^ Message time
+ , msgWHWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window expose event
+ | MsgWindowExpose
+ { msgWEWhen :: Double -- ^ Message time
+ , msgWEWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window move event
+ | MsgWindowMove
+ { msgWMWhen :: Double -- ^ Message time
+ , msgWMWindow :: SDL.Window -- ^ Window identifier
+ , msgWMNewPos :: V2 Int32 -- ^ New absolute window position
+ }
+ -- | Window resize event
+ | MsgWindowResize
+ { msgWRWhen :: Double -- ^ Message time
+ , msgWRWindow :: SDL.Window -- ^ Window identifier
+ , msgWRNewSize :: V2 Int32 -- ^ New absolute window size
+ }
+ -- | Window size change event
+ | MsgWindowSizeChange
+ { msgWSCWhen :: Double -- ^ Message time
+ , msgWSCWindow :: SDL.Window -- ^ Window identifier
+ , msgWSCNewSize :: V2 Int32 -- ^ New absolute window size
+ }
+ -- | Window minimize event
+ | MsgWindowMinimize
+ { msgWMinWhen :: Double -- ^ Message time
+ , msgWMinWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window maximize event
+ | MsgWindowMaximize
+ { msgWMaxWhen :: Double -- ^ Message time
+ , msgWMaxWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window restore event
+ | MsgWindowRestore
+ { msgWRestWhen :: Double -- ^ Message time
+ , msgWRestWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window gain mouse focus event
+ | MsgWindowGainMouseFocus
+ { msgWGMFWhen :: Double -- ^ Message Time
+ , msgWGMFWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window lose mouse focus event
+ | MsgWindowLoseMouseFocus
+ { msgWLMFWhen :: Double -- ^ Message Time
+ , msgWLMFWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window gain keyboard focus event
+ | MsgWindowGainKeyboardFocus
+ { msgWGKFWhen :: Double -- ^ Message time
+ , msgWGKFWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window lose keyboard focus event
+ | MsgWindowLoseKeyboardFocus
+ { msgWLKFWhen :: Double -- ^ Message time
+ , msgWLKFWindow :: SDL.Window -- ^ Window identifier
+ }
+ -- | Window close event
+ | MsgWindowClose
+ { msgWCWhen :: Double -- ^ Message time
+ , msgWCWindow :: SDL.Window -- ^ Window identifier
+ }
+ deriving (Show)
+
+instance Message WindowMessage where
+ msgTime (MsgWindowShow t _) = t
+ msgTime (MsgWindowHide t _) = t
+ msgTime (MsgWindowExpose t _) = t
+ msgTime (MsgWindowMove t _ _) = t
+ msgTime (MsgWindowResize t _ _) = t
+ msgTime (MsgWindowSizeChange t _ _) = t
+ msgTime (MsgWindowMinimize t _) = t
+ msgTime (MsgWindowMaximize t _) = t
+ msgTime (MsgWindowRestore t _) = t
+ msgTime (MsgWindowGainMouseFocus t _) = t
+ msgTime (MsgWindowLoseMouseFocus t _) = t
+ msgTime (MsgWindowGainKeyboardFocus t _) = t
+ msgTime (MsgWindowLoseKeyboardFocus t _) = t
+ msgTime (MsgWindowClose t _) = t
diff --git a/extern/affection/src/Affection/StateMachine.hs b/extern/affection/src/Affection/StateMachine.hs
new file mode 100644
index 0000000..7d9ab55
--- /dev/null
+++ b/extern/affection/src/Affection/StateMachine.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Affection.StateMachine where
+
+import Affection.Types
+
+import qualified SDL
+
+-- | Typeclass for simple scaffolding of a state machine
+class StateMachine us a where
+ -- | State load routine
+ smLoad :: a -> us -> Affection ()
+ -- | state update routine
+ smUpdate :: a -> us -> Double -> Affection ()
+ -- | State event handler routine
+ smEvent :: a -> us -> [SDL.EventPayload] -> Affection ()
+ -- | State draw routine
+ smDraw :: a -> us -> Affection ()
+ -- | State clean routine
+ smClean :: a -> us -> Affection ()
diff --git a/extern/affection/src/Affection/Subsystems.hs b/extern/affection/src/Affection/Subsystems.hs
new file mode 100644
index 0000000..e48fa3e
--- /dev/null
+++ b/extern/affection/src/Affection/Subsystems.hs
@@ -0,0 +1,9 @@
+module Affection.Subsystems
+ ( module S
+ ) where
+
+import Affection.Subsystems.Class as S
+import Affection.Subsystems.AffectionKeyboard as S
+import Affection.Subsystems.AffectionWindow as S
+import Affection.Subsystems.AffectionMouse as S
+import Affection.Subsystems.AffectionJoystick as S
diff --git a/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs b/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs
new file mode 100644
index 0000000..9d75258
--- /dev/null
+++ b/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Affection.Subsystems.AffectionJoystick where
+
+import Affection.MessageBus
+import Affection.Types
+import Affection.Util
+import Affection.Logging
+
+import Control.Monad (filterM)
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Data.Vector as V
+import Data.String as S (fromString)
+
+import Foreign.C.Types (CInt(..))
+
+import qualified SDL
+
+-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
+-- and emits appropriate 'JoystickMessage's
+consumeSDLJoystickEvents
+ :: forall am. (Participant am, Mesg am ~ JoystickMessage)
+ => am -- ^ The message system participant
+ -> [SDL.EventPayload] -- ^ Incoming events
+ -> Affection [SDL.EventPayload] -- ^ Leftover SDL events
+consumeSDLJoystickEvents am = doConsume
+ where
+ doConsume
+ :: [SDL.EventPayload]
+ -> Affection [SDL.EventPayload]
+ doConsume [] = return []
+ doConsume (e:es) = do
+ ts <- getElapsedTime
+ case e of
+ SDL.JoyAxisEvent dat -> do
+ partEmit am (MsgJoystickAxis
+ ts
+ (SDL.joyAxisEventWhich dat)
+ (SDL.joyAxisEventAxis dat)
+ (SDL.joyAxisEventValue dat)
+ )
+ doConsume es
+ SDL.JoyBallEvent dat -> do
+ partEmit am (MsgJoystickBall
+ ts
+ (SDL.joyBallEventWhich dat)
+ (SDL.joyBallEventBall dat)
+ (SDL.joyBallEventRelMotion dat)
+ )
+ doConsume es
+ SDL.JoyHatEvent dat -> do
+ partEmit am (MsgJoystickHat
+ ts
+ (SDL.joyHatEventWhich dat)
+ (SDL.joyHatEventHat dat)
+ (SDL.joyHatEventValue dat)
+ )
+ doConsume es
+ SDL.JoyButtonEvent dat -> do
+ partEmit am (MsgJoystickButton
+ ts
+ (SDL.joyButtonEventWhich dat)
+ (SDL.joyButtonEventButton dat)
+ (SDL.joyButtonEventState dat)
+ )
+ doConsume es
+ SDL.JoyDeviceEvent dat -> do
+ partEmit am (MsgJoystickDevice
+ ts
+ (SDL.joyDeviceEventWhich dat)
+ (SDL.joyDeviceEventConnection dat)
+ )
+ doConsume es
+ _ -> fmap (e :) (doConsume es)
+
+-- | Helper function to automatically connect and open newly attached joystick
+-- devices
+joystickAutoConnect
+ :: JoystickMessage -- ^ Any 'JoystickMessage' will do,
+ -- but listens only on 'MsgJoystickDevice' messages
+ -> Affection (Maybe SDL.Joystick)
+ -- ^ Returns a joystick descriptor, if successful
+joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
+ [descr] <- V.toList <$>
+ (V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
+ SDL.availableJoysticks)
+ logIO Verbose $ "Connecting Joystick " <> fromString (show which) <> " " <>
+ fromString (show descr)
+ Just <$> SDL.openJoystick descr
+joystickAutoConnect _ = return Nothing
+
+-- | Helper function to automatically close and disconnect freshly detached
+-- joystick devices
+joystickAutoDisconnect
+ :: [SDL.Joystick] -- ^ List of Joystick descriptors
+ -> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens
+ -- specifically to 'MsgJoystickDevice' messages
+ -> Affection [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
+joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
+ liftIO $ do
+ joyIds <- mapM SDL.getJoystickID js
+ logIO Verbose $ "These are the Joysticks connected: " <>
+ fromString (show joyIds)
+ d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js
+ if not (null d)
+ then do
+ logIO Verbose $ "disconnected joysticks: " <> fromString (show $ head d)
+ logIO Verbose $ "Disconnecting Joystick " <> fromString (show which)
+ SDL.closeJoystick (head d)
+ njoys <- filterM (\j -> return $ head d /= j) js
+ logIO Verbose $ "returning joysticks: " <> fromString (show njoys)
+ return njoys
+ else do
+ logIO Error $ "Error while disconnecting Joystick"
+ return js
+joystickAutoDisconnect js _ = return js
diff --git a/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs b/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs
new file mode 100644
index 0000000..a78ccda
--- /dev/null
+++ b/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Affection.Subsystems.AffectionKeyboard where
+
+import Affection.Types
+import Affection.Util
+import Affection.MessageBus
+
+import qualified SDL
+
+-- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's
+-- and emits appropriate 'KeyboardMessage's
+consumeSDLKeyboardEvents
+ :: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage)
+ => ak -- ^ The message system participant
+ -> [SDL.EventPayload] -- ^ Incoming events
+ -> Affection [SDL.EventPayload] -- ^ Leftover SDL Events
+consumeSDLKeyboardEvents ak = doConsume
+ where
+ doConsume [] = return []
+ doConsume (e:es) = do
+ ts <- getElapsedTime
+ case e of
+ SDL.KeyboardEvent dat -> do
+ partEmit ak (MsgKeyboardEvent
+ ts
+ (SDL.keyboardEventWindow dat)
+ (SDL.keyboardEventKeyMotion dat)
+ (SDL.keyboardEventRepeat dat)
+ (SDL.keyboardEventKeysym dat)
+ )
+ doConsume es
+ _ -> fmap (e :) (doConsume es)
diff --git a/extern/affection/src/Affection/Subsystems/AffectionMouse.hs b/extern/affection/src/Affection/Subsystems/AffectionMouse.hs
new file mode 100644
index 0000000..6f6a599
--- /dev/null
+++ b/extern/affection/src/Affection/Subsystems/AffectionMouse.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Affection.Subsystems.AffectionMouse where
+
+import Affection.MessageBus
+import Affection.Types
+import Affection.Util
+
+import Linear.Affine (unP)
+
+import qualified SDL
+
+-- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's
+-- and emits appropriate 'MouseMessage's
+consumeSDLMouseEvents
+ :: forall am. (Participant am, Mesg am ~ MouseMessage)
+ => am -- ^ The message system participant
+ -> [SDL.EventPayload] -- ^ Incoming events
+ -> Affection [SDL.EventPayload] -- ^ Leftover SDL events
+consumeSDLMouseEvents am = doConsume
+ where
+ doConsume
+ :: [SDL.EventPayload]
+ -> Affection [SDL.EventPayload]
+ doConsume [] = return []
+ doConsume (e:es) = do
+ ts <- getElapsedTime
+ case e of
+ SDL.MouseMotionEvent dat -> do
+ partEmit am (MsgMouseMotion
+ ts
+ (SDL.mouseMotionEventWindow dat)
+ (SDL.mouseMotionEventWhich dat)
+ (SDL.mouseMotionEventState dat)
+ (unP $ SDL.mouseMotionEventPos dat)
+ (SDL.mouseMotionEventRelMotion dat)
+ )
+ doConsume es
+ SDL.MouseButtonEvent dat -> do
+ partEmit am (MsgMouseButton
+ ts
+ (SDL.mouseButtonEventWindow dat)
+ (SDL.mouseButtonEventMotion dat)
+ (SDL.mouseButtonEventWhich dat)
+ (SDL.mouseButtonEventButton dat)
+ (SDL.mouseButtonEventClicks dat)
+ (unP $ SDL.mouseButtonEventPos dat)
+ )
+ doConsume es
+ SDL.MouseWheelEvent dat -> do
+ partEmit am (MsgMouseWheel
+ ts
+ (SDL.mouseWheelEventWindow dat)
+ (SDL.mouseWheelEventWhich dat)
+ (SDL.mouseWheelEventPos dat)
+ (SDL.mouseWheelEventDirection dat)
+ )
+ doConsume es
+ _ -> fmap (e :) (doConsume es)
diff --git a/extern/affection/src/Affection/Subsystems/AffectionWindow.hs b/extern/affection/src/Affection/Subsystems/AffectionWindow.hs
new file mode 100644
index 0000000..f59e00c
--- /dev/null
+++ b/extern/affection/src/Affection/Subsystems/AffectionWindow.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Affection.Subsystems.AffectionWindow where
+
+import Affection.Types
+import Affection.Util
+import Affection.MessageBus
+
+import qualified SDL
+
+-- | Helper function that consumes all Window-related 'SDL.EventPayload's
+-- and emits appropriate 'WindowMessage's.
+consumeSDLWindowEvents
+ :: forall aw. (Participant aw, Mesg aw ~ WindowMessage)
+ => aw -- ^ The message system participant
+ -> [SDL.EventPayload] -- ^ Incoming events
+ -> Affection [SDL.EventPayload] -- ^ Leftover SDL events
+consumeSDLWindowEvents aw = doConsume
+ where
+ doConsume
+ :: (Mesg aw ~ WindowMessage)
+ => [SDL.EventPayload]
+ -> Affection [SDL.EventPayload]
+ doConsume [] = return []
+ doConsume (e:es) = do
+ ts <- getElapsedTime
+ case e of
+ SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
+ partEmit aw (MsgWindowShow ts window)
+ doConsume es
+ SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
+ partEmit aw (MsgWindowHide ts window)
+ doConsume es
+ SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
+ partEmit aw (MsgWindowExpose ts window)
+ doConsume es
+ SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
+ partEmit aw (MsgWindowMove ts window newPos)
+ doConsume es
+ SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
+ partEmit aw (MsgWindowResize ts window newSize)
+ doConsume es
+ SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window size) -> do
+ partEmit aw (MsgWindowSizeChange ts window size)
+ doConsume es
+ SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
+ partEmit aw (MsgWindowMinimize ts window)
+ doConsume es
+ SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
+ partEmit aw (MsgWindowMaximize ts window)
+ doConsume es
+ SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
+ partEmit aw (MsgWindowRestore ts window)
+ doConsume es
+ SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
+ partEmit aw (MsgWindowGainMouseFocus ts window)
+ doConsume es
+ SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
+ partEmit aw (MsgWindowLoseMouseFocus ts window)
+ doConsume es
+ SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
+ partEmit aw (MsgWindowGainKeyboardFocus ts window)
+ doConsume es
+ SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
+ partEmit aw (MsgWindowLoseKeyboardFocus ts window)
+ doConsume es
+ SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
+ partEmit aw (MsgWindowClose ts window)
+ doConsume es
+ _ -> fmap (e :) (doConsume es)
diff --git a/extern/affection/src/Affection/Subsystems/Class.hs b/extern/affection/src/Affection/Subsystems/Class.hs
new file mode 100644
index 0000000..ec55ae3
--- /dev/null
+++ b/extern/affection/src/Affection/Subsystems/Class.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Affection.Subsystems.Class where
+
+import Affection.Types
+
+import qualified SDL
+
+-- | This class denotes a Subsystem to be part of SDL
+class SDLSubsystem s where
+ -- | Consume the given 'SDL.EventPayload's and return only those not
+ -- recognised
+ consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]
diff --git a/extern/affection/src/Affection/Types.hs b/extern/affection/src/Affection/Types.hs
new file mode 100644
index 0000000..a7d8eb4
--- /dev/null
+++ b/extern/affection/src/Affection/Types.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
+module Affection.Types
+ ( Affection
+ , AffectionConfig(..)
+ , AffectionData(..)
+ , AffectionStateInner
+ , AffectionState(..)
+ , InitComponents(..)
+ , Angle
+ -- | SDL reexports
+ , SDL.WindowConfig(..)
+ , SDL.WindowMode(..)
+ , SDL.EventPayload(..)
+ , SDL.InitFlag(..)
+ , SDL.Window
+ , SDL.GLContext
+ ) where
+
+import qualified SDL.Init as SDL
+import qualified SDL.Video as SDL
+import qualified SDL.Event as SDL
+import qualified Data.Text as T
+
+import Control.Monad.IO.Class
+import Control.Monad.State.Strict
+import qualified Control.Monad.Parallel as MP
+
+import System.Clock (TimeSpec)
+
+-- | Configuration for the aplication. needed at startup.
+data AffectionConfig us = AffectionConfig
+ { initComponents :: InitComponents
+ -- ^ SDL components to initialize at startup
+ , windowTitle :: T.Text
+ -- ^ Window title
+ , windowConfigs ::
+ [
+ ( Word -- --^ Window identifier
+ , SDL.WindowConfig -- --^ Window config for given window
+ , SDL.WindowMode -- -- ^ Window mode to start in
+ )
+ ]
+ -- ^ Window configurations
+ }
+
+-- | Components to initialize in SDL.
+data InitComponents
+ = All
+ | Only [SDL.InitFlag]
+
+-- | 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?
+ }
+
+-- | Inner 'StateT' monad for the update state
+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)
+
+instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
+
+type Affection a = AffectionState AffectionData IO a
+
+type Angle = Double
diff --git a/extern/affection/src/Affection/Util.hs b/extern/affection/src/Affection/Util.hs
new file mode 100644
index 0000000..763f0ee
--- /dev/null
+++ b/extern/affection/src/Affection/Util.hs
@@ -0,0 +1,86 @@
+module Affection.Util where
+
+import Affection.Types
+import Affection.Logging
+import Affection.MessageBus.Message.WindowMessage
+
+import SDL (($=))
+import qualified SDL
+import qualified Graphics.Rendering.OpenGL as GL
+
+import System.Clock
+
+import Data.String (fromString)
+import Data.List (find)
+
+import Control.Monad.State
+
+-- | Prehandle SDL events
+preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload]
+preHandleEvents evs =
+ return $ map SDL.eventPayload evs
+
+-- | block a thread for a specified amount of time
+delaySec
+ :: Int -- ^ Number of seconds
+ -> IO ()
+delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
+
+-- | Get time since start but always the same in the current tick.
+getElapsedTime :: Affection Double
+getElapsedTime = gets elapsedTime
+
+-- | Get delta time (time elapsed from last frame)
+getDelta :: Affection Double
+getDelta = gets deltaTime
+
+-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
+-- Pauses the Engine in the process.
+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))
+
+-- | Fit the GL Viewport to Window size
+fitViewport
+ :: Double -- ^ Image Ratio (width / height)
+ -> WindowMessage -- ^ Incoming Message. Listens only on
+ -- 'MsgWindowResize' and ignores all others.
+ -> Affection ()
+fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
+ liftIO $ logIO Verbose "Fitting Viewport to size"
+ if (fromIntegral w / fromIntegral h) > ratio
+ then do
+ let nw = floor (fromIntegral h * ratio)
+ dw = floor ((fromIntegral w - fromIntegral nw) / 2 :: Double)
+ GL.viewport $= (GL.Position dw 0, GL.Size nw h)
+ else do
+ let nh = floor (fromIntegral w / ratio)
+ dh = floor ((fromIntegral h - fromIntegral nh) / 2 :: Double)
+ GL.viewport $= (GL.Position 0 dh, GL.Size w nh)
+fitViewport _ _ = return ()