wörk wörk

.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,18 @@
+*.hi
+*.o
+.hsenv*
+.stack-work
+.git
+.cabal-sandbox/
+cabal.sandbox.config
+dist/
+*.prof
+*.aux
+*.hp
+*.ps
+*.swp
+.ghc*
+cabal.project.local*
+dist*/
+report.html
+*.bak

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,181 @@
+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
+
+-- This example shows the message system. only makes sense when compiling with
+-- verbose flag.
+executable example00
+  hs-source-dirs:    examples/example00
+  main-is:           Main.hs
+  ghc-options:       -threaded -Wall
+  default-language:  Haskell2010
+  default-extensions: OverloadedStrings
+  if flag(examples)
+    build-depends:     base >=4.9 && < 5
+                     , affection
+                     , sdl2 ^>= 2.5
+                     , stm
+  else
+    buildable:       False
+
+-- A small game of life implementation
+executable example01
+  hs-source-dirs:    examples/example01
+  main-is:           Main.hs
+  other-modules:     Types
+  ghc-options:       -threaded -Wall
+  default-language:  Haskell2010
+  default-extensions: OverloadedStrings
+  if flag(examples)
+    build-depends:     base >=4.9 && < 5
+                     , affection
+                     , sdl2 ^>= 2.5
+                     , stm
+                     , OpenGL
+                     , random
+                     , containers
+                     , linear
+                     , matrix
+                     , nanovg >= 0.6.0.0
+                     , deepseq
+  else
+    buildable:       False
+
+-- Another small game of life implementation
+executable example02
+  hs-source-dirs:    examples/example02
+  main-is:           Main.hs
+  other-modules:     Types
+  ghc-options:       -threaded -Wall
+  default-language:  Haskell2010
+  default-extensions: OverloadedStrings
+  if flag(examples)
+    build-depends:     base >=4.9 && < 5
+                     , affection
+                     , sdl2 ^>= 2.5
+                     , stm
+                     , OpenGL
+                     , random
+                     , containers
+                     , linear
+                     , matrix
+                     , nanovg >= 0.6.0.0
+                     , deepseq
+  else
+    buildable:       False

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,125 @@
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
+
+let
+
+  inherit (nixpkgs) pkgs;
+
+  nanovg = with haskellPackages; callPackage (
+    { mkDerivation, base, bytestring, c2hs, containers, glew
+    , hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector
+    }:
+    mkDerivation {
+      pname = "nanovg";
+      version = "0.6.0.0";
+      sha256 = "e35a2772f2a2e71916013cab70eeb8eedd6f66b5490ddf7ce237c8c76895d496";
+      revision = "1";
+      editedCabalFile = "1lhfsq50r9bdby7mfscw8ih3wsz2m19lr2a2z9b6diaf5kz76vij";
+      isLibrary = true;
+      isExecutable = true;
+      doCheck = false;
+      libraryHaskellDepends = [ base bytestring containers text vector ];
+      librarySystemDepends = [ glew libGL libGLU ];
+      libraryPkgconfigDepends = [ glew ];
+      libraryToolDepends = [ c2hs ];
+      testHaskellDepends = [ base containers hspec inline-c QuickCheck ];
+      homepage = "https://github.com/cocreature/nanovg-hs";
+      description = "Haskell bindings for nanovg";
+      license = stdenv.lib.licenses.isc;
+    }) {};
+
+  glib = with haskellPackages; callPackage(
+    { mkDerivation, base, bytestring, Cabal, containers, glib
+    , stdenv, text, utf8-string, gtk2hs-buildtools
+    }:
+    mkDerivation {
+      pname = "glib";
+      version = "0.13.8.0";
+      sha256 = "9cce6fb44e3c30de2bd330a6902955e3a5fce7b6e9ce41a4afb70e3a7d6e61a2";
+      setupHaskellDepends = [ base Cabal gtk2hs-buildtools ];
+      libraryHaskellDepends = [
+        base bytestring containers text utf8-string
+      ];
+      libraryPkgconfigDepends = [ pkgs.glib ];
+      homepage = "http://projects.haskell.org/gtk2hs/";
+      description = "Binding to the GLIB library for Gtk2Hs";
+      license = stdenv.lib.licenses.lgpl21;
+    }) {};
+
+  #gtk2hs-buildtools = with haskellPackages; callPackage(
+  #  { mkDerivation, alex, array, base, Cabal, containers, directory
+  #  , filepath, happy, hashtables, pretty, process, random, stdenv
+  #  }:
+  #  mkDerivation {
+  #    pname = "gtk2hs-buildtools";
+  #    version = "0.13.4.0";
+  #    src = ../gtk2hs/tools;
+  #    isLibrary = true;
+  #    isExecutable = true;
+  #    enableSeparateDataOutput = true;
+  #    libraryHaskellDepends = [
+  #      array base Cabal containers directory filepath hashtables pretty
+  #      process random
+  #    ];
+  #    libraryToolDepends = [ alex happy ];
+  #    executableHaskellDepends = [ base ];
+  #    homepage = "http://projects.haskell.org/gtk2hs/";
+  #    description = "Tools to build the Gtk2Hs suite of User Interface libraries";
+  #    license = stdenv.lib.licenses.gpl2;
+  #  }) {};
+
+  sdl2 = with haskellPackages; callPackage(
+    { mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2
+    , StateVar, stdenv, text, transformers, vector, weigh
+    }:
+    mkDerivation {
+      pname = "sdl2";
+      version = "2.5.1.0";
+      sha256 = "fc1d3d4276b2c4f835a5311075abb240385aae7edad8760f6bda55ed8271ed20";
+      isLibrary = true;
+      isExecutable = true;
+      enableSeparateDataOutput = true;
+      libraryHaskellDepends = [
+        base bytestring exceptions linear StateVar text transformers vector
+      ];
+      librarySystemDepends = [ SDL2 ];
+      libraryPkgconfigDepends = [ SDL2 ];
+      testHaskellDepends = [ base deepseq linear vector weigh ];
+      description = "Both high- and low-level bindings to the SDL library (version 2.0.6+).";
+      license = stdenv.lib.licenses.bsd3;
+      doCheck = false;
+    }) {};
+
+  f = { mkDerivation, base, bytestring, clock, containers, deepseq
+      , linear, matrix, monad-loops, monad-parallel, mtl
+      , OpenGL, OpenGLRaw, random, stdenv, stm, text, uuid, vector
+      }:
+      mkDerivation {
+        pname = "affection";
+        version = "0.0.0.9";
+        src = ./.;
+        configureFlags = [ "-fexamples" ];
+        isLibrary = true;
+        isExecutable = true;
+        libraryHaskellDepends = [
+          base bytestring clock containers glib linear monad-loops
+          monad-parallel mtl OpenGL OpenGLRaw sdl2 stm text uuid vector
+        ];
+        executableHaskellDepends = [
+          base containers deepseq linear matrix nanovg OpenGL random sdl2 stm
+        ];
+        homepage = "https://github.com/nek0/affection#readme";
+        description = "A simple Game Engine using SDL";
+        license = stdenv.lib.licenses.lgpl3;
+      };
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
+
+  drv = variant (haskellPackages.callPackage f {});
+
+in
+
+  if pkgs.lib.inNixShell then drv.env else drv

