particle system now works as a cascade of nodes

This commit is contained in:
nek0 2016-12-23 14:18:39 +01:00
parent 95c008cc4e
commit 388c141e23
7 changed files with 173 additions and 104 deletions

View file

@ -59,7 +59,9 @@ library
, gegl
, babl
, monad-loops
, containers
, clock
, glib
-- , sdl2-image
executable example00
@ -79,22 +81,22 @@ executable example00
else
buildable: False
executable example01
hs-source-dirs: examples
main-is: example01.hs
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
build-depends: base
, affection
, sdl2
, gegl
, babl
, containers
, mtl
else
buildable: False
-- executable example01
-- hs-source-dirs: examples
-- main-is: example01.hs
-- ghc-options: -threaded -Wall
-- default-language: Haskell2010
-- default-extensions: OverloadedStrings
-- if flag(examples)
-- build-depends: base
-- , affection
-- , sdl2
-- , gegl
-- , babl
-- , containers
-- , mtl
-- else
-- buildable: False
executable example02
hs-source-dirs: examples

View file

@ -48,13 +48,17 @@ load _ = do
buffer@(G.GeglBuffer b) <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufPtr <- new b
sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink"
[ G.Property "buffer" $ G.PropertyPointer $ castPtr bufPtr
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
[ G.Property "buffer" $ G.PropertyBuffer buffer
]
traceM "buffer-sink"
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
traceM "nop"
G.gegl_node_link_many [checkerboard, over, sink]
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
[ G.Property "width" $ G.PropertyDouble 800
, G.Property "height" $ G.PropertyDouble 600
]
G.gegl_node_link_many [checkerboard, over, crop, sink]
G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
@ -63,6 +67,7 @@ load _ = do
, ("background" , checkerboard)
, ("sink" , sink)
, ("nop" , nop)
, ("crop" , crop)
]
traceM "loading complete"
return $ UserData
@ -92,6 +97,7 @@ draw = do
(G.GeglRectangle (x - 10) (y - 10) 20 20)
foreground
) coordinates
liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do

View file

@ -29,7 +29,6 @@ main = do
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, foreground :: G.GeglBuffer
, coordinates :: Maybe (Int, Int)
, partsys :: ParticleSystem
}
@ -45,37 +44,47 @@ load _ = do
traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
buffer@(G.GeglBuffer b) <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
[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 "buffer-sink"
nop <- G.gegl_node_new_child root $ G.Operation "nop" []
traceM "nop"
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
[ G.Property "width" $ G.PropertyDouble 800
, G.Property "height" $ G.PropertyDouble 600
]
traceM "crop"
G.gegl_node_link_many [checkerboard, over, crop, sink]
G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , checkerboard)
, ("foreground" , bufsrc)
, ("sink" , sink)
, ("nop" , nop)
, ("crop" , crop)
]
traceM "loading complete"
return $ UserData
{ nodeGraph = myMap
, foreground = buffer
, coordinates = Nothing
, partsys = ParticleSystem [] over buffer
, partsys = ParticleSystem [] nop buffer
}
drawInit :: Affection UserData ()
drawInit = do
UserData{..} <- getAffection
present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
drawInit = return ()
-- UserData{..} <- getAffection
-- present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
draw :: Affection UserData ()
draw = do
traceM "drawing"
UserData{..} <- getAffection
liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
-- ad <- get
-- ud <- getAffection
-- drawParticles partDraw $ particles ud
@ -109,17 +118,30 @@ update sec = do
vx <- liftIO $ randomRIO (-20, 20)
vy <- liftIO $ randomRIO (-20, 20)
life <- liftIO $ randomRIO (1, 5)
tempRoot <- liftIO $ G.gegl_node_new
tempOver <- liftIO $ G.gegl_node_new_child tempRoot
G.defaultOverOperation
tempNop <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation
"gegl:nop" []
liftIO $ G.gegl_node_connect_to tempNop "output" tempOver "aux"
-- traceM $ "position is: " ++ show x ++ " " ++ show y
-- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
putAffection $ ud
{ coordinates = Just (fromIntegral x, fromIntegral y)
, partsys = (partsys ud)
{ partsys = (partsys ud)
{ psParts = (Particle
{ particleLife = life
, particlePosition = (fromIntegral x, fromIntegral y)
, particleRotation = Rad 0
, particleVelocity = (vx, vy)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("nop" , tempNop)
]
, particleStackCont = tempOver
, particleDrawFlange = tempNop
}) : (psParts $ partsys ud)
}
}
@ -144,7 +166,6 @@ partUpd :: Double -> Particle -> Particle
partUpd sec p@Particle{..} =
p
{ particlePosition = (newX, newY)
, particleLife = particleLife - sec
}
where
newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
@ -153,9 +174,9 @@ partUpd sec p@Particle{..} =
partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData ()
partDraw buf node Particle{..} = do
ud <- getAffection
drawRect
buf
node
drawRect'
particleDrawFlange
(G.RGBA 1 0 0 0.5)
(Line 5)
(Fill)
(G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
buf

View file

@ -83,11 +83,11 @@ withAffection AffectionConfig{..} = do
mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
put $ ad
{ drawStack = [] }
-- execute user defined draw loop
drawLoop
-- execute user defined update loop
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
(fromIntegral 10 ^ 9)
-- execute user defined draw loop
drawLoop
-- handle all new draw requests
ad2 <- get
clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2)

