packages feed

affection 0.0.0.7 → 0.0.0.9

raw patch · 26 files changed

+960/−630 lines, 26 filesdep +deepseqdep +matrixdep +nanovgdep ~sdl2new-component:exe:example01

Dependencies added: deepseq, matrix, nanovg, random, vector

Dependency ranges changed: sdl2

Files

affection.cabal view
@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.0.0.7+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.@@ -68,21 +68,21 @@                      , Affection.Logging                      , Affection.Types                      , Affection.StateMachine-                     , Affection.MouseInteractable                      , Affection.Util                      , Affection.MessageBus-                     , Affection.MessageBus.Util                      , 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    -- Modules included in this library but not exported.@@ -99,7 +99,7 @@   ghc-options:       -Wall   -- Other library packages from which modules are imported.   build-depends:       base >=4.9 && < 5-                     , sdl2+                     , sdl2 >= 2.4 && < 2.5                      , linear                      , text                      , mtl@@ -112,12 +112,13 @@                      , OpenGL                      , stm                      , uuid+                     , vector  -- This example shows the message system. only makes sense when compiling with -- verbose flag. executable example00-  hs-source-dirs:    examples-  main-is:           example00.hs+  hs-source-dirs:    examples/example00+  main-is:           Main.hs   ghc-options:       -threaded -Wall   default-language:  Haskell2010   default-extensions: OverloadedStrings@@ -129,114 +130,25 @@   else     buildable:       False --- executable example01---   hs-source-dirs:    examples---   main-is:           example01.hs---   ghc-options:       -threaded -Wall---   default-language:  Haskell2010---   default-extensions: OverloadedStrings---   if flag(examples)---     build-depends:     base---                      , affection---                      , sdl2---                      , gegl---                      , babl---                      , containers---                      , mtl---   else---     buildable:       False--- --- executable example02---   hs-source-dirs:    examples---   main-is:           example02.hs---   ghc-options:       -threaded -Wall---   default-language:  Haskell2010---   default-extensions: OverloadedStrings---   if flag(examples)---     build-depends:     base---                      , affection---                      , sdl2---                      , gegl---                      , babl---                      , containers---                      , mtl---                      , monad-parallel---   else---     buildable:       False--- --- executable example02.1---   hs-source-dirs:    examples---   main-is:           example02.1.hs---   ghc-options:       -threaded -Wall---   default-language:  Haskell2010---   default-extensions: OverloadedStrings---   if flag(examples)---     build-depends:     base---                      , affection---                      , sdl2---                      , gegl---                      , babl---                      , containers---                      , mtl---   else---     buildable:       False--- --- executable example03---   hs-source-dirs:    examples---   main-is:           example03.hs---   ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts---   default-language:  Haskell2010---   default-extensions: OverloadedStrings---   if flag(examples)---     build-depends:     base---                      , affection---                      , sdl2---                      , gegl---                      , babl---                      , containers---                      , mtl---                      , random---   else---     buildable:       False--- --- executable example04---   hs-source-dirs:    examples---   main-is:           example04.hs---   ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts---   default-language:  Haskell2010---   default-extensions: OverloadedStrings---   if flag(examples)---     build-depends:     base---                      , affection---                      , sdl2---                      , gegl---                      , babl---                      , containers---                      , mtl---                      , random---                      , monad-parallel---   else---     buildable:       False--- --- executable example05---   hs-source-dirs:    examples---   main-is:           example05.hs---   ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts---   default-language:  Haskell2010---   default-extensions: OverloadedStrings---   if flag(examples)---     build-depends:     base---                      , affection---                      , sdl2---                      , gegl---                      , babl---                      , containers---                      , unordered-containers---                      , mtl---                      , random---                      , matrix---                      , random---                      , monad-parallel---                      , parallel---   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+                     , stm+                     , OpenGL+                     , random+                     , containers+                     , linear+                     , matrix+                     , nanovg >= 0.6.0.0+                     , deepseq+  else+    buildable:       False
− examples/example00.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}--import Affection-import qualified SDL--import Control.Concurrent.STM-import Control.Monad.IO.Class (liftIO)--newtype StateData = StateData-  { sdSubs :: Subsystems-  }--data Subsystems = Subsystems-  { subWindow :: Window-  , subMouse :: Mouse-  , subKeyboard :: Keyboard-  }--newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])-newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])-newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])--instance Participant Window WindowMessage StateData where-  partSubscribers (Window t) = do-    subTups <- liftIO $ readTVarIO t-    return $ map snd subTups--  partSubscribe (Window t) funct = do-    uuid <- genUUID-    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)-    return $ MsgId uuid MsgWindowEmptyEvent--  partUnSubscribe (Window t) (MsgId uuid _) =-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))--instance SDLSubsystem Window StateData where-  consumeSDLEvents = consumeSDLWindowEvents--instance Participant Mouse MouseMessage StateData where-  partSubscribers (Mouse t) = do-    subTups <- liftIO $ readTVarIO t-    return $ map snd subTups--  partSubscribe (Mouse t) funct = do-    uuid <- genUUID-    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)-    return $ MsgId uuid MsgMouseEmptyEvent--  partUnSubscribe (Mouse t) (MsgId uuid _) =-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))--instance SDLSubsystem Mouse StateData where-  consumeSDLEvents = consumeSDLMouseEvents--instance Participant Keyboard KeyboardMessage StateData where-  partSubscribers (Keyboard t) = do-    subTups <- liftIO $ readTVarIO t-    return $ map snd subTups--  partSubscribe (Keyboard t) funct = do-    uuid <- genUUID-    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)-    return $ MsgId uuid MsgKeyboardEmptyEvent--  partUnSubscribe (Keyboard t) (MsgId uuid _) =-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))--instance SDLSubsystem Keyboard StateData where-  consumeSDLEvents = consumeSDLKeyboardEvents--main :: IO ()-main = do-  logIO Debug "Starting"-  let conf = AffectionConfig-        { initComponents = All-        , windowTitle = "affection: example00"-        , windowConfig = SDL.defaultWindow-          { SDL.windowOpenGL = Just SDL.defaultOpenGL-            { SDL.glProfile = SDL.Core SDL.Normal 3 3-            }-          }-        , initScreenMode = SDL.Windowed-        , canvasSize = Nothing-        , loadState = load-        , preLoop = pre-        , eventLoop = handle-        , updateLoop = update-        , drawLoop = draw-        , cleanUp = clean-        }-  withAffection conf--load :: IO StateData-load = do-  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])-  empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])-  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])-  return $ StateData $ Subsystems-    (Window empty1)-    (Mouse empty2)-    (Keyboard empty3)--pre :: Affection StateData ()-pre = do-  sd <- getAffection-  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ-  _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose-  return ()--exitOnQ :: KeyboardMessage -> Affection StateData ()-exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =-  case SDL.keysymKeycode sym of-    SDL.KeycodeQ -> do-      liftIO $ logIO Debug "Yo dog I heard..."-      quit-    _ -> return ()--exitOnWindowClose :: WindowMessage -> Affection StateData ()-exitOnWindowClose wm =-  case wm of-    MsgWindowClose _ _ -> do-      liftIO $ logIO Debug "I heard another one..."-      quit-    _ -> return ()--handle :: [SDL.EventPayload] -> Affection StateData ()-handle es = do-  (Subsystems a b c) <- sdSubs <$> getAffection-  _ <- consumeSDLEvents a es-  _ <- consumeSDLEvents b es-  _ <- consumeSDLEvents c es-  return ()--update _ = return ()--draw = return ()--clean _ = return ()
+ examples/example00/Main.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++import Affection as A++import Control.Concurrent.STM+import Control.Monad.IO.Class (liftIO)+import Control.Monad (when)++import qualified SDL hiding (Window(..))++import Data.Maybe (isJust, fromJust)++data StateData = StateData+  { sdSubs :: Subsystems+  , sdJoys :: [SDL.Joystick]+  }++data Subsystems = Subsystems+  { subWindow   :: Main.Window+  , subMouse    :: Main.Mouse+  , subKeyboard :: Main.Keyboard+  , subJoystick :: Main.Joystick+  }++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 ())])++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++  partSubscribe (Window t) = generalSubscribe t++  partUnSubscribe (Window t) = generalUnSubscribe t++instance SDLSubsystem Main.Window StateData where+  consumeSDLEvents = consumeSDLWindowEvents++instance Participant Mouse StateData where+  type Mesg Mouse StateData = MouseMessage++  partSubscribers (Mouse t) = generalSubscribers t++  partSubscribe (Mouse t) = generalSubscribe t++  partUnSubscribe (Mouse t) = generalUnSubscribe t++instance SDLSubsystem Mouse StateData where+  consumeSDLEvents = consumeSDLMouseEvents++instance Participant Keyboard StateData where+  type Mesg Keyboard StateData = KeyboardMessage++  partSubscribers (Keyboard t) = generalSubscribers t++  partSubscribe (Keyboard t) = generalSubscribe t++  partUnSubscribe (Keyboard t) = generalUnSubscribe t++instance SDLSubsystem Keyboard StateData where+  consumeSDLEvents = consumeSDLKeyboardEvents++instance Participant Joystick StateData where+  type Mesg Joystick StateData = JoystickMessage++  partSubscribers (Joystick t) = generalSubscribers t++  partSubscribe (Joystick t) = generalSubscribe t++  partUnSubscribe (Joystick t) = generalUnSubscribe t++instance SDLSubsystem Joystick StateData where+  consumeSDLEvents = consumeSDLJoystickEvents++main :: IO ()+main = do+  logIO Debug "Starting"+  let conf = AffectionConfig+        { initComponents = All+        , windowTitle = "affection: example00"+        , windowConfig = SDL.defaultWindow+          { SDL.windowOpenGL = Just SDL.defaultOpenGL+            { SDL.glProfile = SDL.Core SDL.Normal 3 3+            }+          }+        , initScreenMode = SDL.Windowed+        , canvasSize = Nothing+        , loadState = load+        , preLoop = pre+        , eventLoop = handle+        , updateLoop = update+        , drawLoop = draw+        , cleanUp = clean+        }+  withAffection conf++load :: IO StateData+load =+  StateData <$> (Subsystems+    <$> (Window <$> newTVarIO [])+    <*> (Mouse <$> newTVarIO [])+    <*> (Keyboard <$> newTVarIO [])+    <*> (Joystick <$> newTVarIO [])+    )+    <*> return []++pre :: Affection StateData ()+pre = do+  sd <- getAffection+  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ+  _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose+  _ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect+  return ()++exitOnQ :: KeyboardMessage -> Affection StateData ()+exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =+  case SDL.keysymKeycode sym of+    SDL.KeycodeQ -> do+      liftIO $ logIO Debug "Yo dog I heard..."+      quit+    _ -> return ()++exitOnWindowClose :: WindowMessage -> Affection StateData ()+exitOnWindowClose wm =+  case wm of+    MsgWindowClose _ _ -> do+      liftIO $ logIO Debug "I heard another one..."+      quit+    _ -> return ()++joyConnectDisconnect :: JoystickMessage -> Affection StateData ()+joyConnectDisconnect msg = do+  mj <- joystickAutoConnect msg+  when (isJust mj) $ do+    sd <- getAffection+    putAffection sd+      { sdJoys = fromJust mj : sdJoys sd+      }+  sd <- getAffection+  njs <- joystickAutoDisconnect (sdJoys sd) msg+  putAffection sd+    { sdJoys = njs+    }++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: " ++ show e) leftovers++update _ = return ()++draw = return ()++clean _ = return ()
+ examples/example01/Main.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ForeignFunctionInterface #-}++import Affection as A+import SDL (($=))+import qualified SDL+import qualified Graphics.Rendering.OpenGL as GL++import Control.Concurrent.STM+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 System.Random (randomRIO)++import NanoVG hiding (V2(..))++import Linear++import Foreign.C.Types (CInt(..))++-- internal imports++import Types++foreign import ccall unsafe "glewInit"+  glewInit :: IO CInt++main :: IO ()+main = do+  logIO A.Debug "Starting"+  let conf = AffectionConfig+        { initComponents = All+        , windowTitle = "affection: example01"+        , windowConfig = SDL.defaultWindow+          { SDL.windowOpenGL = Just SDL.defaultOpenGL+            { SDL.glProfile = SDL.Core SDL.Normal 3 3+            }+          , SDL.windowInitialSize = SDL.V2 600 600+          , SDL.windowResizable = True+          }+        , initScreenMode = SDL.Windowed+        , canvasSize = Nothing+        , loadState = load+        , preLoop = pre+        , eventLoop = handle+        , updateLoop = update+        , drawLoop = draw+        , cleanUp = clean+        }+  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]+  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 UserData ())])+  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])+  return $ UserData+    { subsystems = Subsystems+      (Window empty1)+      (Keyboard empty3)+    , lifeMat = fullMatrix+    , foodMat = fromList 60 60 (repeat 10)+    , timeMat = M.zero 60 60+    , nano = nanoCtx+    , lastUpdate = 0+    }++pre :: Affection UserData ()+pre = do+  sd <- getAffection+  _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc+  _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR+  _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS+  _ <- partSubscribe (subWindow   $ subsystems sd) exitOnWindowClose+  _ <- partSubscribe (subWindow   $ subsystems sd) windowResize+  now <- getElapsedTime+  putAffection sd+    { lastUpdate = floor now+    }++exitOnEsc :: KeyboardMessage -> Affection UserData ()+exitOnEsc (MsgKeyboardEvent _ _ _ _ sym) =+  case SDL.keysymKeycode sym of+    SDL.KeycodeEscape -> do+      liftIO $ logIO A.Debug "Yo dog I heard..."+      quit+    _ -> return ()++reloadOnR :: KeyboardMessage -> Affection UserData ()+reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =+  case SDL.keysymKeycode sym of+    SDL.KeycodeR -> reload+    _ -> return ()++reload :: Affection UserData ()+reload = do+  ud <- getAffection+  now <- getElapsedTime+  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]+  let fullMatrix = fromList 60 60 randList+  putAffection ud+    { lifeMat = fullMatrix+    , foodMat = fromList 60 60 (repeat 10)+    , timeMat = M.zero 60 60+    , lastUpdate = floor now+    }++showFPS :: KeyboardMessage -> Affection UserData ()+showFPS (MsgKeyboardEvent _ _ _ _ sym) =+  case SDL.keysymKeycode sym of+    SDL.KeycodeF -> do+      dt <- getDelta+      liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)+    _ -> return ()++exitOnWindowClose :: WindowMessage -> Affection UserData ()+exitOnWindowClose wm =+  case wm of+    MsgWindowClose _ _ -> do+      liftIO $ logIO A.Debug "I heard another one..."+      quit+    _ -> return ()++windowResize :: WindowMessage -> Affection UserData ()+windowResize msg = case msg of+  (MsgWindowResize _ _ (V2 w h)) -> do+    liftIO $ logIO A.Debug "Window resized"+    let nw = floor (fromIntegral h)+        dw = floor ((fromIntegral w - fromIntegral nw) / 2)+    GL.viewport $= (GL.Position dw 0, GL.Size nw h)+  _ -> return ()++handle :: [SDL.EventPayload] -> Affection UserData ()+handle es = do+  (Subsystems a b) <- subsystems <$> getAffection+  _ <- consumeSDLEvents a =<< consumeSDLEvents b es+  return ()++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 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud)+            <->+            submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud)+          | x == 1 && y == 60 =+            submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud)+            <->+            submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud)+          | x == 60 && y == 1 =+            submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud)+            <->+            submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud)+          | x == 60 && y == 60 =+            submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud)+            <->+            submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud)+          | x == 1 =+            submatrix (y - 1) (y + 1) 60 60 (lifeMat ud)+            <|>+            submatrix (y - 1) (y + 1) 1 2 (lifeMat ud)+          | y == 1 =+            submatrix 60 60 (x - 1) (x + 1) (lifeMat ud)+            <->+            submatrix 1 2 (x - 1) (x + 1) (lifeMat ud)+          | x == 60 =+            submatrix (y - 1) (y + 1) 59 60 (lifeMat ud)+            <|>+            submatrix (y - 1) (y + 1) 1 1 (lifeMat ud)+          | y == 60 =+            submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud)+            <->+            submatrix 1 1 (x - 1) (x + 1) (lifeMat ud)+          | otherwise =+            submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud)+        life = countLife subm+    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), 1)+    else if life == 3 && foodMat ud M.! (y, x) > 0+      then return (1, (foodMat ud M.! (y, x)) - 1, 0)+      else return+        ( 0+        , if timeMat ud M.! (y, x) > 10+          then min 10 ((foodMat ud M.! (y, x)) + 1)+          else foodMat ud M.! (y, x)+        , timeMat ud M.! (y, x) + 1+        )+    ) [0..3599]+  let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)+  let newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)+  let newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)+  if newLifeMat == M.zero 60 60+  then+    reload+  else+    putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)+      { lifeMat = newLifeMat+      , foodMat = newFoodMat+      , timeMat = newTimeMat+      -- , lastUpdate = floor now+      }++countLife :: Matrix Word -> Word+countLife mat = res - (mat M.! (2, 2))+  where+    res = foldr (flip (+)) 0 mat++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+          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 mult == 1+      then+        fillColor ctx (rgba 255 255 255 255)+      else+        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 _ = return ()
+ examples/example01/Types.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Types where++import Affection++import Data.Matrix as M++import NanoVG++import Control.Concurrent.STM+import Control.Monad.IO.Class (liftIO)++data UserData = UserData+  { lifeMat    :: Matrix Word+  , foodMat    :: Matrix Word+  , timeMat    :: Matrix Word+  , subsystems :: Subsystems+  , nano       :: Context+  , lastUpdate :: Int+  }++data Subsystems = Subsystems+  { subWindow   :: Types.Window+  , subKeyboard :: Types.Keyboard+  }++newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])++newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])++instance Participant Types.Window UserData where+  type Mesg Types.Window UserData = 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 UserData where+  consumeSDLEvents = consumeSDLWindowEvents++instance Participant Keyboard UserData where+  type Mesg Keyboard UserData = 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 UserData where+  consumeSDLEvents = consumeSDLKeyboardEvents++generalSubscribe+  :: 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 UserData ())]+  -> UUID+  -> Affection UserData ()+generalUnSubscribe t uuid =+  liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))+  where+    filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool+    filterMsg (u, _) p = u /= p
src/Affection.hs view
@@ -4,31 +4,32 @@     ( withAffection     , get     , put+    , liftIO     , module A     ) where  import SDL (($=)) import qualified SDL+import qualified SDL.Raw.Video as SDL (glSetAttribute)+import qualified SDL.Raw.Enum as SDL  import System.Clock  import Control.Monad.Loops-import Control.Monad.State+import Control.Monad.State.Strict+import Control.Monad.IO.Class (liftIO)  import Foreign.C.Types (CInt(..)) -import Debug.Trace- import Affection.Types as A import Affection.StateMachine as A-import Affection.MouseInteractable as A import Affection.Util as A import Affection.MessageBus as A import Affection.Subsystems as A  import Affection.Logging as A -import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))+import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))   -- | Main function which bootstraps everything else.@@ -55,39 +56,14 @@   liftIO $ logIO Debug "Creating Window"   window <- SDL.createWindow windowTitle windowConfig   SDL.showWindow window-  -- renderer <- SDL.createRenderer-  --   window (-1)-  --   SDL.defaultRenderer-  --     { SDL.rendererTargetTexture = True-  --     }-  -- surface <- SDL.createRGBSurface-  --   (case canvasSize of-  --     Just (cw, ch) -> SDL.V2-  --       (CInt $ fromIntegral cw)-  --       (CInt $ fromIntegral ch)-  --     Nothing ->-  --       SDL.windowInitialSize windowConfig-  --   )-  --   SDL.RGBA8888-  -- texture <- SDL.createTexture-  --   renderer-  --   SDL.RGBA8888-  --   SDL.TextureAccessTarget-  --   (case canvasSize of-  --     Just (cw, ch) -> SDL.V2-  --       (CInt $ fromIntegral cw)-  --       (CInt $ fromIntegral ch)-  --     Nothing ->-  --       SDL.windowInitialSize windowConfig-  --   )-  -- SDL.rendererRenderTarget renderer $= Just texture+  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1   context <- SDL.glCreateContext window   let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig       (w, h) = case canvasSize of         Just (cw, ch) -> (cw, ch)         Nothing       -> (fromIntegral rw, fromIntegral rh)   SDL.setWindowMode window initScreenMode-  SDL.swapInterval $= SDL.SynchronizedUpdates+  -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows   liftIO $ logIO Debug "Getting Time"   -- get current time   execTime <- getTime Monotonic@@ -109,10 +85,7 @@   (_, nState) <- runStateT ( A.runState $ do     liftIO $ logIO Debug "Starting Loop"     preLoop-    whileM_ (do-        current <- get-        return $ not $ A.quitEvent current-      )+    whileM_ (not . A.quitEvent <$> get)       (do         -- get state         ad <- get@@ -129,20 +102,16 @@           }         -- poll events         evs <- preHandleEvents =<< liftIO SDL.pollEvents-        -- mapM_ eventLoop evs+        -- handle events         eventLoop evs         -- execute user defined update loop         unless (pausedTime ad) (updateLoop dt)         -- execute user defined draw loop-        liftIO $ GL.clear [ColorBuffer, DepthBuffer, StencilBuffer]+        liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]         drawLoop-        liftIO flush-        -- handle all new draw requests-        ad2 <- get-        -- actual drawing+        liftIO GL.flush+        -- actual displaying of newly drawn frame         SDL.glSwapWindow window-        -- SDL.copy renderer texture Nothing Nothing-        -- SDL.present renderer         -- save new time         ad3 <- get         when (sysTime ad == sysTime ad3) (@@ -155,6 +124,7 @@   liftIO $ logIO Debug "Loop ended. Cleaning"   cleanUp $ userState nState   liftIO $ logIO Debug "Destroying Window"+  SDL.glDeleteContext context   SDL.destroyWindow window-  SDL.quit+  -- SDL.quit -- <- This causes segfaults depending on hardware   liftIO $ logIO Debug "This is the end"
src/Affection/Logging.hs view
@@ -1,15 +1,23 @@ {-# LANGUAGE CPP #-}+-- | This module defines the logging capability of Affection, whis is derived+-- from "Debug.Trace". module Affection.Logging where  import Debug.Trace +-- | The log level definition data LogLevel-  = Verbose-  | Debug-  | Warn-  | Error+  = Verbose -- ^ Log everything+  | Debug   -- ^ Log Debug messages and above+  | Warn    -- ^ Log only Warnings and errors+  | Error   -- ^ Log only errors -log :: LogLevel -> String -> a -> a+-- | Pure logging function+log+  :: LogLevel -- ^ Log level to log to+  -> String   -- ^ The message string+  -> a        -- ^ Arbitrary datatype to return+  -> a        -- ^ Returned data #if defined(VERBOSE) log Verbose s = trace ("VERBOSE: " ++ s) #endif@@ -24,7 +32,11 @@ #endif log _ _ = id -logIO :: LogLevel -> String -> IO ()+-- | Manadic logging function residing in the 'IO' Monad+logIO+  :: LogLevel -- ^ Log level to log to+  -> String   -- ^ The message string+  -> IO () #if defined(VERBOSE) logIO Verbose s = traceIO ("VERBOSE: " ++ s) #endif
src/Affection/MessageBus.hs view
@@ -5,6 +5,5 @@  import Affection.MessageBus.Class as M import Affection.MessageBus.Message as M-import Affection.MessageBus.Util as M  import Affection.MessageBus.Message as Msg
src/Affection/MessageBus/Class.hs view
@@ -3,11 +3,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ExistentialQuantification #-}-module Affection.MessageBus.Class +module Affection.MessageBus.Class   ( Participant(..)   , genUUID   , UUID-  , MsgId(..)   ) where  import Affection.MessageBus.Message@@ -20,30 +19,33 @@  import Affection.Logging -class (Message msg, Show msg) => Participant prt msg us where+-- | This typeclass defines the behaviour of a participant in the message system+class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where+  -- | Message datatype+  type Mesg prt us :: *    -- | Function to get the list of subscribers from the participant   partSubscribers     :: prt     -- ^ the 'Participant''s subscriber storage-    -> Affection us [msg -> Affection us ()]+    -> Affection us [Mesg prt us -> Affection us ()]     -- ^ List of Subscriber functions    -- | Subscribe to the 'Participant''s events   partSubscribe     :: prt     -- ^ The 'Participant''s subscriber storage-    -> (msg -> Affection us ())+    -> (Mesg prt us -> Affection us ())     -- ^ What to do in case of a 'Message'     -- (Subscriber function)-    -> Affection us (MsgId msg)+    -> Affection us UUID     -- ^ 'UUID' of the registered subscriber Function    -- | Unsubscribe a Subscriber function from Participant   partUnSubscribe     :: prt     -- ^ The 'Participant''s subscriber storage to unsubscribe from-    -> (MsgId msg)+    -> UUID     -- ^ The subscriber function's 'UUID'     -> Affection us () @@ -51,7 +53,7 @@   partEmit     :: prt     -- ^ The 'Participant''s subscriber storage-    -> msg+    -> Mesg prt us     -- ^ The 'Message' to emit     -> Affection us ()   partEmit p m = do@@ -62,5 +64,3 @@ -- | Helper function to generate new 'UUID's genUUID :: Affection us UUID genUUID = liftIO nextRandom--data MsgId msg = (Message msg, Show msg) => MsgId UUID msg
src/Affection/MessageBus/Message.hs view
@@ -6,3 +6,4 @@ 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
src/Affection/MessageBus/Message/Class.hs view
@@ -1,6 +1,6 @@ module Affection.MessageBus.Message.Class where -import Data.Word (Word32(..))-+-- | Typeclass definition for messages class Message msg where+  -- | return the time when the message was sent   msgTime :: msg -> Double
+ src/Affection/MessageBus/Message/JoystickMessage.hs view
@@ -0,0 +1,67 @@+module Affection.MessageBus.Message.JoystickMessage +  ( JoystickMessage(..)+    -- | Vector export+  , Linear.V2+    -- | SDL exports+  , SDL.JoyHatPosition+  , SDL.JoyButtonState+  , SDL.JoyDeviceConnection+    -- | Number exports+  , Word8+  , Int16+  , Int32+  ) where++import Affection.MessageBus.Message.Class++import Data.Word (Word8)+import Data.Int (Int32, Int16)++import qualified SDL++import Linear (V2(..))++-- | Datatype for handling all possible joystick events handed over from sdl2+data JoystickMessage+  -- | Movement of a Joystick axis+  = MsgJoystickAxis+    { msgJAWhen :: Double -- ^ Time of event+    , msgJAWhich :: Int32 -- ^ Joystick identifier+    , msgJAAxis :: Word8  -- ^ Axis identifier+    , msgJAValue :: Int16 -- ^ Axis value+    }+  -- | Movement of a joystick ball controller+  | MsgJoystickBall+    { msgJBWhen :: Double            -- ^ Time of event+    , msgJBWhich :: Int32            -- ^ Joystick identifier+    , msgJBBall :: Word8             -- ^ Ball identifier+    , msgJBRelMotion :: V2 Int16     -- ^ Motion relative to previous position+    }+  -- | Movement of joystick hat controller+  | MsgJoystickHat+    { msgJHWhen :: Double                 -- ^ Time of event+    , msgJHWhich :: Int32                 -- ^ Joystick identifier+    , msgJHHat :: Word8                   -- ^ Hat identifier+    , msgJHPosition :: SDL.JoyHatPosition -- ^ New hat position+    }+  -- | Joystick button event+  | MsgJoystickButton+    { msgJBWhen :: Double              -- ^ Time of event+    , msgJBWhich :: Int32              -- ^ Joystick identifier+    , msgJBButton :: Word8             -- ^ Button identifier+    , msgJBState :: SDL.JoyButtonState -- ^ New Button state+    }+  -- | Joystick device event+  | MsgJoystickDevice+    { msgJDWhen :: Double                        -- ^ Time of event+    , msgJDWhich :: Int32                        -- ^ Joystick identifier+    , msgJDConnection :: SDL.JoyDeviceConnection -- ^ Connection status+    }+  deriving (Show)++instance Message JoystickMessage where+  msgTime (MsgJoystickAxis t _ _ _)   = t+  msgTime (MsgJoystickBall t _ _ _)   = t+  msgTime (MsgJoystickHat t _ _ _)    = t+  msgTime (MsgJoystickButton t _ _ _) = t+  msgTime (MsgJoystickDevice t _ _)   = t
src/Affection/MessageBus/Message/KeyboardMessage.hs view
@@ -1,18 +1,25 @@-module Affection.MessageBus.Message.KeyboardMessage where+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-    , msgKbdWindow :: Maybe SDL.Window-    , msgKbdKeyMotion :: SDL.InputMotion-    , msgKbdKeyRepeat :: Bool-    , msgKbdKeysym :: SDL.Keysym+    { 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'     }-  | MsgKeyboardEmptyEvent   deriving (Show)  instance Message KeyboardMessage where
src/Affection/MessageBus/Message/MouseMessage.hs view
@@ -1,42 +1,54 @@-module Affection.MessageBus.Message.MouseMessage where+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 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-    , msgMMWindow :: Maybe SDL.Window-    , msgMMWhich :: SDL.MouseDevice-    , msgMMState :: [SDL.MouseButton]-    , msgMMPos :: V2 Int32-    , msgMMRelMotion :: V2 Int32+    { 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-    , msgMBWindow :: Maybe SDL.Window-    , msgMBWhich :: SDL.MouseDevice-    , msgMBButton :: SDL.MouseButton-    , msgMBClicks :: Word8-    , msgMBPos :: V2 Int32+    { 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-    , msgMWWhindow :: Maybe SDL.Window-    , msgMWWhich :: SDL.MouseDevice-    , msgMWPos :: V2 Int32-    , msgMWDIrection :: SDL.MouseScrollDirection+    { 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     }-  | MsgMouseEmptyEvent   deriving (Show)  instance Message MouseMessage where   msgTime (MsgMouseMotion t _ _ _ _ _) = t-  msgTime (MsgMouseButton t _ _ _ _ _) = t+  msgTime (MsgMouseButton t _ _ _ _ _ _) = t   msgTime (MsgMouseWheel t _ _ _ _) = t
src/Affection/MessageBus/Message/WindowMessage.hs view
@@ -1,84 +1,101 @@-module Affection.MessageBus.Message.WindowMessage where+module Affection.MessageBus.Message.WindowMessage+  ( WindowMessage(..)+  -- | SDL reexports+  , SDL.Window+  ) where  import Affection.MessageBus.Message.Class -import Data.Int (Int32(..))+import Data.Int (Int32)  import qualified SDL  import Linear (V2(..)) +-- | Datatype for handling Window events handed down rom SDL2 data WindowMessage-  -- = MsgEngineReady Double+  -- | Window show event   = MsgWindowShow-    { msgWSWhen :: Double-    , msgWSWindow :: SDL.Window+    { msgWSWhen :: Double       -- ^ Message time+    , msgWSWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window hide event   | MsgWindowHide-    { msgWHWhen :: Double-    , msgWHWindow :: SDL.Window+    { msgWHWhen :: Double       -- ^ Message time+    , msgWHWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window expose event   | MsgWindowExpose-    { msgWEWhen :: Double-    , msgWEWindow :: SDL.Window+    { msgWEWhen :: Double       -- ^ Message time+    , msgWEWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window move event   | MsgWindowMove-    { msgWMWhen :: Double-    , msgWMWindow :: SDL.Window-    , msgWMNewPos :: V2 Int32+    { msgWMWhen :: Double       -- ^ Message time+    , msgWMWindow :: SDL.Window -- ^ Window identifier+    , msgWMNewPos :: V2 Int32   -- ^ New absolute window position     }+  -- | Window resize event   | MsgWindowResize-    { msgWRWhen :: Double-    , msgWRWindow :: SDL.Window-    , msgWRNewSize :: V2 Int32+    { msgWRWhen :: Double       -- ^ Message time+    , msgWRWindow :: SDL.Window -- ^ Window identifier+    , msgWRNewSize :: V2 Int32  -- ^ New absolute window size     }+  -- | Window size change event   | MsgWindowSizeChange-    { msgWSCWhen :: Double-    , msgWSCWindow :: SDL.Window+    { msgWSCWhen    :: Double     -- ^ Message time+    , msgWSCWindow  :: SDL.Window -- ^ Window identifier+    , msgWSCNewSize :: V2 Int32   -- ^ New absolute window size     }+  -- | Window minimize event   | MsgWindowMinimize-    { msgWMinWhen :: Double-    , msgWMinWindow :: SDL.Window+    { msgWMinWhen   :: Double     -- ^ Message time+    , msgWMinWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window maximize event   | MsgWindowMaximize-    { msgWMaxWhen :: Double-    , msgWMaxWindow :: SDL.Window+    { msgWMaxWhen   :: Double     -- ^ Message time+    , msgWMaxWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window restore event   | MsgWindowRestore-    { msgWRestWhen :: Double-    , msgWRestWindow :: SDL.Window+    { msgWRestWhen   :: Double     -- ^ Message time+    , msgWRestWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window gain mouse focus event   | MsgWindowGainMouseFocus-    { msgWGMFWhen :: Double-    , msgWGMFWindow :: SDL.Window+    { msgWGMFWhen   :: Double     -- ^ Message Time+    , msgWGMFWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window lose mouse focus event   | MsgWindowLoseMouseFocus-    { msgWLMFWhen :: Double-    , msgWLMFWindow :: SDL.Window+    { msgWLMFWhen   :: Double     -- ^ Message Time+    , msgWLMFWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window gain keyboard focus event   | MsgWindowGainKeyboardFocus-    { msgWGKFWhen :: Double-    , msgWGKFWindow :: SDL.Window+    { msgWGKFWhen   :: Double     -- ^ Message time+    , msgWGKFWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window lose keyboard focus event   | MsgWindowLoseKeyboardFocus-    { msgWLKFWhen :: Double-    , msgWLKFWindow :: SDL.Window+    { msgWLKFWhen   :: Double     -- ^ Message time+    , msgWLKFWindow :: SDL.Window -- ^ Window identifier     }+  -- | Window close event   | MsgWindowClose-    { msgWCWhen :: Double-    , msgWCWindow :: SDL.Window+    { msgWCWhen   :: Double     -- ^ Message time+    , msgWCWindow :: SDL.Window -- ^ Window identifier     }-  | MsgWindowEmptyEvent   deriving (Show)  instance Message WindowMessage where-  -- msgTime (MsgEngineReady t)   = t   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 (MsgWindowSizeChange t _ _) = t   msgTime (MsgWindowMinimize t _) = t   msgTime (MsgWindowMaximize t _) = t   msgTime (MsgWindowRestore t _) = t
− src/Affection/MessageBus/Util.hs 
@@ -1,3 +0,0 @@-module Affection.MessageBus.Util where---- zuru zuru
− src/Affection/MouseInteractable.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}--module Affection.MouseInteractable where--import Affection.Types--import qualified SDL---- class MouseHoverable a us where---   onHover :: a -> Affection us ()---- | Define a mouse clickable object-class MouseClickable a us where-  onClick-    :: a               -- The object-    -> SDL.MouseButton -- The clicked button-    -> (Int, Int)      -- The coordinates of the click-    -> SDL.InputMotion -- The 'SDL.InputMotion' of the click-    -> Int             -- The number of clicks-    -> Affection us ()---- | A helper function that checks wether provided clickables have been clicked.--- This function does not consume provided events, but passes them on.-handleMouseClicks-  :: (Foldable t, MouseClickable clickable us)-  => SDL.EventPayload              -- ^ Piped event in-  -> t clickable                   -- ^ 'MouseClickable' elemt to be checked-  -> Affection us SDL.EventPayload -- ^ Unaltered event-handleMouseClicks e clickables =-  case e of-    SDL.MouseButtonEvent dat -> do-      mapM_ (\clickable -> do-        let SDL.P (SDL.V2 x y) = SDL.mouseButtonEventPos dat-        onClick-          clickable-          (SDL.mouseButtonEventButton dat)-          (fromIntegral x, fromIntegral y)-          (SDL.mouseButtonEventMotion dat)-          (fromIntegral $ SDL.mouseButtonEventClicks dat)-        ) clickables-      return e-    _ -> return e
src/Affection/StateMachine.hs view
@@ -6,9 +6,15 @@  import qualified SDL +-- | Typeclass for simple scaffolding of a state machine class StateMachine a us where+  -- | State load routine   smLoad   :: a -> Affection us ()+  -- | state update routine   smUpdate :: a -> Double -> Affection us ()+  -- | State event handler routine   smEvent  :: a -> [SDL.EventPayload] -> Affection us ()+  -- | State draw routine   smDraw   :: a -> Affection us ()+  -- | State clean routine   smClean  :: a -> Affection us ()
src/Affection/Subsystems.hs view
@@ -6,3 +6,4 @@ import Affection.Subsystems.AffectionKeyboard as S import Affection.Subsystems.AffectionWindow as S import Affection.Subsystems.AffectionMouse as S+import Affection.Subsystems.AffectionJoystick as S
+ src/Affection/Subsystems/AffectionJoystick.hs view
@@ -0,0 +1,111 @@+{-# 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 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 us. (Participant am us, Mesg am us ~ JoystickMessage)+  => am                              -- ^ The message system participant+  -> [SDL.EventPayload]              -- ^ Incoming events+  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events+consumeSDLJoystickEvents am = doConsume+  where+    doConsume+      :: [SDL.EventPayload]+      -> Affection us [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 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 " ++ show which ++ " " ++ 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 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: " ++ show joyIds+    [d] <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js+    logIO Verbose $ "disconnected joysticks: " ++ show d+    logIO Verbose $ "Disconnecting Joystick " ++ show which+    SDL.closeJoystick d+    njoys <- filterM (\j -> return $ d /= j) js+    logIO Verbose $ "returning joysticks: " ++ show njoys+    return njoys+joystickAutoDisconnect js _ = return js
src/Affection/Subsystems/AffectionKeyboard.hs view
@@ -1,22 +1,22 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module Affection.Subsystems.AffectionKeyboard where  import Affection.Types import Affection.Util import Affection.MessageBus-import Affection.Subsystems.Class -import Control.Concurrent.STM as STM-import Control.Monad.IO.Class (liftIO)- import qualified SDL +-- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's+-- and emits appropriate 'KeyboardMessage's consumeSDLKeyboardEvents-  :: (Participant ak KeyboardMessage us)-  => ak-  -> [SDL.EventPayload]-  -> Affection us [SDL.EventPayload]+  :: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage)+  => ak                              -- ^ The message system participant+  -> [SDL.EventPayload]              -- ^ Incoming events+  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL Events consumeSDLKeyboardEvents ak = doConsume   where     doConsume [] = return []
src/Affection/Subsystems/AffectionMouse.hs view
@@ -1,26 +1,29 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module Affection.Subsystems.AffectionMouse where  import Affection.MessageBus-import Affection.Subsystems.Class import Affection.Types import Affection.Util -import Control.Monad.IO.Class (liftIO)-import Control.Concurrent.STM- import Linear.Affine (unP)  import qualified SDL +-- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's+-- and emits appropriate 'MouseMessage's consumeSDLMouseEvents-  :: (Participant am MouseMessage us)-  => am-  -> [SDL.EventPayload]-  -> Affection us [SDL.EventPayload]+  :: forall am us. (Participant am us, Mesg am us ~ MouseMessage)+  => am                              -- ^ The message system participant+  -> [SDL.EventPayload]              -- ^ Incoming events+  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events consumeSDLMouseEvents am = doConsume   where+    doConsume+      :: [SDL.EventPayload]+      -> Affection us [SDL.EventPayload]     doConsume [] = return []     doConsume (e:es) = do       ts <- getElapsedTime@@ -39,6 +42,7 @@           partEmit am (MsgMouseButton             ts             (SDL.mouseButtonEventWindow dat)+            (SDL.mouseButtonEventMotion dat)             (SDL.mouseButtonEventWhich dat)             (SDL.mouseButtonEventButton dat)             (SDL.mouseButtonEventClicks dat)
src/Affection/Subsystems/AffectionWindow.hs view
@@ -1,25 +1,30 @@ {-# 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 Affection.Subsystems.Class -import Control.Concurrent.STM as STM-import Control.Monad.IO.Class (liftIO)- import qualified SDL +-- | Helper function that consumes all Window-related 'SDL.EventPayload's+-- and emits appropriate 'WindowMessage's. consumeSDLWindowEvents-  :: (Participant aw WindowMessage us)-  => aw-  -> [SDL.EventPayload]-  -> Affection us [SDL.EventPayload]+  :: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage)+  => aw                               -- ^ The message system participant+  -> [SDL.EventPayload]               -- ^ Incoming events+  -> Affection us [SDL.EventPayload]  -- ^ Leftover SDL events consumeSDLWindowEvents aw = doConsume   where+    doConsume+      :: (Mesg aw us ~ WindowMessage)+      => [SDL.EventPayload]+      -> Affection us [SDL.EventPayload]     doConsume [] = return []     doConsume (e:es) = do       ts <- getElapsedTime@@ -39,8 +44,8 @@         SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do           partEmit aw (MsgWindowResize ts window newSize)           doConsume es-        SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do-          partEmit aw (MsgWindowSizeChange ts window)+        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)
src/Affection/Subsystems/Class.hs view
@@ -3,9 +3,11 @@ module Affection.Subsystems.Class where  import Affection.Types-import Affection.MessageBus  import qualified SDL +-- | This class denotes a Subsystem to be part of SDL class SDLSubsystem s us where+  -- | Consume the given 'SDL.EventPayload's and return only those not+  -- recognised   consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]
src/Affection/Types.hs view
@@ -1,57 +1,32 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}-module Affection.Types-  -- ( Affection-  -- , AffectionData(..)-  -- , AffectionConfig(..)-  -- , AffectionState(..)-  -- -- , AffectionDraw(..)-  -- -- , Draw(..)-  -- , AffectionStateInner-  -- -- , AffectionDrawInner(..)-  -- , InitComponents(..)-  -- -- , Loop(..)-  -- -- , RGBA(..)-  -- , DrawType(..)-  -- , DrawRequest(..)-  -- , RequestPersist(..)-  -- , Angle(..)-  -- -- , ConvertAngle(..)-  --   -- | Particle system-  -- , Particle(..)-  -- , ParticleSystem(..)-  -- , ParticleStorage(..)-  --   -- | Convenience exports-  -- , liftIO-  -- , SDL.WindowConfig(..)-  -- , SDL.defaultWindow-  --   -- | GEGL reexports-  -- , G.GeglRectangle(..)-  -- , G.GeglBuffer(..)-  -- )-  where+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 Data.Map.Strict as M --- import qualified GEGL as G--- import qualified BABL as B- import Control.Monad.IO.Class-import Control.Monad.State+import Control.Monad.State.Strict import qualified Control.Monad.Parallel as MP  import System.Clock (TimeSpec)--- import Control.Monad.Reader --- import Control.Concurrent.MVar--import Foreign.Ptr (Ptr)--import Affection.MessageBus.Message- -- | Configuration for the aplication. needed at startup. data AffectionConfig us = AffectionConfig   { initComponents :: InitComponents@@ -85,42 +60,19 @@  -- | Main type for defining the look, feel and action of the whole application. data AffectionData us = AffectionData-  -- { affectionConfig :: AffectionConfig us -- ^ Application configuration.   { quitEvent       :: Bool               -- ^ Loop breaker.   , userState       :: us                 -- ^ State data provided by user   , drawWindow      :: SDL.Window         -- ^ SDL window   , glContext       :: SDL.GLContext      -- ^ OpenGL rendering context-  , windowRenderer  :: SDL.Renderer       -- ^ Internal renderer of window-  , drawTexture     :: SDL.Texture        -- ^ SDL Texture to draw to-  -- , drawFormat      :: B.BablFormatPtr    -- ^ Target format   , screenMode      :: SDL.WindowMode     -- ^ current screen mode-  -- , drawStack       :: [DrawRequest]      -- ^ Stack of 'DrawRequest's to be processed   , drawDimensions  :: (Int, Int)         -- ^ Dimensions of target surface-  , drawStride      :: Int                -- ^ Stride of target buffer-  , drawCPP         :: Int                -- ^ Number of components per pixel   , 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?-  -- , messageChannel  :: Channel msg        -- ^ The main broadcast channel to duplicate all others from   } --- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated--- data DrawRequest = DrawRequest---   { requestArea     :: G.GeglRectangle -- ^ The area to update---   , requestBuffer   :: G.GeglBuffer    -- ^ Buffer to draw---   , requestPersist  :: RequestPersist  -- ^ Shall the drawRequest persist---   }--- --- data RequestPersist---   = Persist---   | Kill (Maybe G.GeglNode)--- --- -- | A type for storing 'DrawRequest' results to be executed frequently. TODO--- data DrawAsset = DrawAsset- -- | Inner 'StateT' monad for the update state--- type AffectionStateInner us m a = StateT (AffectionData us) m a type AffectionStateInner us a = StateT us a  -- | Affection's state monad@@ -132,102 +84,4 @@  type Affection us a = AffectionState (AffectionData us) IO a --- -- | Inner 'StateT' monad of Affection--- type AffectionInner us od a = StateT (AffectionState us od) IO a--- --- -- | Affection state monad--- newtype Affection us od a = Affection---   { runAffection :: AffectionInner us od a }---   deriving (Functor, Applicative, Monad, MonadState (AffectionState us od))--- --- -- | Inner drawing monad of Affection.--- type AffectionDrawInner ds a = ReaderT (Draw ds) a--- --- -- | Affectiondrawinf reader monad.--- newtype AffectionDraw ds a = AffectionDraw---   { runDraw :: (ds -> a) }---   deriving (Functor, Applicative, Monad, MonadReader ds)--- --- -- | Loop state monad to hold elapsed time per frame--- newtype Loop f a = Loop---   { runLoop :: f -> (a, f) }---   deriving (Functor, Applicative, Monad, MonadState (Loop f))---- data RGBA = RGBA---   { r :: Int---   , g :: Int---   , b :: Int---   , a :: Int---   }---- | Type for defining the draw type of draw functions-data DrawType-    -- | Fill the specified area completely with color-  = Fill-    -- | only draw the outline of the area-  | Line-    { lineWidth :: Int -- ^ Width of line in pixels-    }- type Angle = Double---- -- | Type for defining angles--- data Angle---   = Rad Double -- ^ Angle in radians---   | Deg Double -- ^ Angle in degrees---   deriving (Show)--- --- -- | Typeclass for converting Angles from 'Deg' to 'Rad' and vice versa.--- class ConvertAngle a where---   toRad :: a -> a -- Convert to 'Rad'---   toDeg :: a -> a -- Convert to 'Deg'--- --- instance ConvertAngle Angle where---   toRad (Deg x) = Rad $ x * pi / 180---   toRad x = x--- ---   toDeg (Rad x) = Deg $ x * 180 / pi---   toDeg x = x--- --- instance Eq Angle where---   (==) (Deg x) (Deg y) = x == y---   (==) (Rad x) (Rad y) = x == y---   (==) dx@(Deg _) ry@(Rad _) = dx == toDeg ry---   (==) rx@(Rad _) dy@(Deg _) = toDeg rx == dy---- -- | A single particle--- data Particle = Particle---   { particleTimeToLive :: Double---       -- ^ Time to live in seconds---   , particleCreation   :: Double---       -- ^ Creation time of particle in seconds form program start---   , particlePosition   :: (Double, Double)---       -- ^ Position of particle on canvas---   , particleRotation   :: Angle---       -- ^ Particle rotation---   , particleVelocity   :: (Int, Int)---       -- ^ particle velocity as vector of pixels per second---   , particlePitchRate  :: Angle---       -- ^ Rotational velocity of particle in angle per second---   , particleRootNode   :: G.GeglNode---       -- ^ Root 'G.GeglNode' of 'Particle'---   , particleNodeGraph  :: Map String G.GeglNode---       -- ^ Node Graph of 'G.GeglNodes' per particle---   , particleStackCont  :: G.GeglNode---       -- ^ 'G.GeglNode' to connect other 'Particle's to---   , particleDrawFlange :: G.GeglNode---       -- ^ 'G.GeglNode' to connect draw actions to---   } deriving (Eq)--- --- -- | The particle system--- data ParticleSystem = ParticleSystem---   { partSysParts  :: ParticleStorage---   , partSysNode   :: G.GeglNode---   , partSysBuffer :: G.GeglBuffer---   }--- --- -- | The particle storage datatype--- data ParticleStorage = ParticleStorage---   { partStorLatest :: Maybe Particle -- ^ The particle stored last---   , partStorList   :: [Particle]     -- ^ List of particles in ascending order of remaining lifetime---   }
src/Affection/Util.hs view
@@ -1,25 +1,25 @@-module Affection.Util-where+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 Control.Monad.State --- Prehandle SDL events in case any window events occur+-- | Prehandle SDL events 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 = do-  ad <- get-  return $ userState ad+getAffection = gets userState  -- | Put altered user state back putAffection@@ -38,13 +38,13 @@  -- | Get time since start but always the same in the current tick. getElapsedTime :: Affection us Double-getElapsedTime =-  elapsedTime <$> get+getElapsedTime = gets elapsedTime +-- | Get delta time (time elapsed from last frame) getDelta :: Affection us Double-getDelta =-  deltaTime <$> get+getDelta = gets deltaTime +-- | Quit the engine loop quit :: Affection us () quit = do   ad <- get@@ -63,10 +63,29 @@       SDL.setWindowMode (drawWindow ad) SDL.Windowed       return SDL.Windowed     x -> do-      liftIO $ logIO Warn ("Unknown Screen mode: " ++ show x)+      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 us ()+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 ()