extern/affection/src/Affection.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Strict #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+module Affection
+    ( withAffection
+    , get
+    , put
+    , liftIO
+    , module A
+    ) where
+
+import SDL (($=))
+import qualified SDL
+import qualified SDL.Raw.Video as SDL (glSetAttribute)
+import qualified SDL.Raw.Enum as SDL
+
+import 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 qualified Data.ByteString.Char8 as B8
+
+import System.Clock
+
+import Control.Monad.Loops
+import Control.Monad.State.Strict
+
+-- 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{..} = do
+  liftIO $ logIO Debug "Affection starting"
+  liftIO $ logIO Debug "Initializing SDL"
+  -- intialiaze SDL
+  case initComponents of
+    All ->
+      SDL.initializeAll
+    Only is ->
+      SDL.initialize is
+  -- give SDL render quality
+  SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
+  -- just checking…
+  do
+    renderQuality <- SDL.get SDL.HintRenderScaleQuality
+    when (renderQuality /= SDL.ScaleLinear) $
+      logIO Warn "Linear texture filtering not enabled!"
+  -- construct window
+  liftIO $ logIO Debug "Creating Window(s)"
+  windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
+    mapM
+    (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
+    windowConfigs <*>
+    pure (map (\(_,_,z) -> z) windowConfigs)
+
+  mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
+  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
+  contexts <- zip (map (\(x,_,_) -> x) windows) <$>
+    mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
+  mapM_ (\w -> flip SDL.setWindowMode  ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows
+  -- sync updates with monitor
+  -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
+  liftIO $ logIO Debug "Getting Time"
+  -- print current used GL Version
+  version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
+  print (B.pack version)
+  -- get current time
+  execTime <- getTime Monotonic
+  liftIO $ logIO Debug "Loading initial data container"
+  -- construct game data object from provided Affectionate instance
+  gameData <- loadState @us
+  -- build state container
+  let initContainer = AffectionData
+        { drawWindows     = windows
+        , glContext       = contexts
+        , elapsedTime     = 0
+        , deltaTime       = 0
+        , sysTime         = execTime
+        , pausedTime      = False
+        }
+  -- initialize and run state
+  (_, _) <- runStateT
+    (A.runState
+      (do
+        liftIO $ logIO Debug "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
+            evs <- preHandleEvents =<< liftIO SDL.pollEvents
+            -- handle events
+            handleEvents gameData evs
+            -- execute user defined update loop
+            unless (pausedTime ad) (update gameData dt)
+            -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
+            liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
+            draw gameData
+            liftIO GL.flush
+            -- actual displaying of newly drawn frame
+            mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
+            -- save new time
+            ad3 <- get
+            when (sysTime ad == sysTime ad3) (
+              put ad3
+                { sysTime = now
+                }
+              )
+            )
+        )
+      ) initContainer
+  liftIO $ logIO Debug "Loop ended. Cleaning"
+  cleanUp gameData
+  liftIO $ logIO Debug "Destroying Window"
+  mapM_ (SDL.glDeleteContext . snd) contexts
+  mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
+  -- SDL.quit -- <- This causes segfaults depending on hardware
+  liftIO $ logIO Debug "This is the end"

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,84 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
+module Affection.Types 
+  ( Affection
+  , AffectionConfig(..)
+  , AffectionData(..)
+  , AffectionStateInner
+  , AffectionState(..)
+  , InitComponents(..)
+  , Angle
+  -- | SDL reexports
+  , SDL.WindowConfig(..)
+  , SDL.WindowMode(..)
+  , SDL.EventPayload(..)
+  , SDL.InitFlag(..)
+  , SDL.Window
+  , SDL.GLContext
+  ) where
+
+import qualified SDL.Init as SDL
+import qualified SDL.Video as SDL
+import qualified SDL.Event as SDL
+import qualified Data.Text as T
+
+import Control.Monad.IO.Class
+import Control.Monad.State.Strict
+import qualified Control.Monad.Parallel as MP
+
+import System.Clock (TimeSpec)
+
+-- | Configuration for the aplication. needed at startup.
+data AffectionConfig us = AffectionConfig
+  { initComponents :: InitComponents
+      -- ^ SDL components to initialize at startup
+  , windowTitle    :: T.Text
+      -- ^ Window title
+  , windowConfigs  ::
+      [
+      ( Word             -- --^ Window identifier
+      , SDL.WindowConfig -- --^ Window config for given window
+      , SDL.WindowMode   -- -- ^ Window mode to start in
+      )
+      ]
+      -- ^ Window configurations
+  }
+
+-- | Components to initialize in SDL.
+data InitComponents
+  = All
+  | Only [SDL.InitFlag]
+
+-- | Main type for defining the look, feel and action of the whole application.
+data AffectionData = AffectionData
+  { drawWindows     ::
+    [
+    ( Word                                -- --^ Window identifier
+    , SDL.Window                          -- --^ Window linked with identifier
+    , SDL.WindowMode                      -- -- ^ current screen mode
+    )
+    ]                                     -- ^ SDL windows
+  , glContext       ::
+    [
+    ( Word                                -- --^ Window identifier
+    , SDL.GLContext                       -- --^ Associated OpenGL context
+    )
+    ]                                     -- ^ OpenGL rendering contexts
+  , elapsedTime     :: Double             -- ^ Elapsed time in seconds
+  , deltaTime       :: Double             -- ^ Elapsed time in seconds since last tick
+  , sysTime         :: TimeSpec           -- ^ System time (NOT the time on the clock)
+  , pausedTime      :: Bool               -- ^ Should the update loop be executed?
+  }
+
+-- | Inner 'StateT' monad for the update state
+type AffectionStateInner sd a = StateT sd a
+
+-- | Affection's state monad
+newtype AffectionState sd m a = AffectionState
+  { runState :: AffectionStateInner sd m a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
+
+instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
+
+type Affection a = AffectionState AffectionData IO a
+
+type Angle = Double

extern/affection/src/Affection/Util.hs

@@ -0,0 +1,86 @@
+module Affection.Util where
+
+import Affection.Types
+import Affection.Logging
+import Affection.MessageBus.Message.WindowMessage
+
+import SDL (($=))
+import qualified SDL
+import qualified Graphics.Rendering.OpenGL as GL
+
+import System.Clock
+
+import Data.String (fromString)
+import Data.List (find)
+
+import Control.Monad.State
+
+-- | Prehandle SDL events
+preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload]
+preHandleEvents evs =
+  return $ map SDL.eventPayload evs
+
+-- | block a thread for a specified amount of time
+delaySec
+  :: Int -- ^ Number of seconds
+  -> IO ()
+delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
+
+-- | Get time since start but always the same in the current tick.
+getElapsedTime :: Affection Double
+getElapsedTime = gets elapsedTime
+
+-- | Get delta time (time elapsed from last frame)
+getDelta :: Affection Double
+getDelta = gets deltaTime
+
+-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
+-- Pauses the Engine in the process.
+toggleScreen :: Word -> Affection ()
+toggleScreen windowIdent = do
+  ad <- get
+  let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad)
+  case mwindow of
+    Just (ident, window, mode) -> do
+      newMode <- case mode of
+        SDL.FullscreenDesktop -> do
+          SDL.setWindowMode window SDL.Windowed
+          return SDL.Windowed
+        SDL.Windowed -> do
+          SDL.setWindowMode window SDL.FullscreenDesktop
+          return SDL.FullscreenDesktop
+        x -> do
+          liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
+          return x
+      now <- liftIO $ getTime Monotonic
+      put ad
+        { sysTime = now
+        , drawWindows = map
+          (\e@(lid, win, _) ->
+            if lid == ident
+            then (lid, win, newMode)
+            else e
+            )
+          (drawWindows ad)
+        }
+    Nothing -> do
+      liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
+
+-- | Fit the GL Viewport to Window size
+fitViewport
+  :: Double               -- ^ Image Ratio (width / height)
+  -> WindowMessage        -- ^ Incoming Message. Listens only on
+                          -- 'MsgWindowResize' and ignores all others.
+  -> Affection ()
+fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
+  liftIO $ logIO Verbose "Fitting Viewport to size"
+  if (fromIntegral w / fromIntegral h) > ratio
+  then do
+    let nw = floor (fromIntegral h * ratio)
+        dw = floor ((fromIntegral w - fromIntegral nw) / 2 :: Double)
+    GL.viewport $= (GL.Position dw 0, GL.Size nw h)
+  else do
+    let nh = floor (fromIntegral w / ratio)
+        dh = floor ((fromIntegral h - fromIntegral nh) / 2 :: Double)
+    GL.viewport $= (GL.Position 0 dh, GL.Size w nh)
+fitViewport _ _ = return ()

