new: particle system and an example for that

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

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)

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

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

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 }

src/Affection/Types.hs

@@ -15,6 +15,7 @@ module Affection.Types
   , DrawRequest(..)
     -- | Particle system
   , Particle(..)
+  , ParticleSystem(..)
     -- | Convenience exports
   , liftIO
   , SDL.WindowConfig(..)
@@ -128,7 +129,13 @@ data DrawType
 -- | A single particle
 data Particle = Particle
   { particleLife     :: Double           -- ^ Time to live in seconds
-  , particlePosition :: (Int, Int) -- ^ Position of particle on canvas
+  , 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
+  }