blerg

affection.cabal

@@ -43,6 +43,7 @@ library
                      , Affection.MouseInteractable
                      , Affection.Property
                      , Affection.Actor
+                     , Affection.Animation
   default-extensions:  OverloadedStrings
 
   -- Modules included in this library but not exported.
@@ -191,6 +192,7 @@ executable example05
                      , gegl
                      , babl
                      , containers
+                     , unordered-containers
                      , mtl
                      , random
                      , matrix

examples/example05.1.hs

@@ -0,0 +1,294 @@
+{-# LANGUAGE RecordWildCards, BangPatterns #-}
+
+import Affection
+import qualified SDL
+import qualified GEGL as G
+import qualified BABL as B
+import qualified Data.Map.Strict as M
+import qualified Data.Matrix as X
+import Data.List as L
+import Data.Maybe (fromJust, catMaybes)
+-- import Data.Vector as V
+import System.Random (randomRIO)
+import Control.Monad as CM (when, unless, foldM)
+import qualified Control.Monad.Parallel as MP
+import Control.Parallel.Strategies
+import Foreign.C.Types
+import Foreign.Marshal.Utils
+
+import Debug.Trace
+
+dimension :: Int
+dimension = 60
+
+resolution :: Int
+resolution = 600
+
+main :: IO ()
+main = do
+  conf <- return AffectionConfig
+    { initComponents = All
+    , windowTitle    = "Affection: example00"
+    , windowConfig   = SDL.defaultWindow
+      { windowInitialSize = SDL.V2
+        (CInt $ fromIntegral resolution)
+        (CInt $ fromIntegral resolution)
+      }
+    , canvasSize     = Nothing
+    , preLoop        = loadList
+    , eventLoop      = handle
+    , updateLoop     = Main.update
+    , drawLoop       = draw
+    , loadState      = load
+    , cleanUp        = clean
+    }
+  withAffection conf
+
+data UserData = UserData
+  { nodeGraph    :: M.Map String G.GeglNode
+  , foreground   :: G.GeglBuffer
+  , keysDown     :: [SDL.Keycode]
+  , liveIndices  :: [(Int, Int)]
+  , indices      :: [(Int, Int)]
+  -- , cells        :: [((Int, Int), Actor String)]
+  -- , updateActors :: [Actor String]
+  }
+
+load :: IO UserData
+load = do
+  traceM "loading"
+  root <- G.gegl_node_new
+  traceM "new root node"
+  let bgProps = props $ do
+        prop "x" (0 :: Double)
+        prop "y" (0 :: Double)
+        prop "width" (fromIntegral resolution :: Double)
+        prop "height" (fromIntegral resolution :: Double)
+        prop "color" $ G.RGB 0 0 0
+  bg <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" bgProps
+  traceM "background"
+  over <- G.gegl_node_new_child root G.defaultOverOperation
+  traceM "over"
+  buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 resolution resolution) =<<
+    B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
+  sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
+    props $
+    prop "buffer" buffer
+  traceM "buffer-sink"
+  crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
+    props $ do
+      prop "width" (fromIntegral resolution :: Double)
+      prop "height" (fromIntegral resolution :: Double)
+  G.gegl_node_link_many [bg, over, crop, sink]
+  nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
+  _ <- G.gegl_node_connect_to nop "output" over "aux"
+  traceM "connections made"
+  myMap <- return $ M.fromList
+    [ ("root"        , root)
+    , ("over"        , over)
+    , ("background"  , bg)
+    , ("sink"        , sink)
+    , ("nop"         , nop)
+    , ("crop"        , crop)
+    ]
+  traceM "building matrix"
+  let !emptyMatrix = X.matrix dimension dimension (const False)
+      !indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]]
+  -- traceM "building cells"
+  -- cells <- foldM (\acc index@(row, col) -> do
+  --     tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation
+  --     let !scale = (fromIntegral resolution) / (fromIntegral dimension)
+  --         tempProps =
+  --           props $ do
+  --             prop "x" (((fromIntegral col) - 1) * scale :: Double)
+  --             prop "y" (((fromIntegral row) - 1) * scale :: Double)
+  --             prop "width" (scale :: Double)
+  --             prop "height" (scale :: Double)
+  --             prop "color" $ G.RGB 1 1 1
+  --     tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle"
+  --       tempProps
+  --     G.gegl_node_connect_to tempRect "output" tempOver "aux"
+  --     let tempMap = M.fromList
+  --           [ ("over", tempOver)
+  --           , ("rect", tempRect)
+  --           ]
+  --         tempAProps =
+  --           map (\p -> ActorProperty
+  --             { apName    = G.propertyName p
+  --             , apValue   = G.propertyValue p
+  --             , apMapping = Just "rect"
+  --             }) tempProps
+  --     traceIO $ show index
+  --     return $ (index, Actor
+  --       { actorProperties = tempAProps
+  --       , actorNodes      = tempMap
+  --       }) : acc
+  --   )
+  --   ([] :: [((Int, Int), Actor String)])
+  --   indices
+  --   :: IO [((Int, Int), Actor String)]
+  traceM "loading complete"
+  return UserData
+    { nodeGraph    = myMap
+    , foreground   = buffer
+    , keysDown     = []
+    , indices      = indices
+    , liveIndices  = []
+    -- , cells        = cells
+    -- , updateActors = []
+    }
+
+loadList :: Affection UserData ()
+loadList = do
+  ud@UserData{..} <- getAffection
+  init <- foldM (\acc coord -> do
+    trig <- liftIO $ randomRIO (True, False)
+    if trig then return (coord : acc) else return acc
+    ) [] indices
+  putAffection ud
+    { liveIndices = init
+    }
+
+getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)]
+getNeighbors (row, col) =
+  do
+    UserData{..} <- getAffection
+    mapM (\(pr, pc) ->
+      return (overflow(row + pr), overflow(col + pc))
+      ) lcs
+  where
+    overflow x
+      | x < 1         = dimension
+      | x > dimension = 1
+      | otherwise     = x
+
+lcs :: [(Int, Int)]
+lcs =
+  [ (-1, -1)
+  , (-1, 0)
+  , (-1, 1)
+  , (0, -1)
+  -- , (0, 0)
+  , (0, 1)
+  , (1, -1)
+  , (1, 0)
+  , (1, 1)
+  ]
+
+draw :: Affection UserData ()
+draw = do
+  traceM "drawing"
+  ad <- get
+  ud@UserData{..} <- getAffection
+  SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 0 0 0 255)
+  SDL.clear (windowRenderer ad)
+  SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 255 255 255 255)
+  MP.mapM_ (\(row, col) ->
+    let scale = floor (fromIntegral resolution / fromIntegral dimension)
+    in
+      SDL.fillRect
+        (windowRenderer ad)
+        (Just ( SDL.Rectangle
+          (SDL.P (SDL.V2
+            (CInt $ fromIntegral $ (col - 1) * scale)
+            (CInt $ fromIntegral $ (row - 1) * scale)
+            ))
+          (SDL.V2
+            (CInt $ fromIntegral $ scale)
+            (CInt $ fromIntegral $ scale)
+            )
+          ))
+    ) liveIndices
+  -- render Nothing Nothing
+  -- let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices
+  -- unless (null livingActors) $ do
+  --   liftIO $ G.gegl_node_link_many $
+  --     parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
+  --   _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over")
+  --     (nodeGraph M.! "nop")
+  --   return ()
+  -- process (nodeGraph M.! "sink")
+  -- present (G.GeglRectangle 0 0 resolution resolution) foreground True
+  -- render
+  --   Nothing
+  --   Nothing
+  -- _ <- liftIO $ MP.mapM
+  --   (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
+  --   ) livingActors
+  -- putAffection ud
+  --   { updateActors = []
+  --   }
+
+update :: Double -> Affection UserData ()
+update dt = do
+  traceM "updating"
+
+  ud <- getAffection
+  elapsed <- getElapsedTime
+
+  traceM $ show (1 / dt) ++ " FPS"
+  traceM $ show $ keysDown ud
+
+  relevant <- getRelevant (liveIndices ud)
+
+  new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
+    neighs <-
+      foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
+        getNeighbors coord
+    let ret
+          | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
+              Just coord
+          | neighs == 3 =
+              Just coord
+          | otherwise =
+              Nothing
+    return ret
+    ) relevant
+    
+  ud2 <- getAffection
+  putAffection ud2
+    { liveIndices = new
+    }
+
+  mapM_ (\code ->
+    when (code == SDL.KeycodeR) loadList
+    ) (keysDown ud)
+
+getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)]
+getRelevant ls =
+    getRelevant' ls
+  where
+    getRelevant' xs = foldM (\acc x -> do
+      neighs <- getNeighbors x
+      let slice = (x : neighs)
+          rels = foldl (\a y ->
+            if y `elem` acc then a else y : a
+            ) [] slice
+      return (acc ++ rels)
+      ) [] xs
+
+handle :: SDL.EventPayload -> Affection UserData ()
+handle (SDL.KeyboardEvent dat) =
+  when (not (SDL.keyboardEventRepeat dat)) $ do
+    ud <- getAffection
+    if (SDL.keyboardEventKeyMotion dat == SDL.Pressed)
+    then
+      putAffection ud
+        { keysDown =
+            SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud
+        }
+    else
+      putAffection ud
+        { keysDown =
+            delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown ud)
+        }
+
+handle (SDL.WindowClosedEvent _) = do
+  traceM "seeya!"
+  quit
+
+handle _ =
+  return ()
+
+clean :: UserData -> IO ()
+clean _ = return ()

