This commit is contained in:
nek0 2017-04-17 12:40:17 +02:00
parent 1875797cb1
commit 63a493ed19
10 changed files with 460 additions and 90 deletions

View file

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

294
examples/example05.1.hs Normal file
View file

@ -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 ()

View file

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

View file

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

View file

@ -3,11 +3,12 @@
-- | This module implements the Actor, a Datastructure binding a 'G.GeglNode' -- | This module implements the Actor, a Datastructure binding a 'G.GeglNode'
-- to a game asset -- to a game asset
module Affection.Actor module Affection.Actor
( Actor(..) ( Actor(..)
, ActorProperty(..) , ActorProperty(..)
, updateProperties , updateProperties
, applyProperties , applyProperties
) where , getProperty
) where
import qualified GEGL as G import qualified GEGL as G
@ -20,13 +21,14 @@ import Affection.Types
data Ord a => Actor a = Actor data Ord a => Actor a = Actor
{ actorProperties :: [ActorProperty a] { actorProperties :: [ActorProperty a]
, actorNodes :: M.Map a G.GeglNode , actorNodes :: M.Map a G.GeglNode
} , actorFlange :: G.GeglNode
} deriving (Eq)
data Ord a => ActorProperty a = ActorProperty data Ord a => ActorProperty a = ActorProperty
{ apName :: String { apName :: String
, apValue :: G.PropertyValue , apValue :: G.PropertyValue
, apMapping :: Maybe a , apMapping :: Maybe (a, String)
} } deriving (Eq)
updateProperties :: Ord a => [G.Property] -> Actor a -> Actor a updateProperties :: Ord a => [G.Property] -> Actor a -> Actor a
updateProperties ps act@Actor{..} = updateProperties ps act@Actor{..} =
@ -48,7 +50,13 @@ applyProperties :: Ord a => Actor a -> Affection us ()
applyProperties Actor{..} = applyProperties Actor{..} =
MP.mapM_ (\(ActorProperty{..}) -> MP.mapM_ (\(ActorProperty{..}) ->
maybe (return ()) (\m -> 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 ) apMapping
) actorProperties ) 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

View file

@ -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)

View file

@ -101,27 +101,6 @@ render msrc mtgt =
src = maybe Nothing (Just . toSdlRect) msrc src = maybe Nothing (Just . toSdlRect) msrc
tgt = maybe Nothing (Just . toSdlRect) mtgt 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 putToTexture
:: G.GeglRectangle :: G.GeglRectangle
-> Int -> Int
@ -143,7 +122,6 @@ putToTexture realRect stride cpp DrawRequest{..} = do
(destPtr, destStride) <- SDL.lockTexture (destPtr, destStride) <- SDL.lockTexture
(drawTexture ad) (drawTexture ad)
(Just destRect) (Just destRect)
-- destPtr <- liftIO $ malloc :: (Ptr ByteString)
liftIO $ G.gegl_buffer_get liftIO $ G.gegl_buffer_get
requestBuffer requestBuffer
(Just realRect) (Just realRect)
@ -152,17 +130,6 @@ putToTexture realRect stride cpp DrawRequest{..} = do
destPtr destPtr
stride stride
G.GeglAbyssNone 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 SDL.unlockTexture $ drawTexture ad
-- | function for handling 'DrawRequest's and updating the output -- | function for handling 'DrawRequest's and updating the output

View file

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

View file

@ -34,7 +34,17 @@ updateParticle
-> Affection us [Particle] -> Affection us [Particle]
-- ^ processed 'Particle's -- ^ processed 'Particle's
updateParticle time func l = 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 where
updateParticle' _ _ [] = return [] updateParticle' _ _ [] = return []
updateParticle' dt fun [p] = do updateParticle' dt fun [p] = do

View file

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