clean up mess

extern/.gitignore

@@ -1,20 +0,0 @@
-*.hi
-*.o
-.hsenv*
-.stack-work
-.git
-.cabal-sandbox/
-cabal.sandbox.config
-dist/
-*.prof
-*.aux
-*.hp
-*.ps
-*.swp
-.ghc*
-cabal.project.local*
-dist*/
-report.html
-*.bak
-.direnv/
-.envrc

extern/ChangeLog.md

@@ -1,5 +0,0 @@
-# Revision history for affection
-
-## 0.0.0.7 -- 2017-12-23
-
-* Release with working scaffold for engine subsystems.

extern/LICENSE

@@ -1,165 +0,0 @@
-                  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/README.md

@@ -1,8 +0,0 @@
-# ![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/Setup.hs

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

extern/affection.cabal

@@ -1,181 +0,0 @@
-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.nix

@@ -1,18 +0,0 @@
-{ 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/cabal.project

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

extern/examples/example00/Main.hs

@@ -1,196 +0,0 @@
-{-# 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/examples/example01/Main.hs

@@ -1,251 +0,0 @@
-{-# 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/examples/example01/Types.hs

@@ -1,78 +0,0 @@
-{-# 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/examples/example02/Main.hs

@@ -1,253 +0,0 @@
-{-# 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/examples/example02/Types.hs

@@ -1,78 +0,0 @@
-{-# 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/shell.nix

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

extern/src/Affection.hs

@@ -1,151 +0,0 @@
-{-# 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
-            liftIO SDL.pumpEvents
-            evs <- preHandleEvents =<< liftIO SDL.pollEvents
-            -- handle events
-            handleEvents gameData evs
-            -- execute user defined update loop
-            unless (pausedTime ad) (update gameData dt)
-            -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
-            liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
-            draw gameData
-            liftIO GL.flush
-            -- actual displaying of newly drawn frame
-            mapM_ (SDL.glSwapWindow . (\(_,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/src/Affection/Class.hs

@@ -1,21 +0,0 @@
-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/src/Affection/Logging.hs

@@ -1,54 +0,0 @@
-{-# 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/src/Affection/MessageBus.hs

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

extern/src/Affection/MessageBus/Class.hs

@@ -1,68 +0,0 @@
-{-# 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/src/Affection/MessageBus/Message.hs

@@ -1,9 +0,0 @@
-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/src/Affection/MessageBus/Message/Class.hs

@@ -1,6 +0,0 @@
-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/src/Affection/MessageBus/Message/JoystickMessage.hs

@@ -1,67 +0,0 @@
-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/src/Affection/MessageBus/Message/KeyboardMessage.hs

@@ -1,26 +0,0 @@
-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/src/Affection/MessageBus/Message/MouseMessage.hs

@@ -1,54 +0,0 @@
-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/src/Affection/MessageBus/Message/WindowMessage.hs

@@ -1,106 +0,0 @@
-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/src/Affection/StateMachine.hs

@@ -1,20 +0,0 @@
-{-# 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/src/Affection/Subsystems.hs

@@ -1,9 +0,0 @@
-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/src/Affection/Subsystems/AffectionJoystick.hs

@@ -1,119 +0,0 @@
-{-# 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/src/Affection/Subsystems/AffectionKeyboard.hs

@@ -1,35 +0,0 @@
-{-# 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/src/Affection/Subsystems/AffectionMouse.hs

@@ -1,61 +0,0 @@
-{-# 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/src/Affection/Subsystems/AffectionWindow.hs

@@ -1,74 +0,0 @@
-{-# 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/src/Affection/Subsystems/Class.hs

@@ -1,13 +0,0 @@
-{-# 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/src/Affection/Types.hs

@@ -1,84 +0,0 @@
-{-# 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/src/Affection/Util.hs

@@ -1,86 +0,0 @@
-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 ()