examples/example05.hs

@@ -5,12 +5,15 @@ import qualified SDL
 import qualified GEGL as G
 import qualified BABL as B
 import qualified Data.Map.Strict as M
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
 import qualified Data.Matrix as X
 import Data.List as L
+import Data.Foldable (foldrM, foldlM)
 import Data.Maybe (fromJust, catMaybes)
 -- import Data.Vector as V
 import System.Random (randomRIO)
-import Control.Monad as CM (when, unless, foldM)
+import Control.Monad as CM (when, unless)
 import qualified Control.Monad.Parallel as MP
 import Control.Parallel.Strategies
 import Foreign.C.Types
@@ -48,9 +51,9 @@ data UserData = UserData
   { nodeGraph    :: M.Map String G.GeglNode
   , foreground   :: G.GeglBuffer
   , keysDown     :: [SDL.Keycode]
-  , liveIndices  :: [(Int, Int)]
+  , liveIndices  :: HS.HashSet (Int, Int)
   , indices      :: [(Int, Int)]
-  , cells        :: [((Int, Int), Actor String)]
+  , cells        :: HM.HashMap (Int, Int) (Actor String)
   , updateActors :: [Actor String]
   }
 
@@ -95,7 +98,7 @@ load = do
   let !emptyMatrix = X.matrix dimension dimension (const False)
       !indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]]
   traceM "building cells"
