From 63a493ed19b3bcf4c9a56c438e85bb75a3026487 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 17 Apr 2017 12:40:17 +0200 Subject: [PATCH] blerg --- affection.cabal | 2 + examples/example05.1.hs | 294 +++++++++++++++++++++++++++++ examples/example05.hs | 121 ++++++++---- src/Affection.hs | 1 + src/Affection/Actor.hs | 28 ++- src/Affection/Animation.hs | 49 +++++ src/Affection/Draw.hs | 33 ---- src/Affection/MouseInteractable.hs | 8 +- src/Affection/Particle.hs | 12 +- src/Affection/StateMachine.hs | 2 +- 10 files changed, 460 insertions(+), 90 deletions(-) create mode 100644 examples/example05.1.hs create mode 100644 src/Affection/Animation.hs diff --git a/affection.cabal b/affection.cabal index 23dad16..99db33f 100644 --- a/affection.cabal +++ b/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 diff --git a/examples/example05.1.hs b/examples/example05.1.hs new file mode 100644 index 0000000..2758c28 --- /dev/null +++ b/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 () diff --git a/examples/example05.hs b/examples/example05.hs index 612770e..b30b28f 100644 --- a/examples/example05.hs +++ b/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 - ) [] indices + if trig then return (HS.insert coord acc) else return acc + ) HS.empty indices putAffection ud { liveIndices = init } -getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)] +getNeighbors :: (Int, Int) -> [(Int, Int)] getNeighbors (row, col) = - do - UserData{..} <- getAffection - mapM (\(pr, pc) -> - return (overflow(row + pr), overflow(col + pc)) - ) lcs + map (\(pr, pc) -> (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 - (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input" - ) livingActors + -- _ <- liftIO $ MP.mapM + -- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input" + -- ) livingActors putAffection ud { updateActors = [] } @@ -210,19 +210,48 @@ update dt = do 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 + -- let new = HS.fromList $ catMaybes $ parMap rpar (\coord@(row, col) -> + -- let neighs = + -- 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 + 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 ls = +getRelevant :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int)) +getRelevant ls = do 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 + getRelevant' xs = foldlM (\acc x -> + let neighs = getNeighbors x + slice = (x : neighs) + rels = foldr (\y a -> + -- rels = foldl (\a y -> + if y `elem` acc then a else HS.insert y a + ) HS.empty slice + 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 diff --git a/src/Affection.hs b/src/Affection.hs index 430d57b..ea65131 100644 --- a/src/Affection.hs +++ b/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 diff --git a/src/Affection/Actor.hs b/src/Affection/Actor.hs index cd773c6..e7dff80 100644 --- a/src/Affection/Actor.hs +++ b/src/Affection/Actor.hs @@ -3,11 +3,12 @@ -- | This module implements the Actor, a Datastructure binding a 'G.GeglNode' -- to a game asset module Affection.Actor - ( Actor(..) - , ActorProperty(..) - , updateProperties - , applyProperties - ) where + ( 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 "" $ - (G.Property apName apValue) : [] + liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $ + (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 diff --git a/src/Affection/Animation.hs b/src/Affection/Animation.hs new file mode 100644 index 0000000..0bafb9f --- /dev/null +++ b/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) diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index c02cd1e..21c4cd8 100644 --- a/src/Affection/Draw.hs +++ b/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 diff --git a/src/Affection/MouseInteractable.hs b/src/Affection/MouseInteractable.hs index 9af9a64..e3a6436 100644 --- a/src/Affection/MouseInteractable.hs +++ b/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 - -> t clickable -- ^ 'MouseClickable' elemt to be checked - -> Affection us SDL.Event -- ^ Unaltered event + => SDL.EventPayload -- ^ Piped event in + -> t clickable -- ^ 'MouseClickable' elemt to be checked + -> 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 diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 0623a51..0518cd3 100644 --- a/src/Affection/Particle.hs +++ b/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 diff --git a/src/Affection/StateMachine.hs b/src/Affection/StateMachine.hs index 7ea9597..067ae78 100644 --- a/src/Affection/StateMachine.hs +++ b/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 ()