diff --git a/affection.cabal b/affection.cabal index 92511b4..9c73464 100644 --- a/affection.cabal +++ b/affection.cabal @@ -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 diff --git a/examples/example02.hs b/examples/example02.hs index 7b62eb0..dcd0142 100644 --- a/examples/example02.hs +++ b/examples/example02.hs @@ -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 diff --git a/examples/example03.hs b/examples/example03.hs index 7fd540e..d565b55 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -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 - [ G.Property "buffer" $ G.PropertyBuffer buffer + 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 diff --git a/src/Affection.hs b/src/Affection.hs index e2670e6..316f4db 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -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) diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 9df3acf..1a3ab75 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -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,11 +139,11 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do G.GeglAbyssNone liftIO $ SDL.unlockSurface surf -- liftIO $ SDL.updateWindowSurface $ drawWindow ad - if requestPersist - then - return Nothing - else - return $ Just dr + case requestPersist of + Yes -> + return Nothing + Kill _ -> + return $ Just dr -- | clear a previously drawn area invalidateDrawRequest @@ -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 diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 1d4e900..884bc6f 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -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 } diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 6a61f98..c02e889 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -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 @@ -159,17 +165,25 @@ instance Eq Angle where -- | A single particle data Particle = Particle - { particleLife :: Double + { particleLife :: Double -- ^ Time to live in seconds - , particlePosition :: (Double, Double) + , particlePosition :: (Double, Double) -- ^ Position of particle on canvas - , particleRotation :: Angle + , particleRotation :: Angle -- ^ Particle rotation - , particleVelocity :: (Int, Int) + , particleVelocity :: (Int, Int) -- ^ particle velocity as vector of pixels per second - , particlePitchRate :: Angle + , 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]