-  cells <- foldM (\acc index@(row, col) -> do
+  cells <- foldrM (\index@(row, col) acc -> do
       tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation
       let !scale = (fromIntegral resolution) / (fromIntegral dimension)
           tempProps =
@@ -119,21 +122,21 @@ load = do
               , apMapping = Just "rect"
               }) tempProps
       traceIO $ show index
-      return $ (index, Actor
+      return $ HM.insert index Actor
         { actorProperties = tempAProps
         , actorNodes      = tempMap
-        }) : acc
+        }
+        acc
     )
-    ([] :: [((Int, Int), Actor String)])
+    HM.empty
     indices
-    :: IO [((Int, Int), Actor String)]
   traceM "loading complete"
   return UserData
     { nodeGraph    = myMap
     , foreground   = buffer
     , keysDown     = []
     , indices      = indices
-    , liveIndices  = []
+    , liveIndices  = HS.empty
     , cells        = cells
     , updateActors = []
     }
@@ -141,21 +144,18 @@ load = do
 loadList :: Affection UserData ()
 loadList = do
   ud@UserData{..} <- getAffection
-  init <- foldM (\acc coord -> do
+  -- init <- foldrM (\coord acc -> do
+  init <- foldlM (\acc coord -> do
     trig <- liftIO $ randomRIO (True, False)
-    if trig then return (coord : acc) else return acc
+    if trig then return (HS.insert coord acc) else return acc
-    ) [] indices
+    ) HS.empty indices
   putAffection ud
     { liveIndices = init
     }
 
-getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)]
+getNeighbors :: (Int, Int) -> [(Int, Int)]
 getNeighbors (row, col) =
