more cleanup

affection.cabal

@@ -68,10 +68,8 @@ library
                      , 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

examples/example00/Main.hs

@@ -1,13 +1,14 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 
-import Affection
-import qualified SDL
+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
@@ -16,10 +17,10 @@ data StateData = StateData
   }
 
 data Subsystems = Subsystems
-  { subWindow :: Window
-  , subMouse :: Mouse
-  , subKeyboard :: Keyboard
-  , subJoystick :: Joystick
+  { subWindow   :: Main.Window
+  , subMouse    :: Main.Mouse
+  , subKeyboard :: Main.Keyboard
+  , subJoystick :: Main.Joystick
   }
 
 newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
@@ -50,8 +51,8 @@ generalUnSubscribe
 generalUnSubscribe t uuid =
   liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
 
-instance Participant Window StateData where
-  type Mesg Window StateData = WindowMessage
+instance Participant Main.Window StateData where
+  type Mesg Main.Window StateData = WindowMessage
 
   partSubscribers (Window t) = generalSubscribers t
 
@@ -59,7 +60,7 @@ instance Participant Window StateData where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Window StateData where
+instance SDLSubsystem Main.Window StateData where
   consumeSDLEvents = consumeSDLWindowEvents
 
 instance Participant Mouse StateData where
@@ -176,7 +177,6 @@ handle es = do
     =<< consumeSDLEvents c
     =<< consumeSDLEvents d es
   mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
-  return ()
 
 update _ = return ()
 

examples/example01/Main.hs

@@ -152,89 +152,77 @@ handle es = do
 update :: Double -> Affection UserData ()
 update _ = do
   ud <- getAffection
-  -- now <- getElapsedTime
-  when (True) $ do
-    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
-        then if 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 return (0, foodMat ud M.! (y, x), 1)
-      else if life == 3
-        then if 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
-            )
-        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
-        }
+  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 (\a acc -> acc + a) 0 mat
+    res = foldr (flip (+)) 0 mat
 
 draw :: Affection UserData ()
 draw = do
@@ -250,10 +238,10 @@ draw = do
       -- logIO A.Debug $ show mult
       beginPath ctx
       rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
-      if (mult == 1)
-      then do
+      if mult == 1
+      then
         fillColor ctx (rgba 255 255 255 255)
-      else do
+      else
         fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
       fill ctx
       ) [0..3599]

examples/example01/Types.hs

@@ -22,16 +22,16 @@ data UserData = UserData
   }
 
 data Subsystems = Subsystems
