From 9d1b26d633ffc22b58360d08f5933475b8eb1471 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 13 Dec 2016 11:08:49 +0100 Subject: [PATCH] new: particle system and an example for that --- affection.cabal | 18 +++++ examples/example03.hs | 155 ++++++++++++++++++++++++++++++++++++++ src/Affection.hs | 6 +- src/Affection/Draw.hs | 16 ++-- src/Affection/Particle.hs | 37 ++++++--- src/Affection/Types.hs | 15 +++- 6 files changed, 223 insertions(+), 24 deletions(-) create mode 100644 examples/example03.hs diff --git a/affection.cabal b/affection.cabal index a57e18b..da1f56e 100644 --- a/affection.cabal +++ b/affection.cabal @@ -112,3 +112,21 @@ executable example02 , mtl else buildable: False + +executable example03 + hs-source-dirs: examples + main-is: example03.hs + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base + , affection + , sdl2 + , gegl + , babl + , containers + , mtl + , random + else + buildable: False diff --git a/examples/example03.hs b/examples/example03.hs new file mode 100644 index 0000000..7236074 --- /dev/null +++ b/examples/example03.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE RecordWildCards #-} + +import Affection +import qualified SDL +import qualified GEGL as G +import qualified BABL as B +import qualified Data.Map.Strict as M + +import Foreign.C.Types + +import System.Random (randomRIO) + +import Debug.Trace + +main :: IO () +main = do + conf <- return $ AffectionConfig + { initComponents = All + , windowTitle = "Affection: example00" + , windowConfig = SDL.defaultWindow + , preLoop = drawInit + , drawLoop = draw + , updateLoop = update + , loadState = load + , cleanUp = clean + } + withAffection conf + +data UserData = UserData + { nodeGraph :: M.Map String G.GeglNode + , foreground :: G.GeglBuffer + , coordinates :: Maybe (Int, Int) + , partsys :: ParticleSystem + } + +load :: SDL.Surface -> IO UserData +load _ = do + traceM "loading" + root <- G.gegl_node_new + traceM "new root node" + checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation + [ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1 + , G.Property "color2" $ G.PropertyColor $ G.RGBA 0.6 0.6 0.6 1 + ] + traceM "checkerboard" + over <- G.gegl_node_new_child root G.defaultOverOperation + traceM "over" + buffer <- G.gegl_buffer_new (G.GeglRectangle 0 0 800 600) =<< + B.babl_format (B.PixelFormat B.RGBA B.CFfloat) + bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation + [ G.Property "buffer" $ G.PropertyBuffer buffer + ] + traceM "buffer-source" + G.gegl_node_link checkerboard over + G.gegl_node_connect_to bufsrc "output" over "aux" + traceM "connections made" + myMap <- return $ M.fromList + [ ("root" , root) + , ("over" , over) + , ("background" , checkerboard) + , ("foreground" , bufsrc) + ] + traceM "loading complete" + return $ UserData + { nodeGraph = myMap + , foreground = buffer + , coordinates = Nothing + , partsys = ParticleSystem [] over buffer + } + +drawInit :: Affection UserData () +drawInit = do + UserData{..} <- getAffection + present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True + +draw :: Affection UserData () +draw = do + traceM "drawing" + -- ad <- get + -- ud <- getAffection + -- drawParticles partDraw $ particles ud + -- SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad + -- let (w, h) = (fromIntegral rw, fromIntegral rh) + -- liftIO $ clearArea (foreground ud) (GeglRectangle 0 0 w h) + -- maybe (return ()) (\(x, y) -> + -- drawRect + -- (foreground ud) + -- (nodeGraph ud M.! "over") + -- (G.RGBA 1 0 0 0.5) + -- (Line 7) + -- (G.GeglRectangle (x - 10) (y - 10) 20 20) + -- ) $ coordinates ud + +update :: Double -> AffectionState (AffectionData UserData) IO () +update sec = do + traceM "updating" + ad <- get + ud <- getAffection + -- let newPart = updateParticles sec partUpd $ particles ud + -- putAffection $ ud { particles = newPart } + nps <- updateParticleSystem (partsys ud) sec partUpd partDraw + putAffection $ ud { partsys = nps } + traceM $ (show $ 1 / sec) ++ " FPS" + ev <- liftIO $ SDL.pollEvent + maybe (return ()) (\e -> + case SDL.eventPayload e of + SDL.MouseButtonEvent dat -> if sec < 0.03 + then do + let (SDL.P (SDL.V2 x y)) = SDL.mouseButtonEventPos dat + vx <- liftIO $ randomRIO (-20, 20) + vy <- liftIO $ randomRIO (-20, 20) + traceM $ "velocity is: " ++ show vx ++ " " ++ show vy + putAffection $ ud + { coordinates = Just (fromIntegral x, fromIntegral y) + , partsys = (partsys ud) + { psParts = (Particle + { particleLife = 5 + , particlePosition = (fromIntegral x, fromIntegral y) + , particleRotation = 0 + , particleVelocity = (vx, vy) + }) : (psParts $ partsys ud) + } + } + else return () + SDL.WindowClosedEvent _ -> do + traceM "seeya!" + put $ ad + { quitEvent = True + } + _ -> + return () + ) ev + +clean :: UserData -> IO () +clean _ = return () + +partUpd :: Double -> Particle -> Particle +partUpd sec p@Particle{..} = + p + { particlePosition = (newX, newY) + , particleLife = particleLife - sec + } + 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 + buf + node + (G.RGBA 1 0 0 0.5) + (Line 5) + (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20) diff --git a/src/Affection.hs b/src/Affection.hs index cddccae..4cfc9cb 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -30,7 +30,7 @@ import Foreign.Storable (peek) import Affection.Types as A import Affection.Draw as A -import Afection.Particle as A +import Affection.Particle as A import qualified BABL as B @@ -79,13 +79,13 @@ withAffection AffectionConfig{..} = do put $ ad { drawStack = [] } drawLoop + updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / + (fromIntegral 10 ^ 9) ad <- get clear <- return . catMaybes =<< mapM (handleDrawRequest pixels format stride cpp) (drawStack ad) put $ ad { drawStack = clear } liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing - updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / - (fromIntegral 10 ^ 9) _ <- liftIO $ swapMVar execTime $ now return () ) diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 63abfa6..975ee30 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, BangPatterns #-} -- | Module for drawing primitives module Affection.Draw @@ -78,7 +78,8 @@ handleDrawRequest -> Affection us (Maybe DrawRequest) handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do ad <- get - liftIO $ SDL.lockSurface $ drawSurface ad + let !surf = drawSurface ad + liftIO $ SDL.lockSurface surf liftIO $ G.gegl_node_blit requestNode 1 @@ -86,9 +87,9 @@ handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do format (pixels `plusPtr` (rectangleX requestArea * cpp + rectangleY requestArea * stride)) - stride + 0 [G.GeglBlitDefault] - liftIO $ SDL.unlockSurface $ drawSurface ad + liftIO $ SDL.unlockSurface surf liftIO $ SDL.updateWindowSurface $ drawWindow ad if requestPersist then @@ -106,8 +107,9 @@ invalidateDrawRequest -> Affection us () invalidateDrawRequest pixels format stride cpp dr@DrawRequest{..} = do ad <- get + let !surf = drawSurface ad liftIO $ clearArea requestBuffer requestArea - liftIO $ SDL.lockSurface $ drawSurface ad + liftIO $ SDL.lockSurface surf liftIO $ G.gegl_node_blit requestNode 1 @@ -115,9 +117,9 @@ invalidateDrawRequest pixels format stride cpp dr@DrawRequest{..} = do format (pixels `plusPtr` (rectangleX requestArea * cpp + rectangleY requestArea * stride)) - stride + 0 [G.GeglBlitDefault] - liftIO $ SDL.unlockSurface $ drawSurface ad + liftIO $ SDL.unlockSurface surf liftIO $ SDL.updateWindowSurface $ drawWindow ad -- | compute color for a single pixel diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 1acea04..1d4e900 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -1,32 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} + -- | This module introduces a simple particle system to Affection module Affection.Particle - ( updateParticles + ( updateParticle , drawParticles + , updateParticleSystem ) where import Affection.Types +import Data.Maybe (catMaybes) + +import qualified GEGL as G + -- This function updates particles through a specified function. Particle ageing -- and death is being handled by 'updateParticles' itself and does not need to -- bother you. -updateParticles +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] -- ^ List of 'Particle's to be processed - -> [Particle] -- ^ resulting list of particles -updateParticles _ _ [] = [] -updateParticles time funct (p:ps) = - if particleLife p - time < 0 + -> Particle -- ^ 'Particle' to be processed + -> Maybe Particle -- ^ resulting 'Particle' +updateParticle time funct p@Particle{..} = + if particleLife - time < 0 then - updateParticles time funct ps + Nothing else - (funct time $ p { particleLife = particleLife p - time }) : - updateparticles time funct ps + Just $ funct time $ p { particleLife = particleLife - time } drawParticles :: (Particle -> Affection us ()) -> [Particle] -> Affection us () drawParticles = mapM_ + +updateParticleSystem + :: ParticleSystem + -> Double + -> (Double -> Particle -> Particle) + -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ()) + -> Affection us ParticleSystem +updateParticleSystem sys sec upd draw = do + let x = catMaybes $ map (updateParticle sec upd) (psParts sys) + mapM_ (draw (psBuffer sys) (psNode sys)) x + return $ sys + { psParts = x } diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 20bf577..93cd960 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -15,6 +15,7 @@ module Affection.Types , DrawRequest(..) -- | Particle system , Particle(..) + , ParticleSystem(..) -- | Convenience exports , liftIO , SDL.WindowConfig(..) @@ -127,8 +128,14 @@ data DrawType -- | A single particle data Particle = Particle - { particleLife :: Double -- ^ Time to live in seconds - , particlePosition :: (Int, Int) -- ^ Position of particle on canvas - , particleRotation :: Double -- ^ Particle rotation - , particleVelocity :: (Int, Int) -- ^ particle velocity as vector of pixels per second + { particleLife :: Double -- ^ Time to live in seconds + , particlePosition :: (Double, Double) -- ^ Position of particle on canvas + , particleRotation :: Double -- ^ Particle rotation + , particleVelocity :: (Int, Int) -- ^ particle velocity as vector of pixels per second } deriving (Show, Eq) + +data ParticleSystem = ParticleSystem + { psParts :: [Particle] + , psNode :: G.GeglNode + , psBuffer :: G.GeglBuffer + }