-  do
+  map (\(pr, pc) -> (overflow(row + pr), overflow(col + pc))) lcs
-    UserData{..} <- getAffection
-    mapM (\(pr, pc) ->
-      return (overflow(row + pr), overflow(col + pc))
-      ) lcs
   where
     overflow x
       | x < 1         = dimension
@@ -179,7 +179,7 @@ draw :: Affection UserData ()
 draw = do
   traceM "drawing"
   ud@UserData{..} <- getAffection
-  let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices
+  let livingActors = parMap rpar (cells HM.!) $ HS.toList liveIndices
   unless (null livingActors) $ do
     liftIO $ G.gegl_node_link_many $
       parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
@@ -191,9 +191,9 @@ draw = do
   render
     Nothing
     Nothing
-  _ <- liftIO $ MP.mapM
+  -- _ <- liftIO $ MP.mapM
-    (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
+  --   (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
-    ) livingActors
+  --   ) livingActors
   putAffection ud
     { updateActors = []
     }
@@ -210,19 +210,48 @@ update dt = do
 
   relevant <- getRelevant (liveIndices ud)
 
-  new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
+  -- let new = HS.fromList $ catMaybes $ parMap rpar (\coord@(row, col) ->
-    neighs <-
+  --       let neighs =
-      foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
+  --             foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 $
+  --               getNeighbors coord
+  --           ret
+  --             | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
+  --                 Just coord
+  --             | neighs == 3 =
+  --                 Just coord
+  --             | otherwise =
+  --                 Nothing
+  --       in ret
+  --       ) (HS.toList relevant)
+
+  new <- foldrM (\coord@(row, col) acc -> do
+  -- new <- foldlM (\acc coord@(row, col) -> do
+    let !neighs = sum $
+          map (\n -> if n `elem` liveIndices ud then 1 else 0)$
             getNeighbors coord
-    let ret
+        ret
           | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
-              Just coord
+              HS.insert coord acc
           | neighs == 3 =
-              Just coord
+              HS.insert coord acc
           | otherwise =
-              Nothing
+              acc
     return ret
-    ) relevant
+    ) HS.empty relevant
+
+  -- new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
+  --   neighs <-
+  --     foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
+  --       getNeighbors coord
+  --   let ret
+  --         | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
+  --             Just coord
+  --         | neighs == 3 =
+  --             Just coord
+  --         | otherwise =
+  --             Nothing
+  --   return ret
+  --   ) relevant
     
   ud2 <- getAffection
   putAffection ud2
@@ -233,18 +262,19 @@ update dt = do
     when (code == SDL.KeycodeR) loadList
     ) (keysDown ud)
 
-getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)]
+getRelevant :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int))
-getRelevant ls =
+getRelevant ls = do
     getRelevant' ls
   where
-    getRelevant' xs = foldM (\acc x -> do
+    getRelevant' xs = foldlM (\acc x ->
-      neighs <- getNeighbors x
+      let neighs = getNeighbors x
-      let slice = (x : neighs)
+          slice = (x : neighs)
-          rels = foldl (\a y ->
+          rels = foldr (\y a ->
-            if y `elem` acc then a else y : a
+          -- rels = foldl (\a y ->
-            ) [] slice
+            if y `elem` acc then a else HS.insert y a
-      return (acc ++ rels)
+            ) HS.empty slice
-      ) [] xs
+      in return (acc `HS.union` rels)
+      ) HS.empty xs
 
 handle :: SDL.EventPayload -> Affection UserData ()
 handle (SDL.KeyboardEvent dat) =
