.envrc

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

.gitignore

@@ -16,5 +16,3 @@ cabal.project.local*
 dist*/
 report.html
 *.bak
-.direnv/
-result

affection.cabal

@@ -6,7 +6,7 @@ name:                affection
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.0.0.10
+version:             0.0.0.9
 synopsis:            A simple Game Engine using SDL
 description:         This package contains Affection, a simple game engine
                      written in Haskell using SDL.
@@ -16,7 +16,7 @@ homepage:            https://github.com/nek0/affection#readme
 license:             LGPL-3
 license-file:        LICENSE
 author:              nek0
-maintainer:          nek0@nek0.eu
+maintainer:          nek0@chelnok.de
 category:            Game
 build-type:          Simple
 extra-source-files:  ChangeLog.md
@@ -25,11 +25,11 @@ extra-source-files:  ChangeLog.md
 -- README.
 -- extra-source-files:  
 
-cabal-version:       >=2.0
+cabal-version:       >=1.10
 
 source-repository head
   type:     git
-  location: https://gitea.nek0.eu/nek0/affection.git
+  location: https://github.com/nek0/affection
 
 flag verbose
   description:       Enable verbose debug messages
@@ -67,7 +67,6 @@ library
   exposed-modules:     Affection
                      , Affection.Logging
                      , Affection.Types
-                     , Affection.Class
                      , Affection.StateMachine
                      , Affection.Util
                      , Affection.MessageBus
@@ -85,39 +84,35 @@ library
                      , 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
+  other-extensions:    GADTs
+                     , KindSignatures
+                     , FlexibleInstances
+                     , MultiParamTypeClasses
+                     , UndecidableInstances
   hs-source-dirs:      src
   default-language:    Haskell2010
-  ghc-options:       -threaded -Wall
+  ghc-options:       -Wall
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && < 5
-                     , sdl2 >= 2.5
+                     , sdl2 >= 2.4 && < 2.5
                      , linear
                      , text
                      , mtl
                      , monad-loops
                      , monad-parallel
                      , containers
-                     , clock >= 0.8
+                     , clock
                      , glib
                      , bytestring
                      , OpenGL
-                     , OpenGLRaw
                      , stm
                      , uuid
                      , vector
-                     , resourcet
 
 -- This example shows the message system. only makes sense when compiling with
 -- verbose flag.
@@ -127,11 +122,12 @@ executable example00
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
-  build-depends:     base >=4.9 && < 5
-                   , affection
-                   , sdl2 >= 2.5
-                   , stm
-  if !flag(examples)
+  if flag(examples)
+    build-depends:     base >=4.9 && < 5
+                     , affection
+                     , sdl2
+                     , stm
+  else
     buildable:       False
 
 -- A small game of life implementation
@@ -142,18 +138,19 @@ executable example01
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
-  build-depends:     base >=4.9 && < 5
-                   , affection
-                   , sdl2 >= 2.5
-                   , stm
-                   , OpenGL
-                   , random
-                   , containers
-                   , linear
-                   , matrix
-                   , nanovg >= 0.6.0.0
-                   , deepseq
-  if !flag(examples)
+  if flag(examples)
+    build-depends:     base >=4.9 && < 5
+                     , affection
+                     , sdl2
+                     , stm
+                     , OpenGL
+                     , random
+                     , containers
+                     , linear
+                     , matrix
+                     , nanovg >= 0.6.0.0
+                     , deepseq
+  else
     buildable:       False
 
 -- Another small game of life implementation
@@ -164,16 +161,17 @@ executable example02
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
-  build-depends:     base >=4.9 && < 5
-                   , affection
-                   , sdl2 >= 2.5
-                   , stm
-                   , OpenGL
-                   , random
-                   , containers
-                   , linear
-                   , matrix
-                   , nanovg >= 0.6.0.0
-                   , deepseq
-  if !flag(examples)
+  if flag(examples)
+    build-depends:     base >=4.9 && < 5
+                     , affection
+                     , sdl2
+                     , stm
+                     , OpenGL
+                     , random
+                     , containers
+                     , linear
+                     , matrix
+                     , nanovg >= 0.6.0.0
+                     , deepseq
+  else
     buildable:       False

cabal.project