View file

@ -2,8 +2,9 @@
-- | Module for drawing primitives
module Affection.Draw
( drawRect
, drawRect'
(
-- drawRect
drawRect'
-- , clear
, handleDrawRequest
, invalidateDrawRequest
@ -13,12 +14,14 @@ module Affection.Draw
import Affection.Types
import Foreign.Ptr (Ptr, plusPtr, nullPtr)
import Foreign
import Foreign.C.Types
import Control.Monad.State (get, put)
import Control.Monad (when, unless)
import System.Glib.GObject
import qualified SDL
import qualified BABL as B
@ -28,43 +31,43 @@ import qualified GEGL as G
import Debug.Trace
-- | Draw a rectangle on target buffer
drawRect
:: G.GeglBuffer -- ^ Target buffer
-> G.GeglNode -- ^ Target node
-> G.Color -- ^ Color to draw in
-> DrawType -- ^ Draw type
-> GeglRectangle -- ^ Dimensions of Rectangle
-> Affection us ()
drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
(\(x, y) ->
let col = unsafeColorize color
in
G.Pixel x y col
)
ad@AffectionData{..} <- get
put $ ad
{ drawStack = (DrawRequest rect buf False) : drawStack
}
drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do
liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
(\(x, y) ->
let col = unsafeColorize color
in if not ((x >= rectangleX + size && x < rectangleX + rectangleWidth - size) &&
(y >= rectangleY + size && y < rectangleY + rectangleHeight - size))
then
G.Pixel x y col
else
G.Pixel x y $ unsafeColorize $ G.RGBA 0 0 0 0
)
ad@AffectionData{..} <- get
put $ ad
{ drawStack = (DrawRequest rect buf False) : drawStack
}
-- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY rectangleWidth size)
-- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight)
-- drawRect buf node color Fill (G.GeglRectangle (rectangleX + rectangleWidth - size) rectangleY size rectangleHeight)
-- drawRect buf node color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
-- drawRect
-- :: G.GeglBuffer -- ^ Target buffer
-- -> G.GeglNode -- ^ Target node
-- -> G.Color -- ^ Color to draw in
-- -> DrawType -- ^ Draw type
-- -> GeglRectangle -- ^ Dimensions of Rectangle
-- -> Affection us ()
-- drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
-- liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
-- (\(x, y) ->
-- let col = unsafeColorize color
-- in
-- G.Pixel x y col
-- )
-- ad@AffectionData{..} <- get
-- put $ ad
-- { drawStack = (DrawRequest rect buf False) : drawStack
-- }
-- drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do
-- liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
-- (\(x, y) ->
-- let col = unsafeColorize color
-- in if not ((x >= rectangleX + size && x < rectangleX + rectangleWidth - size) &&
-- (y >= rectangleY + size && y < rectangleY + rectangleHeight - size))
-- then
-- G.Pixel x y col
-- else
-- G.Pixel x y $ unsafeColorize $ G.RGBA 0 0 0 0
-- )
-- ad@AffectionData{..} <- get
-- put $ ad
-- { drawStack = (DrawRequest rect buf False) : drawStack
-- }
-- -- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY rectangleWidth size)
-- -- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight)
-- -- drawRect buf node color Fill (G.GeglRectangle (rectangleX + rectangleWidth - size) rectangleY size rectangleHeight)
-- -- drawRect buf node color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
drawRect'
:: G.GeglNode -- ^ Target Node
@ -75,7 +78,8 @@ drawRect'
-> Affection us ()
drawRect' node color Fill rect@GeglRectangle{..} buf = do
ad <- get
opNode <- liftIO $ G.gegl_node_new_child node $ G.Operation "gegl:rectangle"
tempRoot <- liftIO $ G.gegl_node_new
opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle"
[ G.Property "x" $ G.PropertyDouble $ fromIntegral rectangleX
, G.Property "y" $ G.PropertyDouble $ fromIntegral rectangleY
, G.Property "width" $ G.PropertyDouble $ fromIntegral rectangleWidth
@ -85,7 +89,7 @@ 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 False) : drawStack ad
{ drawStack = (DrawRequest rect buf (Kill tempRoot)) : drawStack ad
}
-- -- | force a blit of a specified area. Do not use often as it slows down the program
@ -135,10 +139,10 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad
if requestPersist
then
case requestPersist of
Yes ->
return Nothing
else
Kill _ ->
return $ Just dr
-- | clear a previously drawn area
@ -151,7 +155,7 @@ invalidateDrawRequest
-> Affection us ()
invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
ad <- get
let !surf = drawSurface ad
let surf = drawSurface ad
liftIO $ clearArea requestBuffer requestArea
liftIO $ SDL.lockSurface surf
liftIO $ G.gegl_buffer_get
@ -164,6 +168,8 @@ invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
stride
G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf
let Kill victim = requestPersist
liftIO $ G.gegl_node_drop victim
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad
-- | compute color for a single pixel