flake.lock

@@ -1,110 +0,0 @@
-{
-  "nodes": {
-    "affection-src": {
-      "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"
-      },
-      "original": {
-        "type": "git",
-        "url": "https://gitea.nek0.eu/nek0/affection"
-      }
-    },
-    "flake-utils": {
-      "locked": {
-        "lastModified": 1678901627,
-        "narHash": "sha256-U02riOqrKKzwjsxc/400XnElV+UtPUQWpANPlyazjH0=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "93a2b84fc4b70d9e089d029deacc3583435c2ed6",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "flake-utils_2": {
-      "inputs": {
-        "systems": "systems"
-      },
-      "locked": {
-        "lastModified": 1681202837,
-        "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "cfacdce06f30d2b68473a46042957675eebb3401",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "nixpkgs": {
-      "locked": {
-        "lastModified": 1679747397,
-        "narHash": "sha256-btdjcq9pGJyKNbU5qQpKfWdEwoj+uazeSpchJjHrt3k=",
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "rev": "e235465058f37b1a4f222957352c1e373905521d",
-        "type": "github"
-      },
-      "original": {
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "type": "github"
-      }
-    },
-    "nixpkgs_2": {
-      "locked": {
-        "lastModified": 1681963077,
-        "narHash": "sha256-8uJm8D6bJ7HEUkeHiWYbSfYKKhEIcgCsp/FQaGTS8RM=",
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "rev": "7ddf6698abe1eec2479590144701ca88fe2fcfe9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "type": "github"
-      }
-    },
-    "root": {
-      "inputs": {
-        "affection-src": "affection-src",
-        "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",
-  "version": 7
-}

flake.nix

@@ -1,58 +0,0 @@
-{
-  description = "A game stub written in Haskell";
-
-  inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs";
-    flake-utils.url = "github:numtide/flake-utils";
-    affection-src.url = "git+https://gitea.nek0.eu/nek0/affection";
-  };
-
-  outputs = { self, nixpkgs, flake-utils, affection-src }:
-    flake-utils.lib.eachDefaultSystem (system:
-      let
-        pkgs = nixpkgs.legacyPackages.${system};
-
-        haskellPackages = pkgs.haskellPackages;
-
-        jailbreakUnbreak = pkg:
-          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
-
-        packageName = "pituicat";
-      in rec {
-        packages.${packageName} = # (ref:haskell-package-def)
-          haskellPackages.callCabal2nix packageName self rec {
-            # Dependency overrides go here
-            affection = affection-src.defaultPackage.${system};
-          };
-
-        defaultPackage = self.packages.${system}.${packageName};
-
-        devShell = haskellPackages.shellFor {
-          packages = p: [ defaultPackage ];
-          withHoogle = true;
-          buildInputs = (with haskellPackages; [
-            haskell-language-server
-            ghcid
-            cabal-install
-          ]) ++ (with pkgs; [
-            glib.dev
-          ]);
-        };
-        #devShell = pkgs.mkShell {
-        #  buildInputs = with haskellPackages; [
-        #    haskell-language-server
-        #    ghcid
-        #    cabal-install
-        #  ];
-        #  nativeBuildInputs = with pkgs; [
-        #    pkg-config
-        #    SDL2
-        #    vulkan-validation-layers
-        #    vulkan-headers
-        #    vulkan-loader
-        #  ];
-        #  inputsFrom = builtins.attrValues self.packages.${system};
-        #};
-      });
-}
-

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/Physics/Classes/Collidible.hs

@@ -8,7 +8,7 @@ import Linear
 
 import Data.String (fromString)
 
-import Data.List (sortBy)
+import Data.Bifunctor (bimap)
 
 -- internal imports
 
@@ -48,10 +48,11 @@ class (Show c, Mass c) => Collidible c where
         d2@(V2 d2x d2y) = velocity m2
         p1@(V2 p1x p1y) = position m1
         p2@(V2 p2x p2y) = position m2
+        (V2 dpx dpy) = p2 - p1
         (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
+        (V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = bimap (p1 +) (p1 +) (boundary m1)
+        (V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = bimap (p2 +) (p2 +) (boundary m2)
         m1p1@(V2 m1p1x m1p1y) = p1 + m1b1
         m1p2 = p1 + V2 m1b1x m1b2y
         m1p3@(V2 m1p3x m1p3y) = p1 + m1b2
@@ -99,23 +100,31 @@ class (Show c, Mass c) => Collidible c where
             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)
+                (pm2b1x - pm1b2x <= 0 ||
+                pm1b1x - pm2b2x <= 0) &&
+                (pm2b1y - pm1b2y <= 0 ||
+                pm1b1y - pm2b2y <= 0)
+                -- (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)
+                (pm1b1x - pm2b2x <= 0 ||
+                pm2b1x - pm1b2x <= 0) &&
+                (pm1b1y - pm2b2y <= 0 ||
+                pm2b1y - pm1b2y <= 0)
+                -- (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 =
@@ -159,13 +168,13 @@ class (Show c, Mass c) => Collidible c where
                   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)
+                    CollisionImminent tx (V2 (floor $ signum dpx) 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))
+                    CollisionImminent ty (V2 0 (floor $ signum dpy))
+                  -- (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, _, _) ->
@@ -177,33 +186,60 @@ class (Show c, Mass c) => Collidible c where
                     <> fromString (show x)
           in
             case res of
-              CollisionImminent _ _ ->
-                res
-              NoCollision ->
+              c ->
                 if overlap
                 then
-                  let xoverlap = floor (maximum (filter (0 >)
-                        [ pm2b2x - pm2b1x
-                        , pm2b1x - pm1b2x
-                        ]))
-                      yoverlap = floor (maximum (filter (0 >)
-                        [ pm2b1y - pm1b2y
-                        , pm2b2y - pm1b1y
-                        ]))
+                  let xoverlap = floor $ max
+                        (min 0 $ pm2b2x - pm2b1x)
+                        (min 0 $ pm2b1x - pm1b2x)
+                      yoverlap = floor $ max
+                        (min 0 $ pm2b1y - pm1b2y)
+                        (min 0 $ 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
+                    case (xoverlap < 0, yoverlap < 0) of
+                      (True, True) ->
+                        if abs xoverlap < abs yoverlap
+                        then
+                          OverlapCollision
+                            (V2 xoverlap 0)
+                        else
+                          OverlapCollision
+                            (V2 0 yoverlap)
+                      (True, False) ->
+                        OverlapCollision (V2 xoverlap 0)
+                      (False, True) ->
+                        OverlapCollision (V2 0 yoverlap)
+                      (False, False) ->
+                        c
+                else
+                  c
+              -- NoCollision ->
+              --   if overlap
+              --   then
+              --     let xoverlap = floor $ max
+              --           (min 0 $ pm2b2x - pm2b1x)
+              --           (min 0 $ pm2b1x - pm1b2x)
+              --         yoverlap = floor $ max
+              --           (min 0 $ pm2b1y - pm1b2y)
+              --           (min 0 $ pm2b2y - pm1b1y)
+              --     in
+              --       case (xoverlap < 0, yoverlap < 0) of
+              --         (True, True) ->
+              --           if abs xoverlap < abs yoverlap
+              --           then
+              --             OverlapCollision
+              --               (V2 xoverlap 0)
+              --           else
+              --             OverlapCollision
+              --               (V2 0 yoverlap)
+              --         (True, False) ->
+              --           OverlapCollision (V2 xoverlap 0)
+              --         (False, True) ->
+              --           OverlapCollision (V2 0 yoverlap)
+              --         (False, False) ->
+              --           NoCollision
+              --   else
+              --     NoCollision
               _ -> A.log
                 A.Error
                 "Premature overlap collision detection"
@@ -255,17 +291,13 @@ 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'
+      -- v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx
+      -- v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
+      v1x' = 2 * (m1 * dx) / (m1 + m2)
+      v1y' = 2 * (m1 * dy) / (m1 + m2)
+      nvel
+        | m1 == recip 0 = V2 0 0
+        | m2 == recip 0 = V2 dx dy
+        | otherwise = V2 v1x' v1y'
   in
     velocityUpdater mo1 nvel

src/Scenes/Test/Update.hs

@@ -58,11 +58,11 @@ update level dt = liftIO $ do
                               let res = collisionCheck dt tangible1 tangible2
                               in
                                 case res of
-                                  c@(CollisionImminent _ _) ->
+                                  NoCollision -> jacc
+                                  c ->
                                     if qInd /= index
                                     then jacc `V.snoc` (qInd, c)
                                     else jacc
-                                  _ -> jacc
                               )
                             V.empty
                             indexedTangibles
@@ -71,7 +71,13 @@ update level dt = liftIO $ do
                       then iacc
                       else iacc `V.snoc`
                         ( index
-                        , sortOn (collisionTime . snd) (V.toList partners)
+                        , sortOn
+                            (\(_, cr) -> case cr of
+                              CollisionImminent ddt _ -> ddt
+                              OverlapCollision _ -> 0
+                              NoCollision -> dt
+                              )
+                            (V.toList partners)
                         )
                     )
                   V.empty

src/Types/Player.hs

@@ -174,6 +174,7 @@ instance Mass Pituicat where
   move dt cat =
     let dpos = (dt *) <$> velocity cat
         mpos = (dt *) <$>
+          -- pcMoveVel cat
           (if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat
     in
       positionUpdater cat (position cat + dpos + mpos)