@@ -1,4 +0,0 @@
-packages: ./*.cabal
-
-package affection
-  flags: +examples

examples/example00/Main.hs

@@ -1,34 +1,21 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Main where
-
 import Affection as A
 
 import Control.Concurrent.STM
-import Control.Concurrent.MVar
-import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad (when)
 
-import qualified SDL
+import qualified SDL hiding (Window(..))
 
 import Data.Maybe (isJust, fromJust)
-import Data.String
 
 data StateData = StateData
   { sdSubs :: Subsystems
-  , sdJoys :: MVar [SDL.Joystick]
-  , doNextStep :: MVar Bool
+  , sdJoys :: [SDL.Joystick]
   }
 
-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
@@ -36,13 +23,36 @@ data Subsystems = Subsystems
   , 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 ())])
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
+newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
+newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
 
-instance Participant Main.Window where
-  type Mesg Main.Window = WindowMessage
+generalSubscribers
+  :: TVar [(UUID, msg -> Affection StateData ())]
+  -> Affection StateData [msg -> Affection StateData ()]
+generalSubscribers t = do
+  subTups <- liftIO $ readTVarIO t
+  return $ map snd subTups
+
+generalSubscribe
+  :: TVar [(UUID, msg -> Affection StateData ())]
+  -> (msg -> Affection StateData())
+  -> Affection StateData UUID
+generalSubscribe t funct = do
+  uuid <- genUUID
+  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+  return uuid
+
+generalUnSubscribe
+  :: TVar [(UUID, msg -> Affection StateData ())]
+  -> UUID
+  -> Affection StateData ()
+generalUnSubscribe t uuid =
+  liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
+
+instance Participant Main.Window StateData where
+  type Mesg Main.Window StateData = WindowMessage
 
   partSubscribers (Window t) = generalSubscribers t
 
@@ -50,11 +60,11 @@ instance Participant Main.Window where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Main.Window where
+instance SDLSubsystem Main.Window StateData where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant Mouse where
-  type Mesg Mouse = MouseMessage
+instance Participant Mouse StateData where
+  type Mesg Mouse StateData = MouseMessage
 
   partSubscribers (Mouse t) = generalSubscribers t
 
@@ -62,11 +72,11 @@ instance Participant Mouse where
 
   partUnSubscribe (Mouse t) = generalUnSubscribe t
 
-instance SDLSubsystem Mouse where
+instance SDLSubsystem Mouse StateData where
   consumeSDLEvents = consumeSDLMouseEvents
 
-instance Participant Keyboard where
-  type Mesg Keyboard = KeyboardMessage
+instance Participant Keyboard StateData where
+  type Mesg Keyboard StateData = KeyboardMessage
 
   partSubscribers (Keyboard t) = generalSubscribers t
 
@@ -74,11 +84,11 @@ instance Participant Keyboard where
 
   partUnSubscribe (Keyboard t) = generalUnSubscribe t
 
-instance SDLSubsystem Keyboard where
+instance SDLSubsystem Keyboard StateData where
   consumeSDLEvents = consumeSDLKeyboardEvents
 
-instance Participant Joystick where
-  type Mesg Joystick = JoystickMessage
+instance Participant Joystick StateData where
+  type Mesg Joystick StateData = JoystickMessage
 
   partSubscribers (Joystick t) = generalSubscribers t
 
@@ -86,7 +96,7 @@ instance Participant Joystick where
 
   partUnSubscribe (Joystick t) = generalUnSubscribe t
 
-instance SDLSubsystem Joystick where
+instance SDLSubsystem Joystick StateData where
   consumeSDLEvents = consumeSDLJoystickEvents
 
 main :: IO ()
@@ -99,14 +109,21 @@ main = do
           [
           ( 0
           , SDL.defaultWindow
-            { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+            { SDL.windowOpenGL = Just SDL.defaultOpenGL
               { SDL.glProfile = SDL.Core SDL.Normal 3 3
               }
             }
-          , SDL.Windowed
           )
           ]
-        } :: AffectionConfig StateData
+        , initScreenMode = SDL.Windowed
+        , canvasSize = Nothing
+        , loadState = load
+        , preLoop = pre
+        , eventLoop = handle
+        , updateLoop = update
+        , drawLoop = draw
+        , cleanUp = clean
+        }
   withAffection conf
 
 load :: IO StateData
@@ -117,80 +134,57 @@ load =
     <*> (Keyboard <$> newTVarIO [])
     <*> (Joystick <$> newTVarIO [])
     )
-    <*> newMVar []
-    <*> newMVar True
+    <*> return []
 
-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))
+pre :: Affection StateData ()
+pre = do
+  sd <- getAffection
+  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
+  _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
+  _ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
   return ()
 
-exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
-exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) =
+exitOnQ :: KeyboardMessage -> Affection StateData ()
+exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeQ -> do
       liftIO $ logIO Debug "Yo dog I heard..."
-      void $ liftIO $ swapMVar nextStep False
+      quit
     _ -> return ()
 
-exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
-exitOnWindowClose nextStep wm =
+exitOnWindowClose :: WindowMessage -> Affection StateData ()
+exitOnWindowClose wm =
   case wm of
     MsgWindowClose _ _ -> do
       liftIO $ logIO Debug "I heard another one..."
-      void $ liftIO $ swapMVar nextStep False
+      quit
     _ -> return ()
 
-joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
-joyConnectDisconnect mvjs msg = do
+joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
+joyConnectDisconnect 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
+    sd <- getAffection
+    putAffection sd
+      { sdJoys = fromJust mj : sdJoys sd
+      }
+  sd <- getAffection
+  njs <- joystickAutoDisconnect (sdJoys sd) msg
+  putAffection sd
+    { sdJoys = njs
+    }
 
-handle :: StateData -> [SDL.EventPayload] -> Affection ()
-handle sd es = do
-  let (Subsystems a b c d) = sdSubs sd
+handle :: [SDL.EventPayload] -> Affection StateData ()
+handle es = do
+  (Subsystems a b c d) <- sdSubs <$> getAffection
   leftovers <- consumeSDLEvents a
     =<< consumeSDLEvents b
     =<< consumeSDLEvents c
     =<< consumeSDLEvents d es
-  mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
-    leftovers
+  mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
 
-update :: StateData -> Double -> Affection ()
-update _ _ = return ()
+update _ = return ()
 
-draw :: StateData -> Affection ()
-draw _ = return ()
+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))

examples/example01/Main.hs

@@ -3,36 +3,30 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 import Affection as A
+import SDL (($=))
 import qualified SDL
+import qualified Graphics.Rendering.OpenGL as GL
 
 import Control.Concurrent.STM
-import Control.Concurrent.MVar
-import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad (when)
 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 Linear
+
 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
 
@@ -46,16 +40,23 @@ main = do
           [
           ( 0
           , SDL.defaultWindow
-            { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+            { SDL.windowOpenGL = Just SDL.defaultOpenGL
               { SDL.glProfile = SDL.Core SDL.Normal 3 3
               }
             , SDL.windowInitialSize = SDL.V2 600 600
             , SDL.windowResizable = True
             }
-          , SDL.Windowed
           )
           ]
-        } :: AffectionConfig UserData
+        , initScreenMode = SDL.Windowed
+        , canvasSize = Nothing
+        , loadState = load
+        , preLoop = pre
+        , eventLoop = handle
+        , updateLoop = update
+        , drawLoop = draw
+        , cleanUp = clean
+        }
   withAffection conf
 
 load :: IO UserData
@@ -64,146 +65,156 @@ load = do
   liftIO $ logIO A.Debug "init GLEW"
   _ <- glewInit
   liftIO $ logIO A.Debug "making random"
-  randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+  randList <- mapM (\_ -> randomRIO (0,1)) [0..3599]
   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
+  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
+  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
+  return $ UserData
     { subsystems = Subsystems
       (Window empty1)
       (Keyboard empty3)
-    , lifeMat = life
-    , foodMat = food
-    , timeMat = time
+    , lifeMat = fullMatrix
+    , foodMat = fromList 60 60 (repeat 10)
+    , timeMat = M.zero 60 60
     , 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))
+pre :: Affection UserData ()
+pre = do
+  sd <- getAffection
+  _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
+  _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
+  _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
+  _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
+  _ <- partSubscribe (subWindow   $ subsystems sd) exitOnWindowClose
+  _ <- partSubscribe (subWindow   $ subsystems sd) (fitViewport (600/600))
+  now <- getElapsedTime
+  putAffection sd
 
-toggleFullScreen :: KeyboardMessage -> Affection ()
+toggleFullScreen :: KeyboardMessage -> Affection UserData ()
 toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
-  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
+  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
   | otherwise = return ()
 toggleFullScreen _ = return ()
 
-exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
-exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
+exitOnEsc :: KeyboardMessage -> Affection UserData ()
+exitOnEsc (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
+      quit
     _ -> return ()
-exitOnEsc _ _ = return ()
+exitOnEsc _ = return ()
 
-reloadOnR :: UserData -> KeyboardMessage -> Affection ()
-reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
+reloadOnR :: KeyboardMessage -> Affection UserData ()
+reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
-    SDL.KeycodeR -> reload ud
+    SDL.KeycodeR -> reload
     _ -> return ()
+reloadOnR _ = return ()
 
-reload :: UserData -> Affection ()
-reload ud = do
-  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+reload :: Affection UserData ()
+reload = do
+  ud <- getAffection
+  now <- getElapsedTime
+  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
   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)
+  putAffection ud
+    { lifeMat = fullMatrix
+    , foodMat = fromList 60 60 (repeat 10)
+    , timeMat = M.zero 60 60
+    }
 
-showFPS :: KeyboardMessage -> Affection ()
+showFPS :: KeyboardMessage -> Affection UserData ()
 showFPS (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeF -> do
       dt <- getDelta
-      liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
+      liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
     _ -> return ()
+showFPS _ = return ()
 
-exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
-exitOnWindowClose step wm =
+exitOnWindowClose :: WindowMessage -> Affection UserData ()
+exitOnWindowClose wm =
   case wm of
     MsgWindowClose _ _ -> do
       liftIO $ logIO A.Debug "I heard another one..."
-      void $ liftIO $ swapMVar step False
+      quit
     _ -> return ()
+exitOnWindowClose _ = return ()
 
-handle :: UserData -> [SDL.EventPayload] -> Affection ()
-handle ud es = do
-  let (Subsystems a b) = subsystems ud
+handle :: [SDL.EventPayload] -> Affection UserData ()
+handle es = do
+  (Subsystems a b) <- subsystems <$> getAffection
   _ <- 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)
+update :: Double -> Affection UserData ()
+update _ = do
+  ud <- getAffection
   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 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud))
             <->
-            (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
+            (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud))
           | x == 1 && y == 60 =
-            (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
+            (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud))
             <->
-            (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
+            (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud))
           | x == 60 && y == 1 =
-            (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
+            (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud))
             <->
-            (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
+            (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud))
           | x == 60 && y == 60 =
-            (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
+            (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud))
             <->
-            (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
+            (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud))
           | x == 1 =
-            (submatrix (y - 1) (y + 1) 60 60 pastLife)
+            (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud))
             <|>
-            (submatrix (y - 1) (y + 1) 1 2 pastLife)
+            (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud))
           | y == 1 =
-            (submatrix 60 60 (x - 1) (x + 1) pastLife)
+            (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud))
             <->
-            (submatrix 1 2 (x - 1) (x + 1) pastLife)
+            (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud))
           | x == 60 =
-            (submatrix (y - 1) (y + 1) 59 60 pastLife)
+            (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud))
             <|>
-            (submatrix (y - 1) (y + 1) 1 1 pastLife)
+            (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud))
           | y == 60 =
-            (submatrix 59 60 (x -1 ) (x + 1) pastLife)
+            (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud))
             <->
-            (submatrix 1 1 (x - 1) (x + 1) pastLife)
+            (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud))
           | otherwise =
-            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
+            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
         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)
+        ret
+          | life == 0 && lifeMat ud M.! (y, x) == 0 =
+            ( 0
+            , if timeMat ud M.! (y, x) >= 10
+              then min 10 (foodMat ud M.! (y, x) + 1)
+              else min 10 (foodMat ud M.! (y, x))
+            , timeMat ud M.! (y, x) + 1
+            )
+          | otherwise = (1, 1, 1)
+    if lifeMat ud M.! (y, x) == 1
+    then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0
+      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
+      else return (0, foodMat ud M.! (y, x), 0)
+    else if life == 3 && foodMat ud M.! (y, x) > 0
+      then return (1, (foodMat ud 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
+        , if timeMat ud M.! (y, x) > 10
+          then min 10 ((foodMat ud M.! (y, x)) + 1)
+          else min 10 (foodMat ud M.! (y, x))
+        , timeMat ud M.! (y, x) + 1
         )
     ) [0..3599]
   let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@@ -211,21 +222,22 @@ update ud _ = do
       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
+    reload
+  else
+    putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
+      { lifeMat = newLifeMat
+      --, foodMat = newFoodMat
+      , timeMat = 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)
+draw :: Affection UserData ()
+draw = do
+  ud <- getAffection
   liftIO $ do
     beginFrame (nano ud) 600 600 1
     save (nano ud)
@@ -233,7 +245,7 @@ draw ud = do
       let x = coord `mod` 60
           y = coord `div` 60
           ctx = nano ud
-          mult = life M.! (x + 1, y + 1)
+          mult = lifeMat ud M.! (x + 1, y + 1)
       -- logIO A.Debug $ show mult
       beginPath ctx
       rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
@@ -241,11 +253,10 @@ draw ud = do
       then
         fillColor ctx (rgba 255 255 255 255)
       else
-        fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255)
+        fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
       fill ctx
       ) [0..3599]
     restore (nano ud)
     endFrame (nano ud)
 
-clean :: UserData -> IO ()
 clean _ = return ()

examples/example01/Types.hs

@@ -10,15 +10,14 @@ import Data.Matrix as M
 import NanoVG
 
 import Control.Concurrent.STM
-import Control.Concurrent.MVar
+import Control.Monad.IO.Class (liftIO)
 
 data UserData = UserData
-  { lifeMat    :: MVar (Matrix Word)
-  , foodMat    :: MVar (Matrix Word)
-  , timeMat    :: MVar (Matrix Word)
+  { lifeMat    :: Matrix Word
+  , foodMat    :: Matrix Word
+  , timeMat    :: Matrix Word
   , subsystems :: Subsystems
   , nano       :: Context
-  , doNextStep :: MVar Bool
   }
 
 data Subsystems = Subsystems
@@ -26,12 +25,12 @@ data Subsystems = Subsystems
   , subKeyboard :: Types.Keyboard
   }
 
-newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
 
-newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
 
-instance Participant Types.Window where
-  type Mesg Types.Window = WindowMessage
+instance Participant Types.Window UserData where
+  type Mesg Types.Window UserData = WindowMessage
 
   partSubscribers (Window t) = do
     subTups <- liftIO $ readTVarIO t
@@ -41,11 +40,11 @@ instance Participant Types.Window where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Types.Window where
+instance SDLSubsystem Types.Window UserData where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant Keyboard where
-  type Mesg Keyboard = KeyboardMessage
+instance Participant Keyboard UserData where
+  type Mesg Keyboard UserData = KeyboardMessage
 
   partSubscribers (Keyboard t) = do
     subTups <- liftIO $ readTVarIO t
@@ -55,24 +54,24 @@ instance Participant Keyboard where
 
   partUnSubscribe (Keyboard t) = generalUnSubscribe t
 
-instance SDLSubsystem Keyboard where
+instance SDLSubsystem Keyboard UserData where
   consumeSDLEvents = consumeSDLKeyboardEvents
 
 generalSubscribe
-  :: TVar [(UUID, msg -> Affection ())]
-  -> (msg -> Affection ())
-  -> Affection UUID
+  :: TVar [(UUID, msg -> Affection UserData ())]
+  -> (msg -> Affection UserData ())
+  -> Affection UserData UUID
 generalSubscribe t funct = do
   uuid <- genUUID
   liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
   return uuid
 
 generalUnSubscribe
-  :: TVar [(UUID, msg -> Affection ())]
+  :: TVar [(UUID, msg -> Affection UserData ())]
   -> UUID
-  -> Affection ()
+  -> Affection UserData ()
 generalUnSubscribe t uuid =
   liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
   where
-    filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
+    filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
     filterMsg (u, _) p = u /= p

examples/example02/Main.hs

@@ -3,36 +3,30 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 import Affection as A
+import SDL (($=))
 import qualified SDL
+import qualified Graphics.Rendering.OpenGL as GL
 
 import Control.Concurrent.STM
-import Control.Concurrent.MVar
-import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad (when)
 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 Linear
+
 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
 
@@ -49,16 +43,23 @@ main = do
           [
           ( 0
           , SDL.defaultWindow
-            { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+            { SDL.windowOpenGL = Just SDL.defaultOpenGL
               { SDL.glProfile = SDL.Core SDL.Normal 3 3
               }
             , SDL.windowInitialSize = SDL.V2 600 600
             , SDL.windowResizable = True
             }
-          , SDL.Windowed
           )
           ]
-        } :: AffectionConfig UserData
+        , initScreenMode = SDL.Windowed
+        , canvasSize = Nothing
+        , loadState = load
+        , preLoop = pre
+        , eventLoop = handle
+        , updateLoop = update
+        , drawLoop = draw
+        , cleanUp = clean
+        }
   withAffection conf
 
 load :: IO UserData
@@ -67,145 +68,156 @@ load = do
   liftIO $ logIO A.Debug "init GLEW"
   _ <- glewInit
   liftIO $ logIO A.Debug "making random"
-  randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+  randList <- mapM (\_ -> randomRIO (0,1)) [0..3599]
   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
+  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
+  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
+  return $ UserData
     { subsystems = Subsystems
       (Window empty1)
       (Keyboard empty3)
-    , lifeMat = life
-    , foodMat = food
-    , timeMat = time
+    , lifeMat = fullMatrix
+    , foodMat = fromList 60 60 (repeat maxFood)
+    , timeMat = M.zero 60 60
     , 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))
+pre :: Affection UserData ()
+pre = do
+  sd <- getAffection
+  _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
+  _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
+  _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
+  _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
+  _ <- partSubscribe (subWindow   $ subsystems sd) exitOnWindowClose
+  _ <- partSubscribe (subWindow   $ subsystems sd) (fitViewport (600/600))
+  now <- getElapsedTime
+  putAffection sd
 
-toggleFullScreen :: KeyboardMessage -> Affection ()
+toggleFullScreen :: KeyboardMessage -> Affection UserData ()
 toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
-  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
+  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
   | otherwise = return ()
 toggleFullScreen _ = return ()
 
-exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
-exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
+exitOnEsc :: KeyboardMessage -> Affection UserData ()
+exitOnEsc (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
+      quit
     _ -> return ()
-exitOnEsc _ _ = return ()
+exitOnEsc _ = return ()
 
-reloadOnR :: UserData -> KeyboardMessage -> Affection ()
-reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
+reloadOnR :: KeyboardMessage -> Affection UserData ()
+reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
-    SDL.KeycodeR -> reload ud
+    SDL.KeycodeR -> reload
     _ -> return ()
+reloadOnR _ = return ()
 
-reload :: UserData -> Affection ()
-reload ud = do
-  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
+reload :: Affection UserData ()
+reload = do
+  ud <- getAffection
+  now <- getElapsedTime
+  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
   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)
+  putAffection ud
+    { lifeMat = fullMatrix
+    , foodMat = fromList 60 60 (repeat maxFood)
+    , timeMat = M.zero 60 60
+    }
 
-showFPS :: KeyboardMessage -> Affection ()
+showFPS :: KeyboardMessage -> Affection UserData ()
 showFPS (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeF -> do
       dt <- getDelta
-      liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
+      liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
     _ -> return ()
+showFPS _ = return ()
 
-exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
-exitOnWindowClose step wm =
+exitOnWindowClose :: WindowMessage -> Affection UserData ()
+exitOnWindowClose wm =
   case wm of
     MsgWindowClose _ _ -> do
       liftIO $ logIO A.Debug "I heard another one..."
-      void $ liftIO $ swapMVar step False
+      quit
     _ -> return ()
+exitOnWindowClose _ = return ()
 
-handle :: UserData -> [SDL.EventPayload] -> Affection ()
-handle ud es = do
-  let (Subsystems a b) = subsystems ud
+handle :: [SDL.EventPayload] -> Affection UserData ()
+handle es = do
+  (Subsystems a b) <- subsystems <$> getAffection
   _ <- 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)
+update :: Double -> Affection UserData ()
+update _ = do
+  ud <- getAffection
   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 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud))
             <->
-            (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
+            (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud))
           | x == 1 && y == 60 =
-            (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
+            (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud))
             <->
-            (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
+            (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud))
           | x == 60 && y == 1 =
-            (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
+            (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud))
             <->
-            (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
+            (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud))
           | x == 60 && y == 60 =
-            (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
+            (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud))
             <->
-            (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
+            (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud))
           | x == 1 =
-            (submatrix (y - 1) (y + 1) 60 60 pastLife)
+            (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud))
             <|>
-            (submatrix (y - 1) (y + 1) 1 2 pastLife)
+            (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud))
           | y == 1 =
-            (submatrix 60 60 (x - 1) (x + 1) pastLife)
+            (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud))
             <->
-            (submatrix 1 2 (x - 1) (x + 1) pastLife)
+            (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud))
           | x == 60 =
-            (submatrix (y - 1) (y + 1) 59 60 pastLife)
+            (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud))
             <|>
-            (submatrix (y - 1) (y + 1) 1 1 pastLife)
+            (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud))
           | y == 60 =
-            (submatrix 59 60 (x -1 ) (x + 1) pastLife)
+            (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud))
             <->
-            (submatrix 1 1 (x - 1) (x + 1) pastLife)
+            (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud))
           | otherwise =
-            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
+            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
         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)
+        ret
+          | life == 0 && lifeMat ud M.! (y, x) == 0 =
+            ( 0
+            , if timeMat ud M.! (y, x) >= 10
+              then min 10 (foodMat ud M.! (y, x) + 1)
+              else min 10 (foodMat ud M.! (y, x))
+            , timeMat ud M.! (y, x) + 1
+            )
+          | otherwise = (1, 1, 1)
+    if lifeMat ud M.! (y, x) == 1
+    then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0
+      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
+      else return (0, foodMat ud M.! (y, x), 0)
+    else if life == 3 && foodMat ud M.! (y, x) > 0
+      then return (1, (foodMat ud 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
+        , if timeMat ud M.! (y, x) > 10
+          then min maxFood ((foodMat ud M.! (y, x)) + 1)
+          else min maxFood (foodMat ud M.! (y, x))
+        , timeMat ud M.! (y, x) + 1
         )
     ) [0..3599]
   let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@@ -213,41 +225,41 @@ update ud _ = do
       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
+    reload
+  else
+    putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
+      { lifeMat = newLifeMat
+      , foodMat = newFoodMat
+      , timeMat = newTimeMat
+      }
 
 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)
+draw :: Affection UserData ()
+draw = do
+  ud <- getAffection
+  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
-          multiplicator = pastLife M.! (x + 1, y + 1)
+          mult = lifeMat ud 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
+      if mult == 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)
+        fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (foodMat ud M.! (x+1, y+1))) 0 255)
       fill ctx
       ) [0..3599]
     restore (nano ud)
     endFrame (nano ud)
 
-clean :: UserData -> IO ()
 clean _ = return ()

examples/example02/Types.hs

@@ -10,15 +10,14 @@ import Data.Matrix as M
 import NanoVG
 
 import Control.Concurrent.STM
-import Control.Concurrent.MVar
+import Control.Monad.IO.Class (liftIO)
 
 data UserData = UserData
-  { lifeMat    :: MVar (Matrix Word)
-  , foodMat    :: MVar (Matrix Word)
-  , timeMat    :: MVar (Matrix Word)
+  { lifeMat    :: Matrix Word
+  , foodMat    :: Matrix Word
+  , timeMat    :: Matrix Word
   , subsystems :: Subsystems
   , nano       :: Context
-  , doNextStep :: MVar Bool
   }
 
 data Subsystems = Subsystems
@@ -26,12 +25,12 @@ data Subsystems = Subsystems
   , subKeyboard :: Types.Keyboard
   }
 
-newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
 
-newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
 
-instance Participant Types.Window where
-  type Mesg Types.Window = WindowMessage
+instance Participant Types.Window UserData where
+  type Mesg Types.Window UserData = WindowMessage
 
   partSubscribers (Window t) = do
     subTups <- liftIO $ readTVarIO t
@@ -41,11 +40,11 @@ instance Participant Types.Window where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Types.Window where
+instance SDLSubsystem Types.Window UserData where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant Keyboard where
-  type Mesg Keyboard = KeyboardMessage
+instance Participant Keyboard UserData where
+  type Mesg Keyboard UserData = KeyboardMessage
 
   partSubscribers (Keyboard t) = do
     subTups <- liftIO $ readTVarIO t
@@ -55,24 +54,24 @@ instance Participant Keyboard where
 
   partUnSubscribe (Keyboard t) = generalUnSubscribe t
 
-instance SDLSubsystem Keyboard where
+instance SDLSubsystem Keyboard UserData where
   consumeSDLEvents = consumeSDLKeyboardEvents
 
 generalSubscribe
-  :: TVar [(UUID, msg -> Affection ())]
-  -> (msg -> Affection ())
-  -> Affection UUID
+  :: TVar [(UUID, msg -> Affection UserData ())]
+  -> (msg -> Affection UserData ())
+  -> Affection UserData UUID
 generalSubscribe t funct = do
   uuid <- genUUID
   liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
   return uuid
 
 generalUnSubscribe
-  :: TVar [(UUID, msg -> Affection ())]
+  :: TVar [(UUID, msg -> Affection UserData ())]
   -> UUID
-  -> Affection ()
+  -> Affection UserData ()
 generalUnSubscribe t uuid =
   liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
   where
-    filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
+    filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
     filterMsg (u, _) p = u /= p

flake.lock

@@ -1,60 +0,0 @@
-{
-  "nodes": {
-    "flake-utils": {
-      "inputs": {
-        "systems": "systems"
-      },
-      "locked": {
-        "lastModified": 1694529238,
-        "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "nixpkgs": {
-      "locked": {
-        "lastModified": 1700844339,
-        "narHash": "sha256-VRlPYk0eRn1ao75hoA99LGehYhxZH5RlkP1YXpVROHM=",
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "rev": "33576fdfce2d11204067d6cfa99a2f990ef2169a",
-        "type": "github"
-      },
-      "original": {
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "type": "github"
-      }
-    },
-    "root": {
-      "inputs": {
-        "flake-utils": "flake-utils",
-        "nixpkgs": "nixpkgs"
-      }
-    },
-    "systems": {
-      "locked": {
-        "lastModified": 1681028828,
-        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
-        "owner": "nix-systems",
-        "repo": "default",
-        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
-        "type": "github"
-      },
-      "original": {
-        "owner": "nix-systems",
-        "repo": "default",
-        "type": "github"
-      }
-    }
-  },
-  "root": "root",
-  "version": 7
-}

flake.nix

@@ -1,54 +0,0 @@
-{
-  description = "A game stub written in Haskell";
-
-  inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs";
-    flake-utils.url = "github:numtide/flake-utils";
-  };
-
-  outputs = { self, nixpkgs, flake-utils }:
-    flake-utils.lib.eachDefaultSystem (system:
-      let
-        pkgs = nixpkgs.legacyPackages.${system};
-
-        haskellPackages = pkgs.haskellPackages;
-
-        jailbreakUnbreak = pkg:
-          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
-
-        packageName = "affection";
-      in rec {
-        packages.${packageName} = # (ref:haskell-package-def)
-          haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" {
-            # Dependency overrides go here
-          };
-
-        defaultPackage = self.packages.${system}.${packageName};
-
-        apps = {
-          example00 = {
-            type = "app";
-            program = "${self.packages.${system}.${packageName}}/bin/example00";
-          };
-          example01 = {
-            type = "app";
-            program = "${self.packages.${system}.${packageName}}/bin/example01";
-          };
-          example02 = {
-            type = "app";
-            program = "${self.packages.${system}.${packageName}}/bin/example02";
-          };
-        };
-
-        devShell = haskellPackages.shellFor {
-          packages = p: [ defaultPackage ];
-          withHoogle = true;
-          buildInputs = with haskellPackages; [
-            haskell-language-server
-            ghcid
-            cabal-install
-          ] ++ (builtins.attrValues self.packages.${system});
-        };
-      });
-}
-

notes/TODO.md

@@ -0,0 +1,9 @@
+# TODO
+
+Implement following things in approximately this Order:
+
+* Message bus
+* Console
+* GUI
+* Framework
+* Everything else

shell.nix

@@ -1,7 +1,123 @@
-{ pkgs ? import <nixpkgs> {}}:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
 
 let
-  affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
-  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
+
+  inherit (nixpkgs) pkgs;
+
+  nanovgNeko = 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";
+      src = ../nanovg-hs;
+      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
+    }:
+    mkDerivation {
+      pname = "glib";
+      version = "0.13.6.0";
+      sha256 = "4e71062c6a458440294d820e21449aa4666deed2ea233ef5915da7c1d4aee8eb";
+      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;
+    }) {};
+
+  sdl2Nek0 = with haskellPackages; callPackage(
+    { mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2
+    , StateVar, stdenv, text, transformers, vector, weigh
+    }:
+    mkDerivation {
+      pname = "sdl2";
+      version = "2.4.1.0";
+      sha256 = "21a569c0c19f8ff2bbe1cf1d3eb32f65e8143806de353cedd240df5e9d088b5c";
+      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 ];
+      doCheck = false;
+      description = "Both high- and low-level bindings to the SDL library (version 2.0.4+).";
+      license = stdenv.lib.licenses.bsd3;
+    }) {};
+
+  f = { mkDerivation, base, bytestring, clock, containers, deepseq
+      , linear, matrix, monad-loops, monad-parallel, mtl
+      , OpenGL, random, stdenv, stm, text, uuid, vector
+      }:
+      mkDerivation {
+        pname = "affection";
+        version = "0.0.0.9";
+        src = ./.;
+        configureFlags = [ "-fexamples" ];
+        isLibrary = true;
+        isExecutable = true;
+        libraryHaskellDepends = [
+          base bytestring clock containers glib linear monad-loops
+          monad-parallel mtl OpenGL sdl2Nek0 stm text uuid vector
+        ];
+        executableHaskellDepends = [
+          base containers deepseq linear matrix nanovgNeko OpenGL random sdl2Nek0 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
-  affection.env
+
+  if pkgs.lib.inNixShell then drv.env else drv

src/Affection.hs

@@ -1,8 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE Strict #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE BangPatterns #-}
 module Affection
     ( withAffection
     , get
@@ -16,25 +13,15 @@ import qualified SDL
 import qualified SDL.Raw.Video as SDL (glSetAttribute)
 import qualified SDL.Raw.Enum as SDL
 
-import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-import qualified Graphics.GL as GLRaw
-
-import Foreign.Marshal.Array
-
-import qualified Data.ByteString as B
-
-import Data.String (fromString)
-
 import System.Clock
 
 import Control.Monad.Loops
 import Control.Monad.State.Strict
-import Control.Monad.Trans.Resource
+import Control.Monad.IO.Class (liftIO)
 
--- internal imports
+import Foreign.C.Types (CInt(..))
 
 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
@@ -42,163 +29,102 @@ import Affection.Subsystems as A
 
 import Affection.Logging as A
 
+import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
+
+
 -- | Main function which bootstraps everything else.
 withAffection
-  :: forall us. (Affectionate us)
-  => AffectionConfig us -- ^ Configuration of the Game and its engine.
+  :: AffectionConfig us -- ^ Configuration of the Game and its engine.
   -> IO ()
-withAffection AffectionConfig{..} = runResourceT $ do
+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…
-  renderQuality <- SDL.get SDL.HintRenderScaleQuality
-  when (renderQuality /= SDL.ScaleLinear) $
-    liftIO $ logIO Warn "Linear texture filtering not enabled!"
-  void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
-
+  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 <-
+  windows <- zip (map fst windowConfigs) <$>
     mapM
-      (\(_, sdlWindowConfig, mode) -> do
-        (windowKey, window) <-
-          allocate
-            (SDL.createWindow windowTitle sdlWindowConfig)
-            (\window -> do
-              logIO Debug "Destroying Window"
-              SDL.destroyWindow window
-              )
-        return $ AffectionWindow window windowKey mode
-        )
-      windowConfigs
-
-  -- Show windows
-  mapM_ (SDL.showWindow . awWindow) windows
-
-  -- set modes of windows
-  mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows
-
-  -- Make GL context shareable
-  void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
-
-  -- Create OpenGL contexts
-  contexts <-
-    mapM
-      (\(AffectionWindow window _ _) -> do
-        (contextKey, context) <-
-          allocate
-            (SDL.glCreateContext window)
-            (\context -> do
-              logIO Debug "Destroying context"
-              SDL.glDeleteContext context
-              )
-        return $ AffectionContext context contextKey
-        )
-      windows
-
-  -- sync updates with monitor
+    (\wc -> SDL.createWindow windowTitle (snd wc))
+    windowConfigs
+  mapM_ (SDL.showWindow . snd) windows
+  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
+  contexts <- zip (map fst windows) <$> mapM (SDL.glCreateContext . snd) windows
+  -- let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfigs
+  --     (w, h) = case canvasSize of
+  --       Just (cw, ch) -> (cw, ch)
+  --       Nothing       -> (fromIntegral rw, fromIntegral rh)
+  mapM_ (flip SDL.setWindowMode initScreenMode . snd) windows
   -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
-
-  -- print current used GL Version
-  version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
-  liftIO $ print (B.pack version)
-
-  -- get current time
   liftIO $ logIO Debug "Getting Time"
-  execTime <- liftIO $ getTime Monotonic
+  -- get current time
+  execTime <- getTime Monotonic
   liftIO $ logIO Debug "Loading initial data container"
-
-  -- construct game data object from provided Affectionate instance
-  (gameDataKey, gameData) <-
-    allocate
-      (liftIO $ loadState @us)
-      (liftIO . cleanUp)
-  -- build state container
-  let initContainer = AffectionData
-        { drawWindows     = windows
-        , glContext       = contexts
-        , elapsedTime     = 0
-        , deltaTime       = 0
-        , sysTime         = execTime
-        , pausedTime      = False
-        }
-
-  -- initialize and run state
-  void $ liftIO $ runAffection initContainer
+  initContainer <- (\x -> AffectionData
+    { quitEvent       = False
+    , userState       = x
+    , drawWindows     = windows
+    , glContext       = contexts
+    , screenMode      = initScreenMode
+    , elapsedTime     = 0
+    , deltaTime       = 0
+    , sysTime         = execTime
+    , pausedTime      = False
+    }) <$> loadState
+  (_, nState) <- runStateT ( A.runState $ do
+    liftIO $ logIO Debug "Starting Loop"
+    preLoop
+    whileM_ (not . A.quitEvent <$> get)
       (do
-        liftIO $ logIO Debug "Running Pre-Loop stage"
-
-        -- run preLoop function from Affectionate
-        preLoop gameData
-        liftIO $ logIO Debug "Starting Loop"
-        whileM_ (hasNextStep gameData)
-          (do
-            -- get state
-            ad <- get
-
-            -- Measure time difference form last run
-            now      <- liftIO $ getTime Monotonic
-            let lastTime = sysTime ad
-
-            -- compute dt and update elapsedTime
-            let dt = fromIntegral
-                   (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
-                ne = elapsedTime ad + dt
-
-            -- update state data object with new time values
-            put $ ad
-              { elapsedTime = ne
-              , deltaTime = dt
-              }
-
-            -- poll events
-            liftIO SDL.pumpEvents
-            evs <- preHandleEvents =<< liftIO SDL.pollEvents
-
-            -- handle events
-            handleEvents gameData evs
-
-            -- execute user defined update loop
-            unless (pausedTime ad) (update gameData dt)
-
-            -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
-            liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
-            draw gameData
-            liftIO GL.flush
-
-            -- actual displaying of newly drawn frame
-            mapM_ (SDL.glSwapWindow . awWindow) windows
-
-            -- save new time
-            ad3 <- get
-            when (sysTime ad == sysTime ad3) (
-              put ad3
-                { sysTime = now
-                }
-              )
-            )
-        )
-  -- Cleanup works
+        -- 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
+        put $ ad
+          { elapsedTime = ne
+          , deltaTime = dt
+          }
+        -- poll events
+        evs <- preHandleEvents =<< liftIO SDL.pollEvents
+        -- handle events
+        eventLoop evs
+        -- execute user defined update loop
+        unless (pausedTime ad) (updateLoop dt)
+        -- execute user defined draw loop
+        liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
+        drawLoop
+        liftIO GL.flush
+        -- actual displaying of newly drawn frame
+        mapM_ (SDL.glSwapWindow . snd) windows
+        -- save new time
+        ad3 <- get
+        when (sysTime ad == sysTime ad3) (
+          put ad3
+            { sysTime = now
+            }
+          )
+      )
+    ) initContainer
   liftIO $ logIO Debug "Loop ended. Cleaning"
-  release gameDataKey
-  -- mapM_ (SDL.glDeleteContext . snd) contexts
-  -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
+  cleanUp $ userState nState
+  liftIO $ logIO Debug "Destroying Window"
+  mapM_ (SDL.glDeleteContext . snd) contexts
+  mapM_ (SDL.destroyWindow . snd) windows
   -- SDL.quit -- <- This causes segfaults depending on hardware
   liftIO $ logIO Debug "This is the end"
-
-runAffection
-  :: AffectionData
-  -> AffectionState AffectionData ResIO a
-  -> IO (a, AffectionData)
-runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState

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

src/Affection/Logging.hs

@@ -3,8 +3,6 @@
 -- from "Debug.Trace".
 module Affection.Logging where
 
-import qualified Data.Text as T
-
 import Debug.Trace
 
 -- | The log level definition
@@ -17,38 +15,38 @@ data LogLevel
 -- | Pure logging function
 log
   :: LogLevel -- ^ Log level to log to
-  -> T.Text   -- ^ The message string
+  -> String   -- ^ The message string
   -> a        -- ^ Arbitrary datatype to return
   -> a        -- ^ Returned data
 #if defined(VERBOSE)
-log Verbose s = trace ("VERBOSE: " ++ T.unpack s)
+log Verbose s = trace ("VERBOSE: " ++ s)
 #endif
 #if defined(DEBUG) || defined(VERBOSE)
-log Debug s = trace ("DEBUG: " ++ T.unpack s)
+log Debug s = trace ("DEBUG: " ++ s)
 #endif
 #if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-log Warn s = trace ("WARN: " ++ T.unpack s)
+log Warn s = trace ("WARN: " ++ s)
 #endif
 #if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-log Error s = trace ("ERROR: " ++ T.unpack s)
+log Error s = trace ("ERROR: " ++ s)
 #endif
 log _ _ = id
 
 -- | Manadic logging function residing in the 'IO' Monad
 logIO
   :: LogLevel -- ^ Log level to log to
-  -> T.Text   -- ^ The message string
+  -> String   -- ^ The message string
   -> IO ()
 #if defined(VERBOSE)
-logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s)
+logIO Verbose s = traceIO ("VERBOSE: " ++ s)
 #endif
 #if defined(DEBUG) || defined(VERBOSE)
-logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s)
+logIO Debug s = traceIO ("DEBUG: " ++ s)
 #endif
 #if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-logIO Warn s = traceIO ("WARN: " ++ T.unpack s)
+logIO Warn s = traceIO ("WARN: " ++ s)
 #endif
 #if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-logIO Error s = traceIO ("ERROR: " ++ T.unpack s)
+logIO Error s = traceIO ("ERROR: " ++ s)
 #endif
 logIO _ _ = return ()

src/Affection/MessageBus.hs

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

src/Affection/MessageBus/Class.hs

@@ -17,30 +17,28 @@ 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
+class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
   -- | Message datatype
-  type Mesg prt :: *
+  type Mesg prt us :: *
 
   -- | Function to get the list of subscribers from the participant
   partSubscribers
     :: prt
     -- ^ the 'Participant''s subscriber storage
-    -> Affection [Mesg prt -> Affection ()]
+    -> Affection us [Mesg prt us -> Affection us ()]
     -- ^ List of Subscriber functions
 
   -- | Subscribe to the 'Participant''s events
   partSubscribe
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> (Mesg prt -> Affection ())
+    -> (Mesg prt us -> Affection us ())
     -- ^ What to do in case of a 'Message'
     -- (Subscriber function)
-    -> Affection UUID
+    -> Affection us UUID
     -- ^ 'UUID' of the registered subscriber Function
 
   -- | Unsubscribe a Subscriber function from Participant
@@ -49,20 +47,20 @@ class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where
     -- ^ The 'Participant''s subscriber storage to unsubscribe from
     -> UUID
     -- ^ The subscriber function's 'UUID'
-    -> Affection ()
+    -> Affection us ()
 
   -- | Get the 'Participant' to emit a 'Message' on all of its subscribers
   partEmit
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> Mesg prt
+    -> Mesg prt us
     -- ^ The 'Message' to emit
-    -> Affection ()
+    -> Affection us ()
   partEmit p m = do
-    liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m)
+    liftIO $ logIO Verbose $ "Emitting message: " ++ show m
     l <- partSubscribers p
     mapM_ ($ m) l
 
 -- | Helper function to generate new 'UUID's
-genUUID :: Affection UUID
+genUUID :: Affection us UUID
 genUUID = liftIO nextRandom

src/Affection/StateMachine.hs

@@ -7,14 +7,14 @@ import Affection.Types
 import qualified SDL
 
 -- | Typeclass for simple scaffolding of a state machine
-class StateMachine us a where
+class StateMachine a us where
   -- | State load routine
-  smLoad   :: a -> us -> Affection ()
+  smLoad   :: a -> Affection us ()
   -- | state update routine
-  smUpdate :: a -> us -> Double -> Affection ()
+  smUpdate :: a -> Double -> Affection us ()
   -- | State event handler routine
-  smEvent  :: a -> us -> [SDL.EventPayload] -> Affection ()
+  smEvent  :: a -> [SDL.EventPayload] -> Affection us ()
   -- | State draw routine
-  smDraw   :: a -> us -> Affection ()
+  smDraw   :: a -> Affection us ()
   -- | State clean routine
-  smClean  :: a -> us -> Affection ()
+  smClean  :: a -> Affection us ()

src/Affection/Subsystems/AffectionJoystick.hs

@@ -13,7 +13,6 @@ 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(..))
 
@@ -22,15 +21,15 @@ 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)
+  :: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
   => am                              -- ^ The message system participant
   -> [SDL.EventPayload]              -- ^ Incoming events
-  -> Affection [SDL.EventPayload] -- ^ Leftover SDL events
+  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
 consumeSDLJoystickEvents am = doConsume
   where
     doConsume
       :: [SDL.EventPayload]
-      -> Affection [SDL.EventPayload]
+      -> Affection us [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime
@@ -81,14 +80,13 @@ consumeSDLJoystickEvents am = doConsume
 joystickAutoConnect
   :: JoystickMessage -- ^ Any 'JoystickMessage' will do,
   -- but listens only on 'MsgJoystickDevice' messages
-  -> Affection (Maybe SDL.Joystick)
+  -> Affection us (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)
+  logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
   Just <$> SDL.openJoystick descr
 joystickAutoConnect _ = return Nothing
 
@@ -98,20 +96,19 @@ 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
+  -> Affection us [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)
+    logIO Verbose $ "These are the Joysticks connected: " ++ 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)
+      logIO Verbose $ "disconnected joysticks: " ++ show (head d)
+      logIO Verbose $ "Disconnecting Joystick " ++ show which
       SDL.closeJoystick (head d)
       njoys <- filterM (\j -> return $ head d /= j) js
-      logIO Verbose $ "returning joysticks: " <> fromString (show njoys)
+      logIO Verbose $ "returning joysticks: " ++ show njoys
       return njoys
     else do
       logIO Error $ "Error while disconnecting Joystick"

src/Affection/Subsystems/AffectionKeyboard.hs

@@ -13,10 +13,10 @@ 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)
+  :: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage)
   => ak                              -- ^ The message system participant
   -> [SDL.EventPayload]              -- ^ Incoming events
-  -> Affection [SDL.EventPayload] -- ^ Leftover SDL Events
+  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL Events
 consumeSDLKeyboardEvents ak = doConsume
   where
     doConsume [] = return []

src/Affection/Subsystems/AffectionMouse.hs

@@ -15,15 +15,15 @@ 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)
+  :: forall am us. (Participant am us, Mesg am us ~ MouseMessage)
   => am                              -- ^ The message system participant
   -> [SDL.EventPayload]              -- ^ Incoming events
-  -> Affection [SDL.EventPayload] -- ^ Leftover SDL events
+  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
 consumeSDLMouseEvents am = doConsume
   where
     doConsume
       :: [SDL.EventPayload]
-      -> Affection [SDL.EventPayload]
+      -> Affection us [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime

src/Affection/Subsystems/AffectionWindow.hs

@@ -15,16 +15,16 @@ 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)
+  :: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage)
   => aw                               -- ^ The message system participant
   -> [SDL.EventPayload]               -- ^ Incoming events
-  -> Affection [SDL.EventPayload]  -- ^ Leftover SDL events
+  -> Affection us [SDL.EventPayload]  -- ^ Leftover SDL events
 consumeSDLWindowEvents aw = doConsume
   where
     doConsume
-      :: (Mesg aw ~ WindowMessage)
+      :: (Mesg aw us ~ WindowMessage)
       => [SDL.EventPayload]
-      -> Affection [SDL.EventPayload]
+      -> Affection us [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime

src/Affection/Subsystems/Class.hs

@@ -7,7 +7,7 @@ import Affection.Types
 import qualified SDL
 
 -- | This class denotes a Subsystem to be part of SDL
-class SDLSubsystem s where
+class SDLSubsystem s us where
   -- | Consume the given 'SDL.EventPayload's and return only those not
   -- recognised
-  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]
+  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]

src/Affection/Types.hs

@@ -5,8 +5,6 @@ module Affection.Types
   , AffectionData(..)
   , AffectionStateInner
   , AffectionState(..)
-  , AffectionWindow(..)
-  , AffectionContext(..)
   , InitComponents(..)
   , Angle
   -- | SDL reexports
@@ -25,7 +23,6 @@ import qualified Data.Text as T
 
 import Control.Monad.IO.Class
 import Control.Monad.State.Strict
-import Control.Monad.Trans.Resource
 import qualified Control.Monad.Parallel as MP
 
 import System.Clock (TimeSpec)
@@ -38,12 +35,27 @@ data AffectionConfig us = AffectionConfig
       -- ^ Window title
   , windowConfigs  ::
       [
-      ( Word             -- --^ Window identifier
-      , SDL.WindowConfig -- --^ Window config for given window
-      , SDL.WindowMode   -- -- ^ Window mode to start in
+      ( Word             -- ^ Window identifier
+      , SDL.WindowConfig -- ^ Window config for given window
       )
       ]
       -- ^ Window configurations
+  , canvasSize     :: Maybe (Int, Int)
+      -- ^ size of the texture canvas
+  , initScreenMode :: SDL.WindowMode
+      -- ^ Window mode to start in
+  , loadState      :: IO us
+      -- ^ Provide your own load function to create this data.
+  , preLoop        :: Affection us ()
+      -- ^ Actions to be performed, before loop starts
+  , eventLoop      :: [SDL.EventPayload] -> Affection us ()
+      -- ^ Main update function. Takes fractions of a second as input.
+  , updateLoop     :: Double -> Affection us ()
+      -- ^ Main update function. Takes fractions of a second as input.
+  , drawLoop       :: Affection us ()
+      -- ^ Function for updating graphics.
+  , cleanUp        :: us -> IO ()
+      -- ^ Provide your own finisher function to clean your data.
   }
 
 -- | Components to initialize in SDL.
@@ -52,36 +64,38 @@ data InitComponents
   | Only [SDL.InitFlag]
 
 -- | Main type for defining the look, feel and action of the whole application.
-data AffectionData = AffectionData
-  { drawWindows     :: [ AffectionWindow ]  -- ^ SDL windows
-  , glContext       :: [ AffectionContext ] -- ^ OpenGL rendering contexts
-  , elapsedTime     :: Double               -- ^ Elapsed time in seconds
-  , deltaTime       :: Double               -- ^ Elapsed time in seconds since last tick
-  , sysTime         :: TimeSpec             -- ^ System time (NOT the time on the clock)
-  , pausedTime      :: Bool                 -- ^ Should the update loop be executed?
+data AffectionData us = AffectionData
+  { quitEvent       :: Bool               -- ^ Loop breaker.
+  , userState       :: us                 -- ^ State data provided by user
+  , drawWindows     ::
+    [
+    ( Word                                -- ^ Window identifier
+    , SDL.Window                          -- ^ Window linked with identifier
+    )
+    ]                                     -- ^ SDL windows
+  , glContext       ::
+    [
+    ( Word                                -- ^ Window identifier
+    , SDL.GLContext                       -- ^ Associated OpenGL context
+    )
+    ]                                     -- ^ OpenGL rendering contexts
+  , screenMode      :: SDL.WindowMode     -- ^ current screen mode
+  , elapsedTime     :: Double             -- ^ Elapsed time in seconds
+  , deltaTime       :: Double             -- ^ Elapsed time in seconds since last tick
+  , sysTime         :: TimeSpec           -- ^ System time (NOT the time on the clock)
+  , pausedTime      :: Bool               -- ^ Should the update loop be executed?
   }
 
 -- | Inner 'StateT' monad for the update state
-type AffectionStateInner sd m = StateT sd m
+type AffectionStateInner us a = StateT us a
 
 -- | Affection's state monad
-newtype AffectionState sd m a = AffectionState
-  { runState :: AffectionStateInner sd m a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
+newtype AffectionState us m a = AffectionState
+  { runState :: AffectionStateInner us m a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState us)
 
-instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
+instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m)
 
-type Affection a = AffectionState AffectionData ResIO a
+type Affection us a = AffectionState (AffectionData us) IO a
 
 type Angle = Double
-
-data AffectionWindow = AffectionWindow
-  { awWindow     :: SDL.Window
-  , awReleaseKey :: ReleaseKey
-  , awMode       :: SDL.WindowMode
-  }
-
-data AffectionContext = AffectionContext
-  { acContext    :: SDL.GLContext
-  , acReleaseKey :: ReleaseKey
-  }

src/Affection/Util.hs

@@ -10,16 +10,26 @@ 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 :: [SDL.Event] -> Affection us [SDL.EventPayload]
 preHandleEvents evs =
   return $ map SDL.eventPayload evs
 
+-- | Return the userstate to the user
+getAffection :: Affection us us
+getAffection = gets userState
+
+-- | Put altered user state back
+putAffection
+  :: us              -- User state
+  -> Affection us ()
+putAffection us = do
+  ad <- get
+  put $ ad
+    { userState = us }
+
 -- | block a thread for a specified amount of time
 delaySec
   :: Int -- ^ Number of seconds
@@ -27,54 +37,46 @@ delaySec
 delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
 
 -- | Get time since start but always the same in the current tick.
-getElapsedTime :: Affection Double
+getElapsedTime :: Affection us Double
 getElapsedTime = gets elapsedTime
 
 -- | Get delta time (time elapsed from last frame)
-getDelta :: Affection Double
+getDelta :: Affection us Double
 getDelta = gets deltaTime
 
+-- | Quit the engine loop
+quit :: Affection us ()
+quit = do
+  ad <- get
+  put $ ad { quitEvent = True }
+
 -- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
 -- Pauses the Engine in the process.
-toggleScreen :: Word -> Affection ()
-toggleScreen windowIdent = do
+toggleScreen :: Affection us ()
+toggleScreen = do
   ad <- get
-  (stop, alteredWindowList) <- foldM
-    (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
-      if stop || num == windowIdent
-      then do
-        newMode <- case mode of
-          SDL.FullscreenDesktop -> do
-            liftIO $ SDL.setWindowMode window SDL.Windowed
-            return SDL.Windowed
-          SDL.Windowed -> do
-            liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
-            return SDL.FullscreenDesktop
-          x -> do
-            liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
-            return x
-        return (True, resWindows ++ [aw { awMode = newMode }])
-      else
-        return (stop, resWindows ++ [aw])
-      )
-    (False, [])
-    (zip [0..] (drawWindows ad))
-  if stop
-  then do
-    now <- liftIO $ getTime Monotonic
-    put ad
-      { sysTime = now
-      , drawWindows = alteredWindowList
-      }
-  else
-    liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
+  newMode <- case screenMode ad of
+    SDL.Windowed -> do
+      mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) (drawWindows ad)
+      return SDL.FullscreenDesktop
+    SDL.FullscreenDesktop -> do
+      mapM_ (flip SDL.setWindowMode SDL.Windowed . snd) (drawWindows ad)
+      return SDL.Windowed
+    x -> do
+      liftIO $ logIO Warn ("Unexpected Screen mode: " ++ show x)
+      return x
+  now <- liftIO $ getTime Monotonic
+  put ad
+    { sysTime = now
+    , screenMode = newMode
+    }
 
 -- | 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 ()
+  -> Affection us ()
 fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
   liftIO $ logIO Verbose "Fitting Viewport to size"
   if (fromIntegral w / fromIntegral h) > ratio