-  { subWindow   :: Window
-  , subKeyboard :: Keyboard
+  { subWindow   :: Types.Window
+  , subKeyboard :: Types.Keyboard
   }
 
 newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
 
 newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
 
-instance Participant Window UserData where
-  type Mesg Window UserData = WindowMessage
+instance Participant Types.Window UserData where
+  type Mesg Types.Window UserData = WindowMessage
 
   partSubscribers (Window t) = do
     subTups <- liftIO $ readTVarIO t
@@ -41,7 +41,7 @@ instance Participant Window UserData where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Window UserData where
+instance SDLSubsystem Types.Window UserData where
   consumeSDLEvents = consumeSDLWindowEvents
 
 instance Participant Keyboard UserData where

src/Affection.hs

@@ -21,11 +21,8 @@ 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
@@ -88,10 +85,7 @@ withAffection AffectionConfig{..} = do
   (_, nState) <- runStateT ( A.runState $ do
     liftIO $ logIO Debug "Starting Loop"
     preLoop
-    whileM_ (do
-        current <- get
-        return $ not $ A.quitEvent current
-      )
+    whileM_ (not . A.quitEvent current <$> get)
       (do
         -- get state
         ad <- get

src/Affection/Logging.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP #-}
-module Affection.Logging where
--- ^ This module defines the logging capability of Affection, whis is derived
+-- | This module defines the logging capability of Affection, whis is derived
 -- from "Debug.Trace".
+module Affection.Logging where
 
 import Debug.Trace
 

src/Affection/MessageBus.hs

@@ -5,6 +5,5 @@ module Affection.MessageBus
 
 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

@@ -3,7 +3,11 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ExistentialQuantification #-}
-module Affection.MessageBus.Class where
+module Affection.MessageBus.Class
+  ( Participant(..)
+  , genUUID
+  , UUID
+  ) where
 
 import Affection.MessageBus.Message
 import Affection.Types

src/Affection/MessageBus/Message/JoystickMessage.hs

@@ -7,21 +7,21 @@ module Affection.MessageBus.Message.JoystickMessage
   , SDL.JoyButtonState
   , SDL.JoyDeviceConnection
     -- | Number exports
-  , Word8(..)
-  , Int16(..)
-  , Int32(..)
+  , Word8
+  , Int16
+  , Int32
   ) where
 
 import Affection.MessageBus.Message.Class
 
-import Data.Word (Word8(..))
-import Data.Int (Int32(..), Int16(..))
+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
+-- | Datatype for handling all possible joystick events handed over from sdl2
 data JoystickMessage
   = MsgJoystickAxis -- ^ Movement of a Joystick axis
     { msgJAWhen :: Double -- ^ Time of event

src/Affection/MessageBus/Message/MouseMessage.hs

@@ -10,8 +10,8 @@ module Affection.MessageBus.Message.MouseMessage
 
 import Affection.MessageBus.Message.Class
 
-import Data.Word (Word8(..))
-import Data.Int (Int32(..))
+import Data.Word (Word8)
+import Data.Int (Int32)
 
 import qualified SDL
 

src/Affection/MessageBus/Message/WindowMessage.hs

@@ -6,7 +6,7 @@ module Affection.MessageBus.Message.WindowMessage
 
 import Affection.MessageBus.Message.Class
 
-import Data.Int (Int32(..))
+import Data.Int (Int32)
 
 import qualified SDL
 

src/Affection/Subsystems/AffectionJoystick.hs

@@ -5,14 +5,12 @@
 module Affection.Subsystems.AffectionJoystick where
 
 import Affection.MessageBus
-import Affection.Subsystems.Class
 import Affection.Types
 import Affection.Util
 import Affection.Logging
 
 import Control.Monad (filterM)
 import Control.Monad.IO.Class (liftIO)
-import Control.Concurrent.STM
 
 import qualified Data.Vector as V
 
@@ -86,8 +84,8 @@ joystickAutoConnect
   -- ^ Returns a joystick descriptor, if successful
 joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
   [descr] <- V.toList <$>
-    (return . V.filter (\(SDL.JoystickDevice _ id) -> id == CInt which)
-      =<< SDL.availableJoysticks)
+    (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
@@ -103,7 +101,7 @@ 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 -> return . (which ==) =<< SDL.getJoystickID j) js
+    [d] <- filterM ((which ==) <$> SDL.getJoystickID) js
     logIO Verbose $ "disconnected joysticks: " ++ show d
     logIO Verbose $ "Disconnecting Joystick " ++ show which
     SDL.closeJoystick d

src/Affection/Subsystems/AffectionKeyboard.hs

@@ -7,10 +7,6 @@ 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
 

src/Affection/Subsystems/AffectionMouse.hs

@@ -5,13 +5,9 @@
 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

src/Affection/Subsystems/AffectionWindow.hs

@@ -9,10 +9,6 @@ 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
 

src/Affection/Subsystems/Class.hs

@@ -3,7 +3,6 @@
 module Affection.Subsystems.Class where
 
 import Affection.Types
-import Affection.MessageBus
 
 import qualified SDL
 

src/Affection/Types.hs

@@ -1,26 +1,25 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
 module Affection.Types 
-  ( Affection(..)
+  ( Affection
   , AffectionConfig(..)
   , AffectionData(..)
-  , AffectionStateInner(..)
+  , AffectionStateInner
   , AffectionState(..)
   , InitComponents(..)
-  , Angle(..)
+  , Angle
   -- | SDL reexports
   , SDL.WindowConfig(..)
   , SDL.WindowMode(..)
   , SDL.EventPayload(..)
-  , SDL.InitFlags(..)
-  , SDL.Window(..)
-  , SDL.GLContext(..)
+  , 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 Control.Monad.IO.Class
 import Control.Monad.State.Strict
@@ -28,10 +27,6 @@ import qualified Control.Monad.Parallel as MP
 
 import System.Clock (TimeSpec)
 
-import Foreign.Ptr (Ptr)
-
-import Affection.MessageBus.Message
-
 -- | Configuration for the aplication. needed at startup.
 data AffectionConfig us = AffectionConfig
   { initComponents :: InitComponents
@@ -71,8 +66,6 @@ data AffectionData us = AffectionData
   , glContext       :: SDL.GLContext      -- ^ OpenGL rendering context
   , screenMode      :: SDL.WindowMode     -- ^ current screen mode
   , 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)

src/Affection/Util.hs

@@ -19,9 +19,7 @@ preHandleEvents 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
@@ -40,12 +38,10 @@ delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
 
 -- | Get time since start but always the same in the current tick.
 getElapsedTime :: Affection us Double
-getElapsedTime =
-  elapsedTime <$> get
+getElapsedTime = gets elapsedTime
 
 getDelta :: Affection us Double
-getDelta =
-  deltaTime <$> get
+getDelta = gets deltaTime
 
 quit :: Affection us ()
 quit = do