make it run, not work

.envrc

@@ -1 +0,0 @@
-use flake

.gitignore

@@ -14,5 +14,3 @@ dist/
 *.prof
 *.ps
 *.html
-.direnv/
-result

cabal.project

@@ -1,5 +1,6 @@
 packages:
   ./
+  ./extern/*
 
 constraints:
   affection +verbose

extern/affection/.gitignore

@@ -0,0 +1,20 @@
+*.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
+.direnv/
+.envrc

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.

extern/affection/LICENSE

@@ -0,0 +1,165 @@
+                  GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ 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.

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.

extern/affection/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

extern/affection/affection.cabal

@@ -0,0 +1,179 @@
+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
+                     , OpenGLRaw
+                     , stm
+                     , uuid
+                     , vector
+                     , resourcet
+
+-- 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
+  build-depends:     base >=4.9 && < 5
+                   , affection
+                   , sdl2 >= 2.5
+                   , stm
+  if !flag(examples)
+    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
+  build-depends:     base >=4.9 && < 5
+                   , affection
+                   , sdl2 >= 2.5
+                   , stm
+                   , OpenGL
+                   , random
+                   , containers
+                   , linear
+                   , matrix
+                   , nanovg >= 0.6.0.0
+                   , deepseq
+  if !flag(examples)
+    buildable:       False
+
+-- Another small game of life implementation
+executable example02
+  hs-source-dirs:    examples/example02
+  main-is:           Main.hs
+  other-modules:     Types
+  ghc-options:       -threaded -Wall
+  default-language:  Haskell2010
+  default-extensions: OverloadedStrings
+  build-depends:     base >=4.9 && < 5
+                   , affection
+                   , sdl2 >= 2.5
+                   , stm
+                   , OpenGL
+                   , random
+                   , containers
+                   , linear
+                   , matrix
+                   , nanovg >= 0.6.0.0
+                   , deepseq
+  if !flag(examples)
+    buildable:       False

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;
+}

extern/affection/cabal.project

@@ -0,0 +1,4 @@
+constraints: affection +verbose
+profiling: true
+packages:
+  ./.

extern/affection/default.nix

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

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

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 ()

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

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 ()

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

extern/affection/shell.nix

@@ -0,0 +1,7 @@
+{ pkgs ? import <nixpkgs> {}}:
+
+let
+  affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
+  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
+in
+  affection.env

extern/affection/src/Affection.hs

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

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

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 ()

extern/affection/src/Affection/MessageBus.hs

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

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

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

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

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

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

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

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

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 ()

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

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

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)

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)

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)

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]

extern/affection/src/Affection/Types.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
+module Affection.Types 
+  ( Affection
+  , AffectionConfig(..)
+  , AffectionData(..)
+  , AffectionStateInner
+  , AffectionState(..)
+  , AffectionWindow(..)
+  , AffectionContext(..)
+  , 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 Control.Monad.Trans.Resource
+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     :: [ AffectionWindow ]  -- ^ SDL windows
+  , glContext       :: [ AffectionContext ] -- ^ OpenGL rendering contexts
+  , elapsedTime     :: Double               -- ^ Elapsed time in seconds
+  , deltaTime       :: Double               -- ^ Elapsed time in seconds since last tick
+  , sysTime         :: TimeSpec             -- ^ System time (NOT the time on the clock)
+  , pausedTime      :: Bool                 -- ^ Should the update loop be executed?
+  }
+
+-- | Inner 'StateT' monad for the update state
+type AffectionStateInner sd m = StateT sd m
+
+-- | Affection's state monad
+newtype AffectionState sd m a = AffectionState
+  { runState :: AffectionStateInner sd m a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
+
+instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
+
+type Affection a = AffectionState AffectionData ResIO a
+
+type Angle = Double
+
+data AffectionWindow = AffectionWindow
+  { awWindow     :: SDL.Window
+  , awReleaseKey :: ReleaseKey
+  , awMode       :: SDL.WindowMode
+  }
+
+data AffectionContext = AffectionContext
+  { acContext    :: SDL.GLContext
+  , acReleaseKey :: ReleaseKey
+  }

extern/affection/src/Affection/Util.hs

@@ -0,0 +1,89 @@
+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
+  (stop, alteredWindowList) <- foldM
+    (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
+      if stop || num == windowIdent
+      then do
+        newMode <- case mode of
+          SDL.FullscreenDesktop -> do
+            liftIO $ SDL.setWindowMode window SDL.Windowed
+            return SDL.Windowed
+          SDL.Windowed -> do
+            liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
+            return SDL.FullscreenDesktop
+          x -> do
+            liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
+            return x
+        return (True, resWindows ++ [aw { awMode = newMode }])
+      else
+        return (stop, resWindows ++ [aw])
+      )
+    (False, [])
+    (zip [0..] (drawWindows ad))
+  if stop
+  then do
+    now <- liftIO $ getTime Monotonic
+    put ad
+      { sysTime = now
+      , drawWindows = alteredWindowList
+      }
+  else
+    liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
+
+-- | Fit the GL Viewport to Window size
+fitViewport
+  :: 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 ()

extern/flake.lock

@@ -0,0 +1,42 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "locked": {
+        "lastModified": 1667395993,
+        "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1669901374,
+        "narHash": "sha256-lObvfluyiZ9cgCMgKSrUOjzbx9Oap9949jlnNRPPYqg=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "1c5443f6cdce419174f198141bd76a3fd9502950",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

extern/flake.nix

@@ -0,0 +1,61 @@
+{
+  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 = packages.${packageName}.env;
+        devShell = pkgs.mkShell {
+          buildInputs = with haskellPackages; [
+            haskell-language-server
+            ghcid
+            cabal-install
+          ];
+          nativeBuildInputs = with pkgs; [
+            pkg-config
+            glib
+            SDL2
+            freetype
+            glew
+          ];
+          inputsFrom = builtins.attrValues self.packages.${system};
+        };
+      });
+}
+

flake.lock

@@ -1,31 +1,28 @@
 {
   "nodes": {
-    "affection-src": {
+    "affection-local": {
       "inputs": {
         "flake-utils": "flake-utils",
         "nixpkgs": "nixpkgs"
       },
       "locked": {
-        "lastModified": 1679777510,
-        "narHash": "sha256-FXtXhmUWtBt8944WIAXgB3OuIT446vUvfmccobXu6ts=",
-        "ref": "refs/heads/master",
-        "rev": "445b5807e021ff6fb70fdfa3f7e6a0a2b2221609",
-        "revCount": 300,
-        "type": "git",
-        "url": "https://gitea.nek0.eu/nek0/affection"
+        "lastModified": 1,
+        "narHash": "sha256-jml+z0oNeFXjYreNdEMVmYPuFlDmxuYyXBZQ573Tido=",
+        "path": "./extern/affection",
+        "type": "path"
       },
       "original": {
-        "type": "git",
-        "url": "https://gitea.nek0.eu/nek0/affection"
+        "path": "./extern/affection",
+        "type": "path"
       }
     },
     "flake-utils": {
       "locked": {
-        "lastModified": 1678901627,
-        "narHash": "sha256-U02riOqrKKzwjsxc/400XnElV+UtPUQWpANPlyazjH0=",
+        "lastModified": 1667395993,
+        "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "93a2b84fc4b70d9e089d029deacc3583435c2ed6",
+        "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
         "type": "github"
       },
       "original": {
@@ -35,15 +32,12 @@
       }
     },
     "flake-utils_2": {
-      "inputs": {
-        "systems": "systems"
-      },
       "locked": {
-        "lastModified": 1681202837,
-        "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=",
+        "lastModified": 1667395993,
+        "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "cfacdce06f30d2b68473a46042957675eebb3401",
+        "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
         "type": "github"
       },
       "original": {
@@ -54,11 +48,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1679747397,
-        "narHash": "sha256-btdjcq9pGJyKNbU5qQpKfWdEwoj+uazeSpchJjHrt3k=",
+        "lastModified": 1669901374,
+        "narHash": "sha256-lObvfluyiZ9cgCMgKSrUOjzbx9Oap9949jlnNRPPYqg=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "e235465058f37b1a4f222957352c1e373905521d",
+        "rev": "1c5443f6cdce419174f198141bd76a3fd9502950",
         "type": "github"
       },
       "original": {
@@ -69,11 +63,11 @@
     },
     "nixpkgs_2": {
       "locked": {
-        "lastModified": 1681963077,
-        "narHash": "sha256-8uJm8D6bJ7HEUkeHiWYbSfYKKhEIcgCsp/FQaGTS8RM=",
+        "lastModified": 1671901901,
+        "narHash": "sha256-dTeqgnX1HfTeQ3+VtCXB3/t/ilE5iWmjYucwgSvpwnQ=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "7ddf6698abe1eec2479590144701ca88fe2fcfe9",
+        "rev": "b1a9ae8dfd85d144ff1b268d6c7b47934358c9a1",
         "type": "github"
       },
       "original": {
@@ -84,25 +78,10 @@
     },
     "root": {
       "inputs": {
-        "affection-src": "affection-src",
+        "affection-local": "affection-local",
         "flake-utils": "flake-utils_2",
         "nixpkgs": "nixpkgs_2"
       }
-    },
-    "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",

flake.nix

@@ -4,10 +4,10 @@
   inputs = {
     nixpkgs.url = "github:NixOS/nixpkgs";
     flake-utils.url = "github:numtide/flake-utils";
-    affection-src.url = "git+https://gitea.nek0.eu/nek0/affection";
+    affection-local.url = "path:./extern/affection";
   };
 
-  outputs = { self, nixpkgs, flake-utils, affection-src }:
+  outputs = { self, nixpkgs, flake-utils, affection-local }:
     flake-utils.lib.eachDefaultSystem (system:
       let
         pkgs = nixpkgs.legacyPackages.${system};
@@ -22,7 +22,7 @@
         packages.${packageName} = # (ref:haskell-package-def)
           haskellPackages.callCabal2nix packageName self rec {
             # Dependency overrides go here
-            affection = affection-src.defaultPackage.${system};
+            affection = affection-local.defaultPackage.${system};
           };
 
         defaultPackage = self.packages.${system}.${packageName};

shell.nix

@@ -1,16 +1,53 @@
-{ pkgs ? import <nixpkgs> {}}:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
 
 let
-  # create a modified haskell package set with my package inside it and broken dependencies
-  # jailbroken.
-  hpkgs = pkgs.haskellPackages.override {
-    overrides = hself: hsuper: {
-      pituicat = hself.callCabal2nix "mateamt" (gitignore ./.) {};
-      affection = hself.callCabal2nix "affection" (gitignore ./extern/affection) {};
-      #pg-transact = with pkgs.haskell.lib;
-      #  doJailbreak (unmarkBroken (dontCheck hsuper.pg-transact));
-    };
-  };
-  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
+
+  inherit (nixpkgs) pkgs;
+
+  affection = with haskellPackages; callPackage(
+    { 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.10";
+      src = ./extern/affection;
+      configureFlags = [ "-fverbose" ];
+      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 = pkgs.lib.licenses.lgpl3;
+    }) {};
+
+  f = { mkDerivation, aeson, base, bytestring, containers, derive-storable
+      , JuicyPixels, JuicyPixels-extra, linear, monad-loops, OpenGL, OpenGLRaw
+      , stdenv, sdl2, StateVar, stm, text, vector}:
+      mkDerivation {
+        pname = "pituicat";
+        version = "0.0.0.0";
+        src = ./.;
+        isLibrary = false;
+        isExecutable = true;
+        executableHaskellDepends = [ aeson affection base bytestring containers
+        derive-storable JuicyPixels JuicyPixels-extra linear monad-loops OpenGL
+        OpenGLRaw sdl2 StateVar stm text vector];
+        license = pkgs.lib.licenses.gpl3;
+      };
+
+  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
-  hpkgs.pituicat.env
+
+  if pkgs.lib.inNixShell then drv.env else drv

src/Map.hs

@@ -46,25 +46,24 @@ readLayer (_, path) (V2 tx ty) = do
   let width = imageWidth img
       height = imageHeight img
       layer = V.foldl
-        (\acc (py, px) -> case (pixelAt img px py) of
+        (\acc (py, px) -> case pixelAt img px py of
           (PixelRGBA8 r g b _) -> if r >= 253
             then
               acc `V.snoc` Tile
                (V2 (fromIntegral px) (fromIntegral py))
-               ( (V2
+               ( V2
                    ((255 - fromIntegral g) * (32 / tx))
                    (1 - (255 - fromIntegral b + 1) * (32 / ty))
-                   )
-               , (V2
+               , V2
                    ((255 - fromIntegral g + 1) * (32 / tx))
                    (1 - (255 - fromIntegral b) * (32 / ty))
-                   )
                  )
                (case r of
                  255 -> Solid
                  254 -> Platform
                  _   -> Decoration
                  )
+               False
             else
               acc
           )

src/Physics/Classes/Collidible.hs

@@ -6,20 +6,16 @@ import Affection as A
 
 import Linear
 
-import Data.String (fromString)
-
-import Data.List (sortBy)
-
 -- internal imports
 
 import Physics.Classes.Mass
 
-data CollisionResult time direction
+data CollisionResult direction
   = NoCollision
-  | CollisionImminent
-    { collisionTime :: time
-    , collisionDirection :: direction
-    }
+  -- | CollisionImminent
+  --   { collisionTime :: time
+  --   , collisionDirection :: direction
+  --   }
   | OverlapCollision
     { collisionDepth :: direction
     }
@@ -28,6 +24,33 @@ data CollisionResult time direction
 -- | Typeclass for implementing collision results on objects.
 class (Show c, Mass c) => Collidible c where
 
+  -- | Final position of the object in the previous timestep
+  prevPosition :: c -> V2 Double
+
+  -- | Aggregated impact forces in a simulation step
+  impactForces :: c -> V2 Double
+
+  -- | Overwrite the impact forces of the mass object
+  impactForcesUpdater :: c -> (V2 Double -> c)
+
+  -- | reset impact forces vector at the beginning of a simulation step
+  resetImpactForces :: c -> c
+  resetImpactForces c = impactForcesUpdater c (V2 0 0)
+
+  -- | Add a impact force to the impact forces acting on the mass object
+  addImpactForce
+    :: c
+    -> V2 Double
+    -> c
+  addImpactForce c force =
+    impactForcesUpdater c (impactForces c + force)
+
+  -- | Flag indicating a collision during the current time step
+  collisionOccured :: c -> Bool
+
+  -- | Update the collision occurence flag
+  updateCollisionOccurence :: c -> Bool -> c
+
   -- | returns the bottom left and top right corners relative to the objects
   -- positional vector of the axis aligned bounding box (AABB) serving here
   -- as collision boundaries.
@@ -39,233 +62,75 @@ class (Show c, Mass c) => Collidible c where
 
   collisionCheck
     :: (Collidible other)
-    => Double                          -- ^ Time step length
-    -> c                               -- ^ First object
+    => c                               -- ^ First object
     -> other                           -- ^ second object
-    -> CollisionResult Double (V2 Int) -- ^ Do the objects collide?
-  collisionCheck dt m1 m2 =
-    let d1@(V2 d1x d1y) = velocity m1
-        d2@(V2 d2x d2y) = velocity m2
-        p1@(V2 p1x p1y) = position m1
-        p2@(V2 p2x p2y) = position m2
-        (m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1
-        (m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2
-        (V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = (p1 +) <$> boundary m1
-        (V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = (p2 +) <$> boundary m2
-        m1p1@(V2 m1p1x m1p1y) = p1 + m1b1
-        m1p2 = p1 + V2 m1b1x m1b2y
-        m1p3@(V2 m1p3x m1p3y) = p1 + m1b2
-        m1p4@(V2 m1p4x _) = p1 + V2 m1b2x m1b1y
-        m2p1@(V2 m2p1x m2p1y) = p2 + m2b1
-        m2p2 = p2 + V2 m2b1x m2b2y
-        m2p3@(V2 m2p3x m2p3y) = p2 + m2b2
-        m2p4 = p2 + V2 m2b2x m2b1y
-        (V2 b1minx b1miny, V2 b1maxx b1maxy) =
-          ( V2
-            ((\(V2 x _) -> x) (if d1x < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
-            ((\(V2 _ y) -> y) (if d1y < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
-          , V2
-            ((\(V2 x _) -> x) (if d1x < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
-            ((\(V2 _ y) -> y) (if d1y < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
-          )
-        (V2 b2minx b2miny, V2 b2maxx b2maxy) =
-          ( V2
-            ((\(V2 x _) -> x) (if d2x < 0 then m2p1 + ((dt *) <$> d2) else m2p1))
-            ((\(V2 _ y) -> y) (if d2y < 0 then m2p1 + ((dt *) <$> d2) else m2p1))
-          , V2
-            ((\(V2 x _) -> x) (if d2x < 0 then m2p3 else m2p3 + ((dt *) <$> d2)))
-            ((\(V2 _ y) -> y) (if d2y < 0 then m2p3 else m2p3 + ((dt *) <$> d2)))
-          )
-        broadphaseOverlap =
-          let in2 =
-                (b1minx > b2minx && b1minx < b2maxx &&
-                  b1miny > b2miny && b1miny < b2maxy) ||
-                (b1maxx > b2minx && b1maxx < b2maxx &&
-                  b1miny > b2miny && b1miny < b2maxy) ||
-                (b1minx > b2minx && b1minx < b2maxx &&
-                  b1maxy > b2miny && b1maxy < b2maxy) ||
-                (b1maxx > b2minx && b1maxx < b2maxx &&
-                  b1maxy > b2miny && b1maxy < b2maxy)
-              in1 =
-                (b2minx > b1minx && b2minx < b1maxx &&
-                  b2miny > b1miny && b2miny < b1maxy) ||
-                (b2maxx > b1minx && b2maxx < b1maxx &&
-                  b2miny > b1miny && b2miny < b1maxy) ||
-                (b2minx > b1minx && b2minx < b1maxx &&
-                  b2maxy > b1miny && b2maxy < b1maxy) ||
-                (b2maxx > b1minx && b2maxx < b1maxx &&
-                  b2maxy > b1miny && b2maxy < b1maxy)
-          in
-            in2 || in1
-        overlap =
-          let in1 =
-                (pm1b1x > pm2b1x && pm1b1x < pm2b2x &&
-                  pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
-                (pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
-                  pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
-                (pm1b1x > pm2b1x && pm1b2x < pm2b2x &&
-                  pm1b2y > pm2b1y && pm1b2y < pm2b2y) ||
-                (pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
-                  pm1b2y > pm2b1y && pm1b2y < pm2b2y)
-              in2 =
-                (pm2b1x > pm1b1x && pm2b1x < pm1b2x &&
-                  pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
-                (pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
-                  pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
-                (pm2b1x > pm1b1x && pm2b2x < pm1b2x &&
-                  pm2b2y > pm1b1y && pm2b2y < pm1b2y) ||
-                (pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
-                  pm2b2y > pm1b1y && pm2b2y < pm1b2y)
-          in
-            in2 || in1
-        tx =
-          let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p4)
-              p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1)
-          in
-            if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x)
-        ty =
-          let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p2)
-              p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p2 else m2p1)
-          in
-            if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y)
+    -> CollisionResult (V2 Double) -- ^ Do the objects collide?
+  collisionCheck m1 m2 =
+    let (V2 p1x p1y)                      = position m1
+        (V2 p2x p2y)                      = position m2
+        (V2 b1minx b1miny, V2 b1maxx b1maxy) = boundary m1
+        (V2 b2minx b2miny, V2 b2maxx b2maxy) = boundary m2
+        getCoordinates
+          | p1x <= p2x && p1y <= p2y =
+            let x1 = p1x + b1maxx
+                y1 = p1y + b1maxy
+                x2 = p2x + b2minx
+                y2 = p2y + b2minx
+            in (x1, y1, x2, y2)
+          | p1x > p2x && p1y <= p2y =
+            let x1 = p1x + b1minx
+                y1 = p1y + b1maxy
+                x2 = p2x + b2maxx
+                y2 = p2y + b2miny
+            in (x1, y1, x2, y2)
+          | p1x <= p2x && p1y > p2y =
+            let x1 = p1x + b1maxx
+                y1 = p1y + b1miny
+                x2 = p2x + b2minx
+                y2 = p2y + b2maxy
+            in (x1, y1, x2, y2)
+          | otherwise =
+            let x1 = p1x + b1minx
+                y1 = p1y + b1miny
+                x2 = p2x + b2maxx
+                y2 = p2y + b2maxy
+            in (x1, y1, x2, y2)
+        (ox1, oy1, ox2, oy2) = getCoordinates
     in
-      if broadphaseOverlap
-        then
-          let coll xdir =
-                let (p11, p12, p21, p22)
-                      | xdir =
-                        if d1x < 0
-                        then
-                          (m1p1, m1p2, m2p4, m2p3)
-                        else
-                          (m1p4, m1p3, m2p1, m2p2)
-                      | otherwise =
-                        if d1y < 0
-                        then
-                          (m1p1, m1p4, m2p2, m2p3)
-                        else
-                          (m1p2, m1p3, m2p1, m2p4)
-                    vselector (V2 x y) = if xdir then y else x
-                    tick = if xdir then tx else ty
-                    g1s = vselector $ p11 + ((tick *) <$> d1)
-                    g1e = vselector $ p12 + ((tick *) <$> d1)
-                    g2s = vselector $ p21 + ((tick *) <$> d2)
-                    g2e = vselector $ p22 + ((tick *) <$> d2)
-                    s11 = (g1s - g2s) / (g2e - g2s)
-                    s12 = (g1e - g2s) / (g2e - g2s)
-                    s21 = (g2s - g1s) / (g1e - g1s)
-                    s22 = (g2e - g1s) / (g1e - g1s)
-                in
-                  any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
-              res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of
-                  (True, _, True, True, _) ->
-                    CollisionImminent tx (V2 (floor $ signum d1x) 0)
-                  (_, True, False, _, True) ->
-                    CollisionImminent ty (V2 0 (floor $ signum d1y))
-                  (True, _, False, True, False) ->
-                    CollisionImminent tx (V2 (floor $ signum d1x) 0)
-                  (_, True, True, False, True) ->
-                    CollisionImminent ty (V2 0 (floor $ signum d1y))
-                  (_, _, _, False, False) ->
-                    NoCollision
-                  (_, _, True, _, _) ->
-                    A.log A.Debug "CORNER CASE!" NoCollision
-                  (False, False, _, _, _) ->
-                    NoCollision
-                  x -> error $
-                    "Unhandled combination of collision check results: "
-                    <> fromString (show x)
-          in
-            case res of
-              CollisionImminent _ _ ->
-                res
-              NoCollision ->
-                if overlap
-                then
-                  let xoverlap = floor (maximum (filter (0 >)
-                        [ pm2b2x - pm2b1x
-                        , pm2b1x - pm1b2x
-                        ]))
-                      yoverlap = floor (maximum (filter (0 >)
-                        [ pm2b1y - pm1b2y
-                        , pm2b2y - pm1b1y
-                        ]))
-                  in
-                    if xoverlap < yoverlap
-                    then
-                      if xoverlap < 0
-                      then OverlapCollision
-                        (V2 xoverlap 0)
-                      else
-                        NoCollision
-                    else
-                      if yoverlap < 0
-                      then OverlapCollision
-                        (V2 0 yoverlap)
-                      else NoCollision
-                else NoCollision
-              _ -> A.log
-                A.Error
-                "Premature overlap collision detection"
-                NoCollision
-        else
-          NoCollision
+      if ox2 - ox1 < 0 || oy2 - oy1 < 0
+      then OverlapCollision
+        (V2
+          (min 0 (ox2 - ox1) * (- 1))
+          (min 0 (oy2 - oy1) * (- 1))
+          )
+      else
+        NoCollision
 
   -- | This Function is called for every collision on both colliding objects.
   collide
     :: (Collidible other)
-    => c                                          -- ^ Original object
-    -> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and  results
-    -> Double                                     -- ^ Timestep length
-    -> c                                          -- ^ Updated original object
-  collide coll1 collrs = elasticCollision 0.9 coll1 (head collrs)
+    => c                                      -- ^ Original object
+    -> [(other, CollisionResult (V2 Double))] -- ^ Collision partners and  results
+    -> Double                                 -- ^ Timestep length
+    -> c                                      -- ^ Updated original object
+  collide coll1 collrs dt =
+    foldl (\acc a -> elasticCollision 0.9 acc a dt) coll1 collrs
 
 -- | Implementation of a dampened elastic collision used as default collision
 -- implementation of the collision reaction
 elasticCollision
   :: (Collidible c1, Collidible c2)
-  => Double
-  -> c1
-  -> (c2, CollisionResult Double (V2 Int))
-  -> Double                          -- ^ Timestep length
-  -> c1
+  => Double                            -- ^ Restitution coefficient
+  -> c1                                -- ^ First collision partner
+  -> (c2, CollisionResult (V2 Double)) -- ^ Second collision partner with collision result
+  -> Double                            -- ^ Timestep length
+  -> c1                                -- ^ Updated first collision partner
 elasticCollision _ mo1 (_, NoCollision) _ = mo1
-elasticCollision damping mo1 (mo2, CollisionImminent ddt (V2 dirx diry)) dt =
-  let v1@(V2 v1x v1y) = velocity mo1
-      (V2 v2x v2y) = velocity mo2
-      p1 = position mo1
-      m1 = mass mo1
-      m2 = mass mo2
-      v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
-      v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
-      nvel = if m1 == recip 0
-        then V2 0 0
-        else (damping *) <$>
-          if m2 == recip 0
-          then
-            if dirx /= 0
-            then V2 (-v1x) v1y
-            else V2 v1x (-v1y)
-          else V2 v1x' v1y'
+elasticCollision restitution mo1 (mo2, OverlapCollision depth) dt =
+  let dvel = (velocity mo1 - velocity mo2) * normalize depth
+      j    = (restitution + 1) * (- (dvel `dot` dvel)) /
+        (1 / mass mo1 + 1 / mass mo2)
+      fi   = (* (j / dt)) <$> normalize depth
   in
-    velocityUpdater
-      mo1
-      nvel
-elasticCollision damping mo1 (mo2, OverlapCollision depth) dt =
-  let m1 = mass mo1
-      m2 = mass mo2
-      (V2 dx dy) = (/ dt) . fromIntegral <$> depth
-      v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx
-      v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
-      nvel = if m1 == recip 0
-        then V2 0 0
-        else (damping *) <$>
-          if m2 == recip 0
-          then
-            if dx /= 0
-            then V2 (-v1x') v1y'
-            else V2 v1x' (-v1y')
-          else
-            V2 v1x' v1y'
-  in
-    velocityUpdater mo1 nvel
+    positionUpdater (addImpactForce (updateCollisionOccurence mo1 True) fi)
+      (position mo1 - depth)

src/Physics/Classes/Mass.hs

@@ -9,11 +9,11 @@ class Mass m where
   -- | The mass of the mass object.
   mass :: m -> Double
 
-  -- | Retrieve the acceleration of the mass object.
-  acceleration :: m -> V2 Double
+  -- | Retrieve the position of the mass object.
+  position :: m -> V2 Double
 
-  -- | Overwrite the acceleration of the mass object.
-  accelerationUpdater :: m -> (V2 Double -> m)
+  -- | Overwrite the position of the mass object.
+  positionUpdater :: m -> (V2 Double -> m)
 
   -- | retrieve the velocity of the mass object.
   velocity :: m -> V2 Double
@@ -21,42 +21,42 @@ class Mass m where
   -- | Overwrite the velocity of the mass object.
   velocityUpdater :: m -> (V2 Double -> m)
 
-  -- | Retrieve the position of the mass object.
-  position :: m -> V2 Double
+  -- | Total force acting on a particle in one simulation step
+  forces :: m -> V2 Double
 
-  -- | Overwrite the position of the mass object.
-  positionUpdater :: m -> (V2 Double -> m)
+  -- | Overwrite the forces acting on a particle
+  forcesUpdater :: m -> (V2 Double -> m)
 
-  -- | The update function to let a mass react to gravitational pull.
-  -- Apply all accelerations before calling the default implementation of
-  -- this function, since it will add the gravitational pull to already
-  -- existing accelerations.
-  gravitate
-    :: V2 Double -- ^ Vector of gravitational acceleration
-    -> m         -- ^ Original mass object
+  -- | Reset forces vector for the begining of a new simulation step
+  resetForces :: m -> m
+  resetForces m = forcesUpdater m (V2 0 0)
+
+  -- | Calculate the loads or forces acting on the mass object except for
+  -- collision forces.
+  addLoads
+    :: m         -- ^ The mass object
+    -> V2 Double -- ^ force to be aggregated acting on the particle (e.g.: gravity)
+    -> m         -- ^ Resulting mass object
+  addLoads m vec =
+    forcesUpdater m (forces m + vec)
+
+  -- | Euler integration updates
+  updateByEuler
+    :: m      -- ^ The mass object
+    -> Double -- ^ Time step in fraction of a second
+    -> m      -- ^ Resulting mass object
+  updateByEuler m dt =
+    let acc = (/ mass m) <$> forces m
+        dvel = (* dt) <$> acc
+        nvel = velocity m + dvel
+        dpos = (* dt) <$> nvel
+        npos = position m + dpos
+    in
+      resetForces $ positionUpdater (velocityUpdater m nvel) npos
+
+  calculateLoads
+    :: m         -- ^ Original mass object
+    -> V2 Double -- ^ Gravitational force vector
     -> m         -- ^ Updated mass object
-  gravitate g m =
-    let acc = acceleration m + g
-    in
-      accelerationUpdater m acc
-
-  -- | Apply acceleration to mass object und thus change its velocity
-  accelerate
-    :: Double -- ^ Time step duration
-    -> m      -- ^ Original mass object
-    -> m      -- ^ Updated mass object
-  accelerate dt m =
-    let vel = velocity m + ((dt *) <$> acceleration m)
-    in
-      velocityUpdater m vel
-
-  -- | Apply velocity to mass object and thus change its position
-  -- Changes in position smaller than around half a pixel per second are ignored.
-  move
-    :: Double -- ^ Time step duration
-    -> m      -- ^ Original mass object
-    -> m      -- ^ Updated mass object
-  move dt m =
-    let dpos = (dt *) <$> velocity m
-    in
-      positionUpdater m (position m + dpos)
+  calculateLoads =
+    addLoads

src/Scenes/Test/Load.hs

@@ -78,6 +78,9 @@ load level progress = do
         (V2 0 0)
         (V2 0 0)
         (V2 0 0)
+        (V2 0 0)
+        (V2 0 0)
+        (V2 0 0)
         100
         tex
         False
@@ -85,13 +88,18 @@ load level progress = do
         ViewRight
         []
         False
+        False
       oil = PowerUp
         (realToFrac <$> (startpos + V2 200 0))
         (V2 0 0)
         (V2 0 0)
+        (V2 0 0)
         5000
         tex
         (EffectHolder 5 SpeedUp)
+        (V2 0 0)
+        (V2 0 0)
+        False
 
 
   bind shader

src/Scenes/Test/Update.hs

@@ -5,6 +5,8 @@ module Scenes.Test.Update where
 
 import Affection as A
 
+import Linear
+
 import Control.Concurrent.STM
 
 import Data.List (sortOn)
@@ -21,6 +23,7 @@ import Scenes.Test.Types
 import Classes
 import Types
 import Physics
+import Util
 
 update
   :: Test
@@ -55,10 +58,10 @@ update level dt = liftIO $ do
                     let partners =
                           V.foldl
                             (\jacc (qInd, tangible2) ->
-                              let res = collisionCheck dt tangible1 tangible2
+                              let res = collisionCheck tangible1 tangible2
                               in
                                 case res of
-                                  c@(CollisionImminent _ _) ->
+                                  c@(OverlapCollision _) ->
                                     if qInd /= index
                                     then jacc `V.snoc` (qInd, c)
                                     else jacc
@@ -71,7 +74,9 @@ update level dt = liftIO $ do
                       then iacc
                       else iacc `V.snoc`
                         ( index
-                        , sortOn (collisionTime . snd) (V.toList partners)
+                        , sortOn
+                          ((\v -> collisionDepth v `dot` collisionDepth v) . snd)
+                            (V.toList partners)
                         )
                     )
                   V.empty
@@ -93,7 +98,10 @@ update level dt = liftIO $ do
                                 d
                                 dt
                         in
-                          inter
+                          resetImpactForces $ flip updateCollisionOccurence False $
+                            if collisionOccured inter
+                            then addLoads inter (impactForces inter)
+                            else addLoads inter constG
                         )
                       digest
                 in
@@ -112,11 +120,11 @@ update level dt = liftIO $ do
           (\acc@(castAcc, pAcc, _) input ->
             case input of
               TCast c ->
-                (castAcc `V.snoc` move dt c, pAcc, mnewCat)
+                (castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat)
               TPowerUp p ->
-                (castAcc, pAcc `V.snoc` move dt p, mnewCat)
+                (castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat)
               TPlayer ncat ->
-                (castAcc, pAcc, Just (move dt ncat))
+                (castAcc, pAcc, Just (updateByEuler ncat dt))
               TTile _ ->
                 acc
             )
@@ -125,144 +133,3 @@ update level dt = liftIO $ do
     writeTVar (testCast level) newCast
     writeTVar (testPowerups level) newPowerups
     writeTVar (testPlayer level) mnewCat
-
-    -- oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$>
-    --   readTVar (testCast level)
-    -- oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level)
-    -- modifyTVar (testCast level) $ \cast ->
-    --   let playedCast =
-    --         V.map
-    --         (\(Cast c) -> Cast (perform dt c))
-    --         cast
-    --       collidedCast =
-    --         V.map
-    --           (\(Cast c1) ->
-    --             let partners = V.foldl
-    --                   (\acc@(Cast _, ires) (Cast c2) ->
-    --                     let res = collisionCheck dt c1 c2
-    --                     in
-    --                       if res /= NoCollision &&
-    --                         collisionTime res < collisionTime ires
-    --                       then (Cast c2, res)
-    --                       else acc
-    --                     )
-    --                   (Cast c1, NoCollision)
-    --                   playedCast
-    --             in
-    --               if null partners
-    --               then Cast c1
-    --               else
-    --                 uncurry
-    --                   (\(Cast c2) result -> Cast $ collide c1 c2 result)
-    --                   partners
-    --             )
-    --           playedCast
-    --       wallCast (Cast c) =
-    --         Cast $ performWorldCollision c layer dt
-    --       walledCast =
-    --         V.map wallCast collidedCast
-    --       cattedCast = V.map
-    --         (\(Cast c) ->
-    --           Cast $ collide c oldCat $ collisionCheck dt c oldCat
-    --           )
-    --         walledCast
-    --   in
-    --     V.map
-    --       (\(Cast c) -> Cast $
-    --         move dt c
-    --         )
-    --       walledCast
-    -- releasedEffects <- stateTVar (testPowerups level) $ \pus ->
-    --   let living = V.foldl
-    --         (\acc pu ->
-    --           let npu = perform dt pu
-    --           in
-    --             if puTTL npu > 0
-    --             then npu `V.cons` acc
-    --             else acc
-    --           )
-    --         V.empty
-    --         pus
-    --       indexCollected = V.filter ((/= NoCollision) . snd) $
-    --         V.zip (V.fromList [0..length living])
-    --           (V.map
-    --             (collisionCheck dt oldCat)
-    --             living
-    --             )
-    --       collected = V.foldl
-    --         (\acc (ind, _) ->
-    --           (living V.! ind) `V.cons` acc
-    --           )
-    --         V.empty
-    --         indexCollected
-    --       differ = V.foldl
-    --         (\acc life -> if life `V.elem` collected
-    --           then acc
-    --           else life `V.cons` acc
-    --           )
-    --         V.empty
-    --         living
-    --       fin = V.map
-    --         (\pu -> move dt $ performWorldCollision pu layer dt)
-    --         differ
-    --   in
-    --     (collected, fin)
-    -- modifyTVar
-    --   (testPlayer level) $ \(Just pituicat) ->
-    --     let playedCat = perform dt pituicat
-    --         castCat =
-    --           let allPartners = V.zip (V.fromList [0..V.length oldCast])
-    --                 (V.map
-    --                   (\(Cast c) -> collisionCheck dt playedCat c)
-    --                   oldCast
-    --                   )
-    --               filtered = (V.filter ((/= NoCollision) . snd) allPartners)
-    --               partner = V.minimumBy
-    --                 (\(_, e) (_, f) -> collisionTime e `compare` collisionTime f)
-    --                 filtered
-    --           in
-    --             if V.null filtered
-    --             then
-    --               playedCat
-    --             else
-    --               uncurry
-    --                 (\(Cast c) cr -> collide playedCat c cr)
-    --                 (oldCast V.! fst partner, snd partner)
-    --         walledCat = performWorldCollision castCat layer dt
-    --         affectedCat = walledCat
-    --           { pcEffects = pcEffects walledCat ++
-    --             map puEffect (V.toList releasedEffects)
-    --           }
-    --     in Just $ move dt affectedCat
-
--- performWorldCollision
---   :: (Collidible c)
---   => c      -- ^ Cast member to check
---   -> Layer  -- ^ The walk layer of the level
---   -> Double -- ^ Tick length
---   -> c      -- ^ Updated cast member
--- performWorldCollision c layer dt =
---   let partner = V.foldl
---         (\acc@(part, cr) tile ->
---           let res = collisionCheck dt c tile
---               ret = if cr == NoCollision && res == NoCollision
---                 then
---                   acc
---                 else
---                   if cr == NoCollision && res /= NoCollision
---                   then (tile, res)
---                   else
---                     if cr /= NoCollision && res == NoCollision
---                     then
---                       acc
---                     else
---                       if collisionTime cr < collisionTime res
---                       then acc
---                       else (tile, res)
---           in
---             ret
---           )
---         (V.head layer, collisionCheck dt c $ V.head layer)
---         layer
---   in
---     (uncurry (collide c) partner) dt

src/Types/Cast.hs

@@ -16,22 +16,32 @@ instance Mass Cast where
 
   mass (Cast a) = mass a
 
-  acceleration (Cast a) = acceleration a
-
-  accelerationUpdater (Cast a) = Cast . accelerationUpdater a
-
   velocity (Cast a) = velocity a
 
   velocityUpdater (Cast a) = Cast . velocityUpdater a
 
+  forces (Cast a) = forces a
+
+  forcesUpdater (Cast a) = Cast . forcesUpdater a
+
   position (Cast a) = position a
 
   positionUpdater (Cast a) = Cast . positionUpdater a
 
 instance Collidible Cast where
 
+  prevPosition (Cast c) = prevPosition c
+
+  impactForces (Cast c) = impactForces c
+
+  impactForcesUpdater (Cast c) = Cast . impactForcesUpdater c
+
+  collisionOccured (Cast c) = collisionOccured c
+
+  updateCollisionOccurence (Cast c) = Cast . updateCollisionOccurence c
+
   boundary (Cast c) = boundary c
 
-  collisionCheck dt (Cast c1) c2 = collisionCheck dt c1 c2
+  collisionCheck (Cast c1) c2 = collisionCheck c1 c2
 
   collide (Cast c1) res dt = Cast $ collide c1 res dt

src/Types/Map.hs

@@ -41,6 +41,7 @@ data Tile = Tile
   { tilePosition     :: V2 Word              -- ^
   , tileOffset       :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
   , tileType         :: TileType             -- ^ Type of tile
+  , tileCollided     :: Bool
   }
   deriving (Eq, Show)
 
@@ -48,7 +49,7 @@ instance Drawable Tile where
 
   -- type VertexList Tile = V.Vector
 
-  toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _) =
+  toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _ _) =
     ( V.fromList [ 0, 1, 2, 2, 3, 0 ]
     , V.fromList
       [ newVertex
@@ -76,12 +77,12 @@ instance Drawable Tile where
 
 instance Mass Tile where
 
+  forces _ = V2 0 0
+
+  forcesUpdater t _ = t
+
   mass _ = recip 0
 
-  acceleration _ = V2 0 0
-
-  accelerationUpdater t = const t
-
   velocity _ = V2 0 0
 
   velocityUpdater t = const t
@@ -95,6 +96,18 @@ instance Mass Tile where
 
 instance Collidible Tile where
 
+  prevPosition t = position t
+
+  impactForces _ = V2 0 0
+
+  impactForcesUpdater t _ = t
+
+  collisionOccured t = tileCollided t
+
+  updateCollisionOccurence t coll = t
+    { tileCollided = coll
+    }
+
   boundary _ =
     ( V2 (-16) (-16)
     , V2 16 16

src/Types/Player.hs

@@ -31,7 +31,10 @@ catMoveVelocity = 100
 
 data Pituicat = Pituicat
   { pcPos           :: V2 Double
+  , pcPrevPos       :: V2 Double
   , pcVel           :: V2 Double
+  , pcForces        :: V2 Double
+  , pcImpactForces  :: V2 Double
   , pcMoveVel       :: V2 Double
   , pcTMoveVel      :: V2 Double
   , pcAcc           :: V2 Double
@@ -42,6 +45,7 @@ data Pituicat = Pituicat
   , pcViewDirection :: ViewDirection
   , pcEffects       :: [EffectHolder]
   , pcXColl         :: Bool
+  , pcCollisionOcc  :: Bool
   }
   deriving (Eq, Show)
 
@@ -50,7 +54,7 @@ data ViewDirection = ViewLeft | ViewRight
 
 instance Drawable Pituicat where
 
-  toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ vd _ _) =
+  toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ _ _ _ vd _ _ _) =
     ( V.fromList [0, 1, 2, 2, 3, 0]
     , V.fromList
       [ newVertex
@@ -103,7 +107,7 @@ instance Actor Pituicat where
             not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
           then 1
           else 2
-        physCat = (accelerate dt . gravitate constG)
+        physCat =
           (p
             { pcAcc = V2 0 0
             , pcTMoveVel =
@@ -149,13 +153,6 @@ instance Mass Pituicat where
 
   mass _ = 100
 
-  acceleration = pcAcc
-
-  accelerationUpdater cat =
-    \accel -> cat
-      { pcAcc = accel
-      }
-
   velocity =
     pcVel
 
@@ -164,6 +161,12 @@ instance Mass Pituicat where
       { pcVel = vel
       }
 
+  forces = pcForces
+
+  forcesUpdater c force = c
+    { pcForces = force
+    }
+
   position = pcPos
 
   positionUpdater cat =
@@ -171,15 +174,22 @@ instance Mass Pituicat where
       { pcPos = pos
       }
 
-  move dt cat =
-    let dpos = (dt *) <$> velocity cat
-        mpos = (dt *) <$>
-          (if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat
-    in
-      positionUpdater cat (position cat + dpos + mpos)
-
 instance Collidible Pituicat where
 
+  impactForces = pcImpactForces
+
+  impactForcesUpdater c force = c
+    { pcImpactForces = force
+    }
+
+  collisionOccured = pcCollisionOcc
+
+  updateCollisionOccurence c coll = c
+    { pcCollisionOcc = coll
+    }
+
+  prevPosition = pcPrevPos
+
   boundary cat =
     if pcViewDirection cat == ViewRight
     then
@@ -196,25 +206,25 @@ instance Collidible Pituicat where
     }
   collide cat collrs@((_, NoCollision):_) _ = cat
     { pcXColl = any
-      (\(_, CollisionImminent _ (V2 cx _)) -> cx /= 0)
+      (\(_, OverlapCollision (V2 cx _)) -> cx /= 0)
       (filter ((NoCollision /= ) . snd) collrs)
     }
   collide cat collrs@(collr@(_, OverlapCollision direction):_) dt =
     elasticCollision 0.3 cat collr dt
-  collide cat collrs@(collr@(other, CollisionImminent ddt (V2 dirx diry)):_) dt =
-    let ncat = elasticCollision 0.3 cat collr dt
-        vel@(V2 vx vy) = velocity ncat
-        moveVel@(V2 mx my) = pcMoveVel cat
-        nvel = V2
-          (if abs mx > abs vx
-            then 0
-            else signum vx * (abs vx - abs mx)
-            )
-          ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
-        grounded =
-          diry == -1 && abs (vy * ddt) < 2
-    in
-      ncat
-        { pcGrounded = grounded
-        , pcXColl = not grounded && diry /= 0
-        }
+  -- collide cat collrs@(collr@(other, OverlapCollision (V2 dirx diry)):_) dt =
+  --   let ncat = elasticCollision 0.3 cat collr dt
+  --       vel@(V2 vx vy) = velocity ncat
+  --       moveVel@(V2 mx my) = pcMoveVel cat
+  --       nvel = V2
+  --         (if abs mx > abs vx
+  --           then 0
+  --           else signum vx * (abs vx - abs mx)
+  --           )
+  --         ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
+  --       grounded =
+  --         diry == -1 && abs (vy * ddt) < 2
+  --   in
+  --     ncat
+  --       { pcGrounded = grounded
+  --       , pcXColl = not grounded && diry /= 0
+  --       }

src/Types/PowerUp.hs

@@ -17,21 +17,23 @@ import Graphics.Types.Texture
 import Graphics.Classes.Drawable
 import Graphics.Classes.Bindable
 
-import Util
-
 data PowerUp = PowerUp
-  { puPos     :: V2 Double
-  , puVel     :: V2 Double
-  , puAcc     :: V2 Double
-  , puTTL     :: Double
-  , puTexture :: Texture
-  , puEffect  :: EffectHolder
+  { puPos          :: V2 Double
+  , puPrevPos      :: V2 Double
+  , puVel          :: V2 Double
+  , puAcc          :: V2 Double
+  , puTTL          :: Double
+  , puTexture      :: Texture
+  , puEffect       :: EffectHolder
+  , puForces       :: V2 Double
+  , puImpactForces :: V2 Double
+  , puCollided     :: Bool
   }
   deriving (Eq, Show)
 
 instance Drawable PowerUp where
 
-  toVertices (PowerUp (V2 x y) _ _ _ _ _) =
+  toVertices (PowerUp (V2 x y) _ _ _ _ _ _ _ _ _) =
     ( V.fromList [0, 1, 2, 2, 3, 0]
     , V.fromList
       [ newVertex
@@ -66,7 +68,7 @@ instance Prop PowerUp where
 instance Actor PowerUp where
 
   perform dt o =
-    let phys = (accelerate dt . gravitate constG)
+    let phys =
           o
             { puAcc = V2 0 0
             , puTTL = puTTL o - dt
@@ -78,12 +80,11 @@ instance Mass PowerUp where
 
   mass _ = 0.1
 
-  acceleration = puAcc
+  forces = puForces
 
-  accelerationUpdater o =
-    \acc -> o
-      { puAcc = acc
-      }
+  forcesUpdater p force = p
+    { puForces = force
+    }
 
   velocity = puVel
 
@@ -101,6 +102,20 @@ instance Mass PowerUp where
 
 instance Collidible PowerUp where
 
+  prevPosition = puPrevPos
+
+  impactForces = puImpactForces
+
+  impactForcesUpdater p force = p
+    { puImpactForces = force
+    }
+
+  collisionOccured = puCollided
+
+  updateCollisionOccurence p coll = p
+    { puCollided = coll
+    }
+
   boundary _ =
     ( V2 (-20) (-20)
     , V2 20 20

src/Types/Tangible.hs

@@ -28,15 +28,15 @@ instance Mass Tangible where
   mass (TPowerUp a) = mass a
   mass (TTile a) = mass a
 
-  acceleration (TPlayer a) = acceleration a
-  acceleration (TCast a) = acceleration a
-  acceleration (TPowerUp a) = acceleration a
-  acceleration (TTile a) = acceleration a
+  forces (TPlayer a) = forces a
+  forces (TCast a) = forces a
+  forces (TPowerUp a) = forces a
+  forces (TTile a) = forces a
 
-  accelerationUpdater (TPlayer a) = TPlayer . accelerationUpdater a
-  accelerationUpdater (TCast a) = TCast . accelerationUpdater a
-  accelerationUpdater (TPowerUp a) = TPowerUp . accelerationUpdater a
-  accelerationUpdater (TTile a) = TTile . accelerationUpdater a
+  forcesUpdater (TPlayer a) = TPlayer . forcesUpdater a
+  forcesUpdater (TCast a) = TCast . forcesUpdater a
+  forcesUpdater (TPowerUp a) = TPowerUp . forcesUpdater a
+  forcesUpdater (TTile a) = TTile . forcesUpdater a
 
   velocity (TPlayer a) = velocity a
   velocity (TCast a) = velocity a
@@ -60,15 +60,40 @@ instance Mass Tangible where
 
 instance Collidible Tangible where
 
-  boundary (TPlayer c) = boundary c
-  boundary (TCast c) = boundary c
+  boundary (TPlayer c)  = boundary c
+  boundary (TCast c)    = boundary c
   boundary (TPowerUp c) = boundary c
-  boundary (TTile c) = boundary c
+  boundary (TTile c)    = boundary c
 
-  collisionCheck dt (TPlayer c1) c2 = collisionCheck dt c1 c2
-  collisionCheck dt (TCast c1) c2 = collisionCheck dt c1 c2
-  collisionCheck dt (TPowerUp c1) c2 = collisionCheck dt c1 c2
-  collisionCheck dt (TTile c1) c2 = collisionCheck dt c1 c2
+  prevPosition (TPlayer c)  = prevPosition c
+  prevPosition (TCast c)    = prevPosition c
+  prevPosition (TPowerUp c) = prevPosition c
+  prevPosition (TTile c)    = prevPosition c
+
+  impactForces (TPlayer c)  = impactForces c
+  impactForces (TCast c)    = impactForces c
+  impactForces (TPowerUp c) = impactForces c
+  impactForces (TTile c)    = impactForces c
+
+  collisionOccured (TPlayer c)  = collisionOccured c
+  collisionOccured (TCast c)    = collisionOccured c
+  collisionOccured (TPowerUp c) = collisionOccured c
+  collisionOccured (TTile c)    = collisionOccured c
+
+  impactForcesUpdater (TPlayer c)  = TPlayer . impactForcesUpdater c
+  impactForcesUpdater (TCast c)    = TCast . impactForcesUpdater c
+  impactForcesUpdater (TPowerUp c) = TPowerUp . impactForcesUpdater c
+  impactForcesUpdater (TTile c)    = TTile . impactForcesUpdater c
+
+  updateCollisionOccurence (TPlayer c)  = TPlayer . updateCollisionOccurence c
+  updateCollisionOccurence (TCast c)    = TCast . updateCollisionOccurence c
+  updateCollisionOccurence (TPowerUp c) = TPowerUp . updateCollisionOccurence c
+  updateCollisionOccurence (TTile c)    = TTile . updateCollisionOccurence c
+
+  collisionCheck (TPlayer c1) c2  = collisionCheck c1 c2
+  collisionCheck (TCast c1) c2    = collisionCheck c1 c2
+  collisionCheck (TPowerUp c1) c2 = collisionCheck c1 c2
+  collisionCheck (TTile c1) c2    = collisionCheck c1 c2
 
   collide (TPlayer c1) res dt  = TPlayer $ collide c1 res dt
   collide (TCast c1) res dt    = TCast $ collide c1 res dt

src/Util.hs

@@ -3,20 +3,18 @@ module Util where
 import Affection
 
 import qualified SDL
-import qualified SDL.Internal.Numbered as SDL
 
 import Linear
 
 -- internal imports
 
 import Types.Application
-import Types.Subsystems
 
 globalKeyHandle
   :: GameData
   -> KeyboardMessage
   -> Affection ()
-globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) =
+globalKeyHandle _ mesg@MsgKeyboardEvent {} =
   case mesg of
     MsgKeyboardEvent
       _