From d5bf09919cf3ad7ae37c8b42a3d6f51f5f583be8 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 01:13:00 +0100 Subject: [PATCH] make it work! --- examples/example03.hs | 31 +++++++++++++++++++------------ src/Affection/Draw.hs | 24 ++++++++++++++++++++---- src/Affection/Particle.hs | 24 ++++++++++++++---------- src/Affection/Types.hs | 2 +- 4 files changed, 54 insertions(+), 27 deletions(-) diff --git a/examples/example03.hs b/examples/example03.hs index da2ed00..02ed06d 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -171,21 +171,28 @@ update sec = do clean :: UserData -> IO () clean _ = return () -partUpd :: Double -> Particle -> Particle -partUpd sec p@Particle{..} = - p +partUpd :: Double -> Particle -> Affection UserData Particle +partUpd sec p@Particle{..} = do + let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity) + newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity) + liftIO $ G.gegl_node_set (particleNodeGraph M.! "rect") $ G.Operation "gegl:rectangle" + [ G.Property "x" $ G.PropertyDouble $ newX - 10 + , G.Property "y" $ G.PropertyDouble $ newY - 10 + ] + return p { particlePosition = (newX, newY) } - where - newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity) - newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity) partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData () partDraw buf node Particle{..} = do - ud <- getAffection - drawRect' - particleDrawFlange - (G.RGBA 1 0 0 0.5) - (Fill) - (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20) + present + (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20) buf + False + -- ud <- getAffection + -- drawRect' + -- particleDrawFlange + -- (G.RGBA 1 0 0 0.5) + -- (Fill) + -- (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20) + -- buf diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 1a3ab75..8826e10 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -8,7 +8,7 @@ module Affection.Draw -- , clear , handleDrawRequest , invalidateDrawRequest - -- , present + , present , clearArea ) where @@ -89,7 +89,20 @@ drawRect' node color Fill rect@GeglRectangle{..} buf = do diw <- liftIO $ G.gegl_node_connect_to opNode "output" node "input" unless diw $ error "Affection.Draw.drawRect': connect failed" put $ ad - { drawStack = (DrawRequest rect buf (Kill tempRoot)) : drawStack ad + { drawStack = (DrawRequest rect buf (Kill (Just tempRoot))) : drawStack ad + } + +-- | Force update of a specific region on screen +present + :: G.GeglRectangle -- ^ Area to be updated + -> G.GeglBuffer -- ^ Target buffer + -> Bool -- ^ Shall the 'DrawRequest' persist? + -> Affection us () +present rect buf kill = do + ad <- get + let k = if not kill then Kill Nothing else Yes + put ad + { drawStack = (DrawRequest rect buf k) : drawStack ad } -- -- | force a blit of a specified area. Do not use often as it slows down the program @@ -168,8 +181,11 @@ invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do stride G.GeglAbyssNone liftIO $ SDL.unlockSurface surf - let Kill victim = requestPersist - liftIO $ G.gegl_node_drop victim + case requestPersist of + Kill (Just victim) -> + liftIO $ G.gegl_node_drop victim + _ -> + return () -- liftIO $ SDL.updateWindowSurface $ drawWindow ad -- | compute color for a single pixel diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 884bc6f..5a5d45d 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -19,19 +19,23 @@ import qualified GEGL as G -- and death is being handled by 'updateParticles' itself and does not need to -- bother you. updateParticle - :: Double -- ^ Elapsed time in seconds - -> (Double -> Particle -> Particle) -- ^ Update function for a single 'Particle' - -- This Function should take the elapsed time - -- in seconds and the initial particle as arguments. - -> Particle -- ^ 'Particle' to be processed - -> IO (Maybe Particle) -- ^ resulting 'Particle' + :: Double + -- ^ Elapsed time in seconds + -> (Double -> Particle -> Affection us Particle) + -- ^ Update function for a single 'Particle' + -- This Function should take the elapsed time + -- in seconds and the initial particle as arguments. + -> Particle + -- ^ 'Particle' to be processed + -> Affection us (Maybe Particle) + -- ^ resulting 'Particle' updateParticle time funct pa = if particleLife pa - time < 0 then do - G.gegl_node_drop $ particleRootNode pa + liftIO $ G.gegl_node_drop $ particleRootNode pa return $ Nothing else - return $ Just $ funct time $ pa { particleLife = particleLife pa - time } + Just <$> funct time pa { particleLife = particleLife pa - time } -- updateParticle time funct acc@[p] pa = -- if particleLife pa - time < 0 -- then do @@ -56,13 +60,13 @@ drawParticles = mapM_ updateParticleSystem :: ParticleSystem -> Double - -> (Double -> Particle -> Particle) + -> (Double -> Particle -> Affection us Particle) -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ()) -> Affection us ParticleSystem updateParticleSystem sys sec upd draw = do -- let x = catMaybes <$> mapM (updateParticle sec upd) (psParts sys) -- x <- liftIO $ catMaybes <$> foldM (updateParticle sec upd) [] (psParts sys) - x <- liftIO $ catMaybes <$> mapM (updateParticle sec upd) (psParts sys) + x <- catMaybes <$> mapM (updateParticle sec upd) (psParts sys) liftIO $ G.gegl_node_link_many $ map particleStackCont x ++ [psNode sys] mapM_ (draw (psBuffer sys) (psNode sys)) x return $ sys diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index c02e889..9d43022 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -88,7 +88,7 @@ data DrawRequest = DrawRequest data RequestPersist = Yes - | Kill G.GeglNode + | Kill (Maybe G.GeglNode) -- | A type for storing 'DrawRequest' results to be executed frequently. TODO data DrawAsset = DrawAsset