@@ -271,3 +301,12 @@ handle _ =
 
 clean :: UserData -> IO ()
 clean _ = return ()
+
+parHSMap f = (`using` parTraversable rpar) . HM.map f
+
+-- catHSMaybe =
+--   foldr (\x acc ->
+--     case x of
+--       Just a -> a `HS.insert` acc
+--       Nothing -> acc
+--     ) HS.empty

src/Affection.hs

@@ -41,6 +41,7 @@ import Affection.StateMachine as A
 import Affection.MouseInteractable as A
 import Affection.Property as A
 import Affection.Actor as A
+import Affection.Animation as A
 
 import qualified BABL as B
 

src/Affection/Actor.hs

@@ -7,6 +7,7 @@ module Affection.Actor
   , ActorProperty(..)
   , updateProperties
   , applyProperties
+  , getProperty
   ) where
 
 import qualified GEGL as G
@@ -20,13 +21,14 @@ import Affection.Types
 data Ord a => Actor a = Actor
   { actorProperties :: [ActorProperty a]
   , actorNodes      :: M.Map a G.GeglNode
-  }
+  , actorFlange     :: G.GeglNode
+  } deriving (Eq)
 
 data Ord a => ActorProperty a = ActorProperty
   { apName    :: String
   , apValue   :: G.PropertyValue
-  , apMapping :: Maybe a
+  , apMapping :: Maybe (a, String)
-  }
+  } deriving (Eq)
 
 updateProperties :: Ord a => [G.Property] -> Actor a -> Actor a
 updateProperties ps act@Actor{..} =
@@ -48,7 +50,13 @@ applyProperties :: Ord a => Actor a -> Affection us ()
 applyProperties Actor{..} =
   MP.mapM_ (\(ActorProperty{..}) ->
     maybe (return ()) (\m ->
-      liftIO $ G.gegl_node_set (actorNodes M.! m) $ G.Operation "" $
+      liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $
-        (G.Property apName apValue) : []
+        (G.Property (snd m) apValue) : []
       ) apMapping
     ) actorProperties
+
+getProperty :: Ord a => String -> Actor a -> Maybe G.PropertyValue
+getProperty name act =
+  case find (\a -> name == apName a) $ actorProperties act of
+    Just p -> Just $ apValue p
+    Nothing -> Nothing

src/Affection/Animation.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Affection.Animation
+  ( SpriteAnimation(..)
+  , runAnimation
+  ) where
+
+import Affection.Actor
+import Affection.Types
+import Affection.Property
+
+import qualified GEGL as G
+
+import Control.Monad.State
+
+data SpriteAnimation = SpriteAnimation
+  { sanimCurrentFrame :: Int
+  , sanimSprites :: [FilePath]
+  , sanimFrameDuration :: Double
+  , sanimLoop :: Bool
+  , sanimLastChange :: Double
+  , sanimPropName :: String
+  }
+
+runAnimation
+  :: Ord a
+  => Actor a
+  -> SpriteAnimation
+  -> Affection us (SpriteAnimation, Actor a)
+runAnimation act anim@SpriteAnimation{..} = do
+  ad <- get
+  let elapsed = elapsedTime ad
+  if elapsed - sanimLastChange > sanimFrameDuration
+  then do
+    let nframe =
+          if sanimCurrentFrame + 1 > length sanimSprites
+          then
+            if sanimLoop then 1 else sanimCurrentFrame
+          else sanimCurrentFrame + 1
+        nact =
+          updateProperties
+          (props $ prop sanimPropName $ sanimSprites !! (nframe - 1))
+          act
+    return (anim
+      { sanimCurrentFrame = nframe
+      , sanimLastChange = elapsed
+      }, nact)
+  else
+    return (anim, act)

src/Affection/Draw.hs