View file

@ -9,7 +9,9 @@ module Affection.Particle
import Affection.Types
import Data.Maybe (catMaybes)
import Control.Monad
import Data.Maybe
import qualified GEGL as G
@ -22,13 +24,28 @@ updateParticle
-- This Function should take the elapsed time
-- in seconds and the initial particle as arguments.
-> Particle -- ^ 'Particle' to be processed
-> Maybe Particle -- ^ resulting 'Particle'
updateParticle time funct p@Particle{..} =
if particleLife - time < 0
then
Nothing
-> IO (Maybe Particle) -- ^ resulting 'Particle'
updateParticle time funct pa =
if particleLife pa - time < 0
then do
G.gegl_node_drop $ particleRootNode pa
return $ Nothing
else
Just $ funct time $ p { particleLife = particleLife - time }
return $ Just $ funct time $ pa { particleLife = particleLife pa - time }
-- updateParticle time funct acc@[p] pa =
-- if particleLife pa - time < 0
-- then do
-- G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else
-- return $ (Just $ funct time $ pa { particleLife = particleLife pa - time }) : acc
-- updateParticle time funct acc@(p:ps) pa =
-- if particleLife pa - time < 0
-- then do
-- G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else
-- return $ (Just $ funct time $ pa { particleLife = particleLife pa - time }) : acc
drawParticles
:: (Particle -> Affection us ())
@ -43,7 +60,10 @@ updateParticleSystem
-> (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)
-- 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)
liftIO $ G.gegl_node_link_many $ map particleStackCont x ++ [psNode sys]
mapM_ (draw (psBuffer sys) (psNode sys)) x
return $ sys
{ psParts = x }

View file

@ -13,6 +13,7 @@ module Affection.Types
, RGBA(..)
, DrawType(..)
, DrawRequest(..)
, RequestPersist(..)
, Angle(..)
, ConvertAngle(..)
-- | Particle system
@ -30,6 +31,7 @@ module Affection.Types
import qualified SDL.Init as SDL
import qualified SDL.Video as SDL
import qualified Data.Text as T
import Data.Map
import qualified GEGL as G
import qualified BABL as B
@ -81,9 +83,13 @@ data AffectionData us = AffectionData
data DrawRequest = DrawRequest
{ requestArea :: G.GeglRectangle -- ^ The area to update
, requestBuffer :: G.GeglBuffer -- ^ Buffer to draw
, requestPersist :: Bool -- ^ Shall the drawRequest persist
, requestPersist :: RequestPersist -- ^ Shall the drawRequest persist
}
data RequestPersist
= Yes
| Kill G.GeglNode
-- | A type for storing 'DrawRequest' results to be executed frequently. TODO
data DrawAsset = DrawAsset
@ -169,7 +175,15 @@ data Particle = Particle
-- ^ particle velocity as vector of pixels per second
, particlePitchRate :: Angle
-- ^ Rotational velocity of particle in angle per second
} deriving (Show, Eq)
, particleRootNode :: G.GeglNode
-- ^ Root 'G.GeglNode' of 'Particle'
, particleNodeGraph :: Map String G.GeglNode
-- ^ Node Graph of 'G.GeglNodes' per particle
, particleStackCont :: G.GeglNode
-- ^ 'G.GeglNode' to connect other 'Particle's to
, particleDrawFlange :: G.GeglNode
-- ^ 'G.GeglNode' to connect draw actions to
}
data ParticleSystem = ParticleSystem
{ psParts :: [Particle]