@@ -101,27 +101,6 @@ render msrc mtgt =
     src = maybe Nothing (Just . toSdlRect) msrc
     tgt = maybe Nothing (Just . toSdlRect) mtgt
 
--- putToSurface
---   :: Ptr a
---   -> G.GeglRectangle
---   -> Int
---   -> Int
---   -> DrawRequest
---   -> Affection us ()
--- putToSurface pixels realRect stride cpp DrawRequest{..} = do
---   ad <- get
---   liftIO $ SDL.lockSurface $ drawSurface ad
---   liftIO $ G.gegl_buffer_get
---     requestBuffer
---     (Just realRect)
---     1
---     (Just $ drawFormat ad)
---     (pixels `plusPtr`
---       (rectangleX realRect * cpp + rectangleY realRect * stride))
---     stride
---     G.GeglAbyssNone
---   liftIO $ SDL.unlockSurface $ drawSurface ad
-
 putToTexture
   :: G.GeglRectangle
   -> Int
@@ -143,7 +122,6 @@ putToTexture realRect stride cpp DrawRequest{..} = do
   (destPtr, destStride) <- SDL.lockTexture
     (drawTexture ad)
     (Just destRect)
-  -- destPtr <- liftIO $ malloc :: (Ptr ByteString)
   liftIO $ G.gegl_buffer_get
     requestBuffer
     (Just realRect)
@@ -152,17 +130,6 @@ putToTexture realRect stride cpp DrawRequest{..} = do
     destPtr
     stride
     G.GeglAbyssNone
-  -- pixelData <- liftIO $ peekArray
-  --   (rectangleWidth realRect * rectangleHeight realRect)
-  --   destPtr
-  -- SDL.updateTexture
-  --   (drawTexture ad)
-  --   (Just $ SDL.Rectangle
-  --     (SDL.P $ SDL.V2 (rectangleX realRect) (rectangleY realRect))
-  --     (SDL.V2 (rectangleWidth realRect) (rectangleHeight realRect))
-  --     )
-  --   pixelData
-  --   (CInt $ fromIntegral stride)
   SDL.unlockTexture $ drawTexture ad
 
 -- | function for handling 'DrawRequest's and updating the output

src/Affection/MouseInteractable.hs

@@ -23,11 +23,11 @@ class MouseClickable a us where
 -- This function does not consume provided events, but passes them on.
 handleMouseClicks
   :: (Foldable t, MouseClickable clickable us)
-  => SDL.Event                    -- ^ Piped event in
+  => SDL.EventPayload              -- ^ Piped event in
   -> t clickable                   -- ^ 'MouseClickable' elemt to be checked
-  -> Affection us SDL.Event       -- ^ Unaltered event
+  -> Affection us SDL.EventPayload -- ^ Unaltered event
 handleMouseClicks e clickables =
-  case SDL.eventPayload e of
+  case e of
     SDL.MouseButtonEvent dat -> do
       mapM_ (\clickable -> do
         let SDL.P (SDL.V2 x y) = SDL.mouseButtonEventPos dat

src/Affection/Particle.hs

@@ -34,7 +34,17 @@ updateParticle
   -> Affection us [Particle]
         -- ^ processed 'Particle's
 updateParticle time func l =
-  updateParticle' time func l
+  catMaybes <$> MP.mapM (\p -> do
+    now <- elapsedTime <$> get
+    if particleCreation p + particleTimeToLive p < now
+    then do
+      dropParticle p
+      return Nothing
+    else do
+      np <- func time p
+      return $ Just np
+    ) l
+  -- updateParticle' time func l
   where
     updateParticle' _  _   []     = return []
     updateParticle' dt fun [p]    = do

src/Affection/StateMachine.hs

@@ -9,6 +9,6 @@ import qualified SDL
 class StateMachine a us where
   smLoad   :: a -> Affection us ()
   smUpdate :: a -> Double -> Affection us ()
-  smEvent  :: a -> Double -> SDL.Event -> Affection us ()
+  smEvent  :: a -> SDL.EventPayload -> Affection us ()
   smDraw   :: a -> Affection us ()
   smClean  :: a -> Affection us ()