From f468fdaaf53fbda2e6649470858363cb3c226550 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 21 Dec 2016 04:28:57 +0100 Subject: [PATCH 01/15] *vomiting sounds* --- affection.cabal | 18 ++++++++ examples/example01.hs | 2 +- examples/example02.hs | 39 ++++++++++------- examples/example03.hs | 2 +- src/Affection.hs | 5 ++- src/Affection/Draw.hs | 99 +++++++++++++++++++++++++----------------- src/Affection/Types.hs | 17 +++++--- 7 files changed, 117 insertions(+), 65 deletions(-) diff --git a/affection.cabal b/affection.cabal index cf25000..92511b4 100644 --- a/affection.cabal +++ b/affection.cabal @@ -130,3 +130,21 @@ executable example03 , random else buildable: False + +executable example04 + hs-source-dirs: examples + main-is: example04.hs + ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts + 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/example01.hs b/examples/example01.hs index a3358ae..bb61e2b 100644 --- a/examples/example01.hs +++ b/examples/example01.hs @@ -52,7 +52,7 @@ load _ = do traceM "checkerboard" over <- G.gegl_node_new_child root G.defaultOverOperation traceM "over" - buffer <- G.gegl_buffer_new (G.GeglRectangle 0 0 800 600) =<< + buffer <- 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 diff --git a/examples/example02.hs b/examples/example02.hs index 72cc6eb..7b62eb0 100644 --- a/examples/example02.hs +++ b/examples/example02.hs @@ -3,10 +3,13 @@ import Affection import qualified SDL import qualified GEGL as G +import qualified GEGL.FFI.Buffer as G import qualified BABL as B import qualified Data.Map.Strict as M import Foreign.C.Types +import Foreign.Marshal.Utils (new) +import Foreign.Ptr (castPtr) import Debug.Trace @@ -16,7 +19,7 @@ main = do { initComponents = All , windowTitle = "Affection: example00" , windowConfig = SDL.defaultWindow - , preLoop = drawInit + , preLoop = return () , drawLoop = draw , updateLoop = update , loadState = load @@ -42,20 +45,24 @@ load _ = do traceM "checkerboard" over <- G.gegl_node_new_child root G.defaultOverOperation traceM "over" - buffer <- G.gegl_buffer_new (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 + bufPtr <- new b + sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink" + [ G.Property "buffer" $ G.PropertyPointer $ castPtr bufPtr ] - 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 "gegl:nop" [] + traceM "nop" + G.gegl_node_link_many [checkerboard, over, 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) ] traceM "loading complete" return $ UserData @@ -64,10 +71,10 @@ load _ = do , coordinates = Nothing } -drawInit :: Affection UserData () -drawInit = do - UserData{..} <- getAffection - present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True +-- drawInit :: Affection UserData () +-- drawInit = do +-- UserData{..} <- getAffection +-- present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True draw :: Affection UserData () draw = do @@ -78,12 +85,12 @@ draw = do let (w, h) = (fromIntegral rw, fromIntegral rh) liftIO $ clearArea foreground (GeglRectangle 0 0 w h) maybe (return ()) (\(x, y) -> - drawRect - foreground - (nodeGraph M.! "over") + drawRect' + (nodeGraph M.! "nop") (G.RGBA 1 0 0 0.5) - (Line 7) + (Fill) (G.GeglRectangle (x - 10) (y - 10) 20 20) + foreground ) coordinates update :: Double -> AffectionState (AffectionData UserData) IO () diff --git a/examples/example03.hs b/examples/example03.hs index 7b579d4..7fd540e 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -45,7 +45,7 @@ load _ = do traceM "checkerboard" over <- G.gegl_node_new_child root G.defaultOverOperation traceM "over" - buffer <- G.gegl_buffer_new (G.GeglRectangle 0 0 800 600) =<< + buffer <- 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 diff --git a/src/Affection.hs b/src/Affection.hs index 460cc63..e2670e6 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -63,6 +63,7 @@ withAffection AffectionConfig{..} = do , userState = x , drawWindow = window , drawSurface = surface + , drawFormat = format , drawStack = [] }) <$> loadState surface (_, nState) <- runStateT ( A.runState $ do @@ -79,7 +80,7 @@ withAffection AffectionConfig{..} = do -- get state ad <- get -- clean draw requests from last run - mapM_ (invalidateDrawRequest pixels format stride cpp) $ drawStack ad + mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad put $ ad { drawStack = [] } -- execute user defined draw loop @@ -89,7 +90,7 @@ withAffection AffectionConfig{..} = do (fromIntegral 10 ^ 9) -- handle all new draw requests ad2 <- get - clear <- catMaybes <$> mapM (handleDrawRequest pixels format stride cpp) (drawStack ad2) + clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2) -- save all draw requests to clear in next run put $ ad2 { drawStack = clear } diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 6237c83..9df3acf 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -3,10 +3,11 @@ -- | Module for drawing primitives module Affection.Draw ( drawRect + , drawRect' -- , clear , handleDrawRequest , invalidateDrawRequest - , present + -- , present , clearArea ) where @@ -16,7 +17,7 @@ import Foreign.Ptr (Ptr, plusPtr, nullPtr) import Foreign.C.Types import Control.Monad.State (get, put) -import Control.Monad (when) +import Control.Monad (when, unless) import qualified SDL @@ -43,7 +44,7 @@ drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do ) ad@AffectionData{..} <- get put $ ad - { drawStack = (DrawRequest node rect buf False) : drawStack + { 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 $ @@ -58,60 +59,80 @@ drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do ) ad@AffectionData{..} <- get put $ ad - { drawStack = (DrawRequest node rect buf False) : drawStack + { 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) --- | force a blit of a specified area. Do not use often as it slows down the program -present - :: G.GeglNode -- ^ Node to blit - -> G.GeglBuffer -- ^ BUffer to draw - -> G.GeglRectangle -- ^ Area to blit - -> Bool -- ^ Shall the drawing be cleared in the next run? +drawRect' + :: G.GeglNode -- ^ Target Node + -> G.Color -- ^ Color to draw in + -> DrawType -- ^ Draw type + -> G.GeglRectangle -- ^ Dimensions of Rectangle + -> G.GeglBuffer -- ^ Final Buffer -> Affection us () -present node buf rect pers = do +drawRect' node color Fill rect@GeglRectangle{..} buf = do ad <- get + opNode <- liftIO $ G.gegl_node_new_child node $ 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 + , G.Property "height" $ G.PropertyDouble $ fromIntegral rectangleHeight + , G.Property "color" $ G.PropertyColor color + ] + diw <- liftIO $ G.gegl_node_connect_to opNode "output" node "input" + unless diw $ error "Affection.Draw.drawRect': connect failed" put $ ad - { drawStack = (DrawRequest node rect buf pers) : drawStack ad + { drawStack = (DrawRequest rect buf False) : drawStack ad } - ad <- get - format <- liftIO $ B.babl_format $ B.PixelFormat B.RGBA B.CFu8 - liftIO $ SDL.lockSurface $ drawSurface ad - liftIO $ G.gegl_node_blit - node - 1 - rect - format - nullPtr - 0 - [G.GeglBlitDefault] - liftIO $ SDL.unlockSurface $ drawSurface ad - liftIO $ SDL.updateWindowSurface $ drawWindow ad + +-- -- | force a blit of a specified area. Do not use often as it slows down the program +-- present +-- :: G.GeglNode -- ^ Node to blit +-- -> G.GeglBuffer -- ^ BUffer to draw +-- -> G.GeglRectangle -- ^ Area to blit +-- -> Bool -- ^ Shall the drawing be cleared in the next run? +-- -> Affection us () +-- present node buf rect pers = do +-- ad <- get +-- put $ ad +-- { drawStack = (DrawRequest rect buf pers) : drawStack ad +-- } +-- ad <- get +-- format <- liftIO $ B.babl_format $ B.PixelFormat B.RGBA B.CFu8 +-- liftIO $ SDL.lockSurface $ drawSurface ad +-- liftIO $ G.gegl_node_blit +-- rect +-- format +-- nullPtr +-- 0 +-- [G.GeglBlitDefault] +-- liftIO $ SDL.unlockSurface $ drawSurface ad +-- liftIO $ SDL.updateWindowSurface $ drawWindow ad -- | function for handling 'DrawRequest's and updating the output handleDrawRequest :: Ptr a -- ^ Pixel buffer to blit to - -> B.BablFormatPtr -- ^ format to blit in + -- -> B.BablFormatPtr -- ^ format to blit in -> Int -- ^ Stride -> Int -- ^ Components per Pixel -> DrawRequest -- ^ 'DrawRequest' to handle -> Affection us (Maybe DrawRequest) -handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do +handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do ad <- get let surf = drawSurface ad liftIO $ SDL.lockSurface surf - liftIO $ G.gegl_node_blit - requestNode + liftIO $ G.gegl_buffer_get + requestBuffer + (Just requestArea) 1 - requestArea - format + (Just $ drawFormat ad) (pixels `plusPtr` (rectangleX requestArea * cpp + rectangleY requestArea * stride)) stride - [G.GeglBlitDefault] + G.GeglAbyssNone liftIO $ SDL.unlockSurface surf -- liftIO $ SDL.updateWindowSurface $ drawWindow ad if requestPersist @@ -123,25 +144,25 @@ handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do -- | clear a previously drawn area invalidateDrawRequest :: Ptr a -- ^ Pixel buffer to blit to - -> B.BablFormatPtr -- ^ format to blit in + -- -> B.BablFormatPtr -- ^ format to blit in -> Int -- ^ Stride -> Int -- ^ Components per Pixel -> DrawRequest -- ^ Drawrequest to invalidate -> Affection us () -invalidateDrawRequest pixels format stride cpp dr@DrawRequest{..} = do +invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do ad <- get let !surf = drawSurface ad liftIO $ clearArea requestBuffer requestArea liftIO $ SDL.lockSurface surf - liftIO $ G.gegl_node_blit - requestNode + liftIO $ G.gegl_buffer_get + requestBuffer + (Just requestArea) 1 - requestArea - format + (Just $ drawFormat ad) (pixels `plusPtr` (rectangleX requestArea * cpp + rectangleY requestArea * stride)) stride - [G.GeglBlitDefault] + G.GeglAbyssNone liftIO $ SDL.unlockSurface surf -- liftIO $ SDL.updateWindowSurface $ drawWindow ad diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index bca87d0..6a61f98 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -30,7 +30,9 @@ module Affection.Types import qualified SDL.Init as SDL import qualified SDL.Video as SDL import qualified Data.Text as T + import qualified GEGL as G +import qualified BABL as B import Control.Monad.IO.Class import Control.Monad.State @@ -58,6 +60,11 @@ data AffectionConfig us = AffectionConfig -- ^ Provide your own finisher function to clean your data. } +-- | Components to initialize in SDL. +data InitComponents + = All + | Only [SDL.InitFlag] + -- | Main type for defining the look, feel and action of the whole application. data AffectionData us = AffectionData -- { affectionConfig :: AffectionConfig us -- ^ Application configuration. @@ -65,22 +72,20 @@ data AffectionData us = AffectionData , userState :: us -- ^ State data provided by user , drawWindow :: SDL.Window -- ^ SDL window , drawSurface :: SDL.Surface -- ^ SDL surface + , drawFormat :: B.BablFormatPtr -- ^ Target format , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated } -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated data DrawRequest = DrawRequest - { requestNode :: G.GeglNode -- ^ The 'G.GeglNode' to blit - , requestArea :: G.GeglRectangle -- ^ The area to update + { requestArea :: G.GeglRectangle -- ^ The area to update , requestBuffer :: G.GeglBuffer -- ^ Buffer to draw , requestPersist :: Bool -- ^ Shall the drawRequest persist } --- | Components to initialize in SDL. -data InitComponents - = All - | Only [SDL.InitFlag] +-- | A type for storing 'DrawRequest' results to be executed frequently. TODO +data DrawAsset = DrawAsset -- | Inner 'StateT' monad for the update state -- type AffectionStateInner us m a = StateT (AffectionData us) m a From 95c008cc4edac2a369f0e952b6284c84b3857216 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 21 Dec 2016 04:33:28 +0100 Subject: [PATCH 02/15] new example --- examples/example04.hs | 120 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 120 insertions(+) create mode 100644 examples/example04.hs diff --git a/examples/example04.hs b/examples/example04.hs new file mode 100644 index 0000000..a720487 --- /dev/null +++ b/examples/example04.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE RecordWildCards #-} + +import Affection +import qualified SDL +import qualified GEGL as G +import qualified BABL as B +import qualified BABL.FFI.Format as B +import qualified Data.Map.Strict as M + +import Foreign.C.Types +import Foreign.Ptr (castPtr, nullPtr) +import Foreign.Marshal.Utils (new) + +import System.Random (randomRIO) + +import Control.Monad (unless) + +import Debug.Trace + +main :: IO () +main = do + conf <- return $ AffectionConfig + { initComponents = All + , windowTitle = "Affection: example00" + , windowConfig = SDL.defaultWindow + , preLoop = return () + , drawLoop = draw + , updateLoop = update + , loadState = load + , cleanUp = clean + } + withAffection conf + +data UserData = UserData + { nodeGraph :: M.Map String G.GeglNode + , coordinates :: Maybe (Int, Int) + } + +load :: SDL.Surface -> IO UserData +load surface = 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" + nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] + traceM "nop" + crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" + [ G.Property "x" $ G.PropertyDouble 0 + , G.Property "y" $ G.PropertyDouble 0 + , G.Property "width" $ G.PropertyDouble 800 + , G.Property "height" $ G.PropertyDouble 600 + ] + traceM "crop" + format <- B.babl_format $ B.PixelFormat B.RGBA B.CFu8 + pixels <- liftIO $ new =<< SDL.surfacePixels surface + sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink" + [ G.Property "buffer" $ G.PropertyPointer $ castPtr $ pixels + , G.Property "format" $ G.PropertyPointer $ nullPtr + ] + traceM "sink" + G.gegl_node_link_many [checkerboard, over, crop, sink] + diw <- G.gegl_node_connect_to nop "output" over "aux" + unless diw (error "connect failed") + traceM "connections made" + myMap <- return $ M.fromList + [ ("root" , root) + , ("over" , over) + , ("background" , checkerboard) + , ("nop" , nop) + , ("crop" , crop) + , ("sink" , sink) + ] + traceM "loading complete" + return $ UserData + { nodeGraph = myMap + , coordinates = Nothing + } + +update :: Double -> AffectionState (AffectionData UserData) IO () +update sec = do + traceM "updating" + ad <- get + ud <- getAffection + traceM $ (show $ 1 / sec) ++ " FPS" + ev <- liftIO $ SDL.pollEvents + mapM_ (\e -> + case SDL.eventPayload e of + SDL.MouseButtonEvent dat -> do + let (SDL.P (SDL.V2 x y)) = SDL.mouseButtonEventPos dat + drawRect + (nodeGraph ud M.! "nop") + (G.RGBA 1 0 0 0.5) + Fill + (G.GeglRectangle (fromIntegral x - 10) (fromIntegral y - 10) 20 20) + traceM $ "drewn a rectangle at " ++ show x ++ " " ++ show y + SDL.WindowClosedEvent _ -> do + traceM "seeya!" + put $ ad + { quitEvent = True + } + _ -> + return () + ) ev + +draw :: Affection UserData () +draw = do + ad <- get + ud <- getAffection + liftIO $ SDL.lockSurface $ drawSurface ad + liftIO $ G.gegl_node_process (nodeGraph ud M.! "sink") + liftIO $ SDL.unlockSurface $ drawSurface ad + +clean :: UserData -> IO () +clean _ = return () From 388c141e232ab8c3fa504c5c8148b92447a8672f Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 23 Dec 2016 14:18:39 +0100 Subject: [PATCH 03/15] particle system now works as a cascade of nodes --- affection.cabal | 34 +++++++------ examples/example02.hs | 12 +++-- examples/example03.hs | 61 +++++++++++++++-------- src/Affection.hs | 4 +- src/Affection/Draw.hs | 102 ++++++++++++++++++++------------------ src/Affection/Particle.hs | 36 +++++++++++--- src/Affection/Types.hs | 28 ++++++++--- 7 files changed, 173 insertions(+), 104 deletions(-) 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] From da79d55a0de7eb3252966bb00a585be54c71ab04 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 01:10:18 +0100 Subject: [PATCH 04/15] make text more visible --- examples/example00.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/example00.hs b/examples/example00.hs index 8046990..84b370d 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -53,7 +53,7 @@ load _ = do traceM "over" text <- G.gegl_node_new_child root $ G.textOperation [ G.Property "string" $ G.PropertyString "Hello world!" - , G.Property "color" $ G.PropertyColor $ G.RGBA 0 0 1 0.1 + , G.Property "color" $ G.PropertyColor $ G.RGBA 0 0 1 0.5 , G.Property "size" $ G.PropertyDouble 40 ] traceM "text" From 158e4ddc800521411ffb785a94b6b8bb8ad0b05e Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 01:11:59 +0100 Subject: [PATCH 05/15] trying to enable initial draw again --- examples/example03.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/examples/example03.hs b/examples/example03.hs index d565b55..3d296b4 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -76,9 +76,9 @@ load _ = do } drawInit :: Affection UserData () -drawInit = return () - -- UserData{..} <- getAffection - -- present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True +drawInit = do + UserData{..} <- getAffection + present (GeglRectangle 0 0 800 600) foreground True draw :: Affection UserData () draw = do From ee1200b597281938c007dc9453746780d2af7b6d Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 01:12:34 +0100 Subject: [PATCH 06/15] random colors --- examples/example03.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/examples/example03.hs b/examples/example03.hs index 3d296b4..da2ed00 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -118,12 +118,21 @@ update sec = do vx <- liftIO $ randomRIO (-20, 20) vy <- liftIO $ randomRIO (-20, 20) life <- liftIO $ randomRIO (1, 5) + r <- liftIO $ randomRIO (0,1) + g <- liftIO $ randomRIO (0,1) + b <- liftIO $ randomRIO (0,1) 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" + tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation + "gegl:rectangle" + [ G.Property "x" $ G.PropertyDouble $ fromIntegral x - 10 + , G.Property "y" $ G.PropertyDouble $ fromIntegral y - 10 + , G.Property "width" $ G.PropertyDouble 20 + , G.Property "height" $ G.PropertyDouble 20 + , G.Property "color" $ G.PropertyColor $ (G.RGBA r g b 0.5) + ] + liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux" -- traceM $ "position is: " ++ show x ++ " " ++ show y -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy putAffection $ ud @@ -138,10 +147,10 @@ update sec = do , particleNodeGraph = M.fromList [ ("root", tempRoot) , ("over", tempOver) - , ("nop" , tempNop) + , ("rect" , tempRect) ] , particleStackCont = tempOver - , particleDrawFlange = tempNop + , particleDrawFlange = tempOver }) : (psParts $ partsys ud) } } From d5bf09919cf3ad7ae37c8b42a3d6f51f5f583be8 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 01:13:00 +0100 Subject: [PATCH 07/15] 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 From a564eed511298b1141804d05c84a5948373a82de Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 08:26:45 +0100 Subject: [PATCH 08/15] enable debugging --- affection.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/affection.cabal b/affection.cabal index 9c73464..1ff5b90 100644 --- a/affection.cabal +++ b/affection.cabal @@ -49,7 +49,7 @@ library , UndecidableInstances hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -debug -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.10 , sdl2 @@ -118,7 +118,7 @@ executable example02 executable example03 hs-source-dirs: examples main-is: example03.hs - ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts + ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts -debug default-language: Haskell2010 default-extensions: OverloadedStrings if flag(examples) From b75f20c3d59945a349cbf2e2cf1bfbc7138fe21a Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 08:27:09 +0100 Subject: [PATCH 09/15] link all new particles --- examples/example03.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/examples/example03.hs b/examples/example03.hs index 02ed06d..a50a4d3 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -4,8 +4,11 @@ import Affection import qualified SDL import qualified GEGL as G import qualified BABL as B + import qualified Data.Map.Strict as M +import Control.Monad (when) + import Foreign.C.Types import System.Random (randomRIO) @@ -154,6 +157,10 @@ update sec = do }) : (psParts $ partsys ud) } } + when (not $ null $ psParts $ partsys ud) $ + liftIO $ G.gegl_node_link + tempOver + (particleStackCont $ head $ psParts $ partsys ud) else return () SDL.WindowClosedEvent _ -> do From c6a37e80f71241ab59f50aeffa81e6e719d7dd5f Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 24 Dec 2016 08:27:47 +0100 Subject: [PATCH 10/15] link only when needed --- src/Affection/Particle.hs | 75 ++++++++++++++++++++++++++++----------- 1 file changed, 54 insertions(+), 21 deletions(-) diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 5a5d45d..c1a53fc 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -15,6 +15,8 @@ import Data.Maybe import qualified GEGL as G +import Debug.Trace + -- 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. @@ -25,31 +27,60 @@ updateParticle -- ^ Update function for a single 'Particle' -- This Function should take the elapsed time -- in seconds and the initial particle as arguments. + -> [Maybe Particle] -> Particle -- ^ 'Particle' to be processed - -> Affection us (Maybe Particle) + -> Affection us [Maybe Particle] -- ^ resulting 'Particle' -updateParticle time funct pa = +updateParticle time funct acc@[] pa = if particleLife pa - time < 0 then do liftIO $ G.gegl_node_drop $ particleRootNode pa - return $ Nothing - else - 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 + return $ Nothing : acc + else do + np <- Just <$> funct time pa { particleLife = particleLife pa - time } + return $ np : acc +updateParticle time funct acc@[p] pa = + if particleLife pa - time < 0 + then do + liftIO $ G.gegl_node_drop $ particleRootNode pa + return $ Nothing : acc + else do + when (not $ isNothing p) $ do + -- liftIO $ traceIO "linking second node in list" + liftIO $ G.gegl_node_link + (particleStackCont pa) + (particleStackCont $ fromJust p) + np <- Just <$> funct time pa { particleLife = particleLife pa - time } + return $ np : acc +updateParticle time funct acc@(p:ps) pa = + if particleLife pa - time < 0 + then do + liftIO $ G.gegl_node_drop $ particleRootNode pa + return $ Nothing : acc + else do + when (isNothing p) $ do + let mnl = nextLiving ps + maybe + (return ()) + (\nl -> do + -- liftIO $ traceIO "linking nth node on list" + liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl)) + mnl + np <- Just <$> funct time pa { particleLife = particleLife pa - time } + return $ np : acc + +-- | Get the next living particle from a list +nextLiving + :: [Maybe Particle] + -> Maybe Particle +nextLiving [] = Nothing +nextLiving acc = case catMaybes acc of + [] -> Nothing + ps -> Just $ head $ ps + -- if isNothing p + -- then nextLiving ps + -- else p drawParticles :: (Particle -> Affection us ()) @@ -66,8 +97,10 @@ updateParticleSystem 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 <- catMaybes <$> mapM (updateParticle sec upd) (psParts sys) - liftIO $ G.gegl_node_link_many $ map particleStackCont x ++ [psNode sys] + x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys) + when (not $ null x) $ do + -- liftIO $ traceIO "linking last node to output" + liftIO $ G.gegl_node_link (particleStackCont $ last x) (psNode sys) mapM_ (draw (psBuffer sys) (psNode sys)) x return $ sys { psParts = x } From 428ab736f82037adf5de7a4e34dda32759f5b159 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 25 Dec 2016 08:14:27 +0100 Subject: [PATCH 11/15] disabling example --- affection.cabal | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/affection.cabal b/affection.cabal index 1ff5b90..76b39b0 100644 --- a/affection.cabal +++ b/affection.cabal @@ -64,22 +64,22 @@ library , glib -- , sdl2-image -executable example00 - hs-source-dirs: examples - main-is: example00.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 example00 +-- hs-source-dirs: examples +-- main-is: example00.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 From 2095bb1924bb5002a42a564f3b731f06d8dc63dd Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 25 Dec 2016 08:14:51 +0100 Subject: [PATCH 12/15] fixed routing --- examples/example03.hs | 45 ++++++------ src/Affection.hs | 10 ++- src/Affection/Particle.hs | 146 +++++++++++++++++++++++++++----------- src/Affection/Types.hs | 19 +++-- 4 files changed, 149 insertions(+), 71 deletions(-) diff --git a/examples/example03.hs b/examples/example03.hs index a50a4d3..53af30b 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -75,7 +75,7 @@ load _ = do return $ UserData { nodeGraph = myMap , foreground = buffer - , partsys = ParticleSystem [] nop buffer + , partsys = ParticleSystem (ParticleStorage Nothing []) nop buffer } drawInit :: Affection UserData () @@ -138,29 +138,30 @@ update sec = do liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux" -- traceM $ "position is: " ++ show x ++ " " ++ show y -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy + ips <- insertParticle (partsys ud) $ + Particle + { particleTimeToLive = life + , particleCreation = elapsedTime ad + , particlePosition = (fromIntegral x, fromIntegral y) + , particleRotation = Rad 0 + , particleVelocity = (vx, vy) + , particlePitchRate = Rad 0 + , particleRootNode = tempRoot + , particleNodeGraph = M.fromList + [ ("root", tempRoot) + , ("over", tempOver) + , ("rect", tempRect) + ] + , particleStackCont = tempOver + , particleDrawFlange = tempOver + } putAffection $ 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) - , ("rect" , tempRect) - ] - , particleStackCont = tempOver - , particleDrawFlange = tempOver - }) : (psParts $ partsys ud) - } + { partsys = ips } - when (not $ null $ psParts $ partsys ud) $ - liftIO $ G.gegl_node_link - tempOver - (particleStackCont $ head $ psParts $ partsys ud) + -- when (not $ null $ psParts $ partsys ud) $ + -- liftIO $ G.gegl_node_link + -- tempOver + -- (particleStackCont $ head $ psParts $ partsys ud) else return () SDL.WindowClosedEvent _ -> do diff --git a/src/Affection.hs b/src/Affection.hs index 316f4db..343e16e 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -65,6 +65,7 @@ withAffection AffectionConfig{..} = do , drawSurface = surface , drawFormat = format , drawStack = [] + , elapsedTime = 0 }) <$> loadState surface (_, nState) <- runStateT ( A.runState $ do preLoop @@ -81,11 +82,14 @@ withAffection AffectionConfig{..} = do ad <- get -- clean draw requests from last run mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad + -- compute dt and update elapsedTime + let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9) put $ ad - { drawStack = [] } + { drawStack = [] + , elapsedTime = elapsedTime ad + dt + } -- execute user defined update loop - updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / - (fromIntegral 10 ^ 9) + updateLoop dt -- execute user defined draw loop drawLoop -- handle all new draw requests diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index c1a53fc..311048f 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -5,11 +5,13 @@ module Affection.Particle ( updateParticle , drawParticles , updateParticleSystem + , insertParticle ) where import Affection.Types import Control.Monad +import Control.Monad.State (get) import Data.Maybe @@ -27,48 +29,67 @@ updateParticle -- ^ Update function for a single 'Particle' -- This Function should take the elapsed time -- in seconds and the initial particle as arguments. - -> [Maybe Particle] + -- -> [Maybe Particle] -> Particle -- ^ 'Particle' to be processed - -> Affection us [Maybe Particle] + -- -> Affection us [Maybe Particle] + -> Affection us (Maybe Particle) -- ^ resulting 'Particle' -updateParticle time funct acc@[] pa = - if particleLife pa - time < 0 +updateParticle time funct pa = do + now <- elapsedTime <$> get + if particleCreation pa + particleTimeToLive pa < now then do + mproducer <- liftIO $ G.gegl_node_get_producer + (particleStackCont pa) + "input" + case mproducer of + Just (producer, padname) -> do + consumers <- liftIO $ G.gegl_node_get_consumers + (particleStackCont pa) + "output" + liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to + producer + padname + node + inpad + ) consumers + Nothing -> return () liftIO $ G.gegl_node_drop $ particleRootNode pa - return $ Nothing : acc + return $ Nothing else do - np <- Just <$> funct time pa { particleLife = particleLife pa - time } - return $ np : acc -updateParticle time funct acc@[p] pa = - if particleLife pa - time < 0 - then do - liftIO $ G.gegl_node_drop $ particleRootNode pa - return $ Nothing : acc - else do - when (not $ isNothing p) $ do - -- liftIO $ traceIO "linking second node in list" - liftIO $ G.gegl_node_link - (particleStackCont pa) - (particleStackCont $ fromJust p) - np <- Just <$> funct time pa { particleLife = particleLife pa - time } - return $ np : acc -updateParticle time funct acc@(p:ps) pa = - if particleLife pa - time < 0 - then do - liftIO $ G.gegl_node_drop $ particleRootNode pa - return $ Nothing : acc - else do - when (isNothing p) $ do - let mnl = nextLiving ps - maybe - (return ()) - (\nl -> do - -- liftIO $ traceIO "linking nth node on list" - liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl)) - mnl - np <- Just <$> funct time pa { particleLife = particleLife pa - time } - return $ np : acc + np <- Just <$> funct time pa + return $ np +-- updateParticle time funct acc@[p] pa = do +-- now <- elapsedTime <$> get +-- if particleCreation pa + particleTimeToLive pa > now +-- then do +-- liftIO $ G.gegl_node_drop $ particleRootNode pa +-- return $ Nothing : acc +-- else do +-- when (not $ isNothing p) $ do +-- -- liftIO $ traceIO "linking second node in list" +-- liftIO $ G.gegl_node_link +-- (particleStackCont pa) +-- (particleStackCont $ fromJust p) +-- np <- Just <$> funct time pa +-- return $ np : acc +-- updateParticle time funct acc@(p:ps) pa = do +-- now <- elapsedTime <$> get +-- if particleCreation pa + particleTimeToLive pa > now +-- then do +-- liftIO $ G.gegl_node_drop $ particleRootNode pa +-- return $ Nothing : acc +-- else do +-- when (isNothing p) $ do +-- let mnl = nextLiving ps +-- maybe +-- (return ()) +-- (\nl -> do +-- -- liftIO $ traceIO "linking nth node on list" +-- liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl)) +-- mnl +-- np <- Just <$> funct time pa +-- return $ np : acc -- | Get the next living particle from a list nextLiving @@ -95,12 +116,53 @@ updateParticleSystem -> (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 <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys) + x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys) + -- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys) when (not $ null x) $ do -- liftIO $ traceIO "linking last node to output" - liftIO $ G.gegl_node_link (particleStackCont $ last x) (psNode sys) - mapM_ (draw (psBuffer sys) (psNode sys)) x + liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys) + mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x return $ sys - { psParts = x } + { partSysParts = (partSysParts sys) + { partStorList = x + , partStorLatest = + if null x + then Nothing + else partStorLatest (partSysParts sys) + } + } + +-- | Function for inserting a new 'Particle' into its 'PartileSystem' +insertParticle + :: ParticleSystem -- ^ 'ParticleSystem' to insert into + -> Particle -- ^ 'Particle' to insert + -> Affection us ParticleSystem -- ^ resulting new 'ParticleSystem' +insertParticle ps p = do + now <- elapsedTime <$> get + let newList = chronoInsert now (partStorList $ partSysParts ps) p + when (not $ isNothing $ partStorLatest $ partSysParts ps) $ + liftIO $ G.gegl_node_link + (particleStackCont p) + (particleStackCont $ fromJust $ partStorLatest $ partSysParts ps) + return $ ps + { partSysParts = (partSysParts ps) + { partStorLatest = Just p + , partStorList = newList + } + } + +-- | Insert a 'Particle' into its chronologically ordered list +chronoInsert + :: Double -- ^ Time in seconds from beginning of program execution + -> [Particle] -- ^ List to insert to + -> Particle -- ^ 'Particle' to insert + -> [Particle] -- ^ Resulting list +chronoInsert now [] np = [np] +chronoInsert now [p] np = + if now + particleTimeToLive p < particleCreation np + then p : [np] + else np : [p] +chronoInsert now l@(p:ps) np = + if now + particleTimeToLive p < particleCreation np + then p : chronoInsert now ps np + else np : l diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 9d43022..c197961 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -19,6 +19,7 @@ module Affection.Types -- | Particle system , Particle(..) , ParticleSystem(..) + , ParticleStorage(..) -- | Convenience exports , liftIO , SDL.WindowConfig(..) @@ -77,6 +78,7 @@ data AffectionData us = AffectionData , drawFormat :: B.BablFormatPtr -- ^ Target format , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated + , elapsedTime :: Double -- ^ Elapsed time in seconds } -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated @@ -165,8 +167,10 @@ instance Eq Angle where -- | A single particle data Particle = Particle - { particleLife :: Double + { particleTimeToLive :: Double -- ^ Time to live in seconds + , particleCreation :: Double + -- ^ Creation time of particle in seconds form program start , particlePosition :: (Double, Double) -- ^ Position of particle on canvas , particleRotation :: Angle @@ -185,8 +189,15 @@ data Particle = Particle -- ^ 'G.GeglNode' to connect draw actions to } +-- | The particle system data ParticleSystem = ParticleSystem - { psParts :: [Particle] - , psNode :: G.GeglNode - , psBuffer :: G.GeglBuffer + { partSysParts :: ParticleStorage + , partSysNode :: G.GeglNode + , partSysBuffer :: G.GeglBuffer + } + +-- | The particle storage datatype +data ParticleStorage = ParticleStorage + { partStorLatest :: Maybe Particle -- ^ The particle stored last + , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime } From ebc0eea6c76ba793cc5ff045e18a62e7d0fd4ddb Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 26 Dec 2016 14:06:51 +0100 Subject: [PATCH 13/15] make previous examples work again --- affection.cabal | 64 ++++++++++++++-------------- examples/example00.hs | 20 +++------ examples/example01.hs | 98 ++++++++----------------------------------- examples/example03.hs | 2 +- 4 files changed, 57 insertions(+), 127 deletions(-) diff --git a/affection.cabal b/affection.cabal index 76b39b0..e88248e 100644 --- a/affection.cabal +++ b/affection.cabal @@ -64,39 +64,39 @@ library , glib -- , sdl2-image --- executable example00 --- hs-source-dirs: examples --- main-is: example00.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 example00 + hs-source-dirs: examples + main-is: example00.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 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/example00.hs b/examples/example00.hs index 84b370d..f2569af 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -7,6 +7,8 @@ import qualified GEGL as G import qualified BABL as B import qualified Data.Map.Strict as M +import Control.Monad (when) + import Foreign.Storable (peek) import Foreign.C.Types (CInt(..)) @@ -36,7 +38,6 @@ main = do data UserData = UserData { nodeGraph :: M.Map String G.GeglNode - , elapsedTime :: Double } load :: SDL.Surface -> IO UserData @@ -69,7 +70,6 @@ load _ = do traceM "loading complete" return $ UserData { nodeGraph = myMap - , elapsedTime = 0 } draw :: Affection UserData () @@ -99,18 +99,10 @@ draw = do update :: Double -> Affection UserData () update sec = do traceM "updating" - -- liftIO $ delaySec 5 - ad@AffectionData{..} <- get - let ud@UserData{..} = userState - traceM $ show elapsedTime - if elapsedTime < 5 - then - put $ ad - { userState = ud - { elapsedTime = elapsedTime + sec - } - } - else + ad <- get + ud@UserData{..} <- getAffection + traceM $ (show $ 1 / sec) ++ " FPS" + when (elapsedTime ad > 5) $ put $ ad { quitEvent = True } diff --git a/examples/example01.hs b/examples/example01.hs index bb61e2b..89675e5 100644 --- a/examples/example01.hs +++ b/examples/example01.hs @@ -7,6 +7,8 @@ import qualified GEGL as G import qualified BABL as B import qualified Data.Map.Strict as M +import Control.Monad (when) + import Foreign.Storable (peek) import Foreign.C.Types @@ -37,7 +39,6 @@ main = do data UserData = UserData { nodeGraph :: M.Map String G.GeglNode , foreground :: G.GeglBuffer - , elapsedTime :: Double } load :: SDL.Surface -> IO UserData @@ -54,111 +55,48 @@ load _ = do traceM "over" buffer <- 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" + nop <- G.gegl_node_new_child root $ G.Operation "gegl: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 + ] + 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) ] let roi = G.GeglRectangle 0 0 20 20 - -- G.iterateOver - -- buffer - -- roi - -- (B.PixelFormat B.RGBA B.CFfloat) - -- G.GeglAccessReadWrite - -- G.GeglAbyssNone - -- (\(G.Pixel px py pc) -> - -- let dsqr = (((10 - px) ^ 2) + ((10 - py) ^ 2)) - -- (G.CVfloat (CFloat pr), G.CVfloat (CFloat pg), G.CVfloat (CFloat pb), G.CVfloat (CFloat pa)) = pc - -- dist = (sqrt (fromIntegral dsqr :: Float)) - -- in if dsqr < 100 - -- then - -- if dist < fromIntegral 9 - -- then - -- G.Pixel px py - -- ( G.CVfloat $ CFloat 0 - -- , G.CVfloat $ CFloat 0 - -- , G.CVfloat $ CFloat 0 - -- , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa - -- ) - -- else - -- let alpha = fromIntegral 10 - dist - -- dst_a = pa - -- a = alpha + dst_a * (1 - alpha) - -- a_term = dst_a * (1 - alpha) - -- red = 0 * alpha + pr * a_term - -- gre = 0 * alpha + pg * a_term - -- blu = 0 * alpha + pb * a_term - -- in - -- G.Pixel px py - -- ( G.CVfloat $ CFloat $ red / a - -- , G.CVfloat $ CFloat $ gre / a - -- , G.CVfloat $ CFloat $ blu / a - -- , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa - -- ) - -- else - -- G.Pixel px py pc - -- ) traceM "loading complete" return $ UserData { nodeGraph = myMap , foreground = buffer - , elapsedTime = 0 } draw :: Affection UserData () draw = do traceM "drawing" UserData{..} <- getAffection - -- AffectionData{..} <- get - -- let UserData{..} = userState - -- -- liftIO $ SDL.lockSurface drawSurface - -- pixels <- liftIO $ SDL.surfacePixels drawSurface - -- let SDL.Surface rawSurfacePtr _ = drawSurface - -- rawSurface <- liftIO $ peek rawSurfacePtr - -- pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface - -- format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8) - -- SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface - -- let (w, h) = (fromIntegral rw, fromIntegral rh) - drawRect foreground (nodeGraph M.! "over") (G.RGB 1 0 0) (Line 2) (G.GeglRectangle 10 10 500 500) - -- liftIO $ G.gegl_node_blit - -- (nodeGraph M.! "over" :: G.GeglNode) - -- 1 - -- (G.GeglRectangle 0 0 w h) - -- format - -- pixels - -- (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w) - -- [G.GeglBlitDefault] - -- liftIO $ SDL.unlockSurface drawSurface - -- liftIO $ SDL.updateWindowSurface drawWindow + drawRect' (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground + liftIO $ G.gegl_node_process $ nodeGraph M.! "sink" update :: Double -> AffectionState (AffectionData UserData) IO () update sec = do traceM "updating" -- liftIO $ delaySec 5 - ad@AffectionData{..} <- get - let ud@UserData{..} = userState + ad <- get + ud@UserData{..} <- getAffection traceM $ (show $ 1 / sec) ++ " FPS" - if elapsedTime < 20 - then do - fg <- liftIO $ G.gegl_buffer_get_extent foreground - _ <- liftIO $ G.gegl_buffer_set_extent foreground $ fg - { G.rectangleX = G.rectangleX fg + 1 - , G.rectangleY = G.rectangleY fg + 1 - } - put $ ad - { userState = ud - { elapsedTime = elapsedTime + sec - } - } - else + when (elapsedTime ad > 20) $ put $ ad { quitEvent = True } diff --git a/examples/example03.hs b/examples/example03.hs index 53af30b..8121058 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -53,7 +53,7 @@ load _ = do [G.Property "buffer" $ G.PropertyBuffer buffer ] traceM "buffer-sink" - nop <- G.gegl_node_new_child root $ G.Operation "nop" [] + nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] traceM "nop" crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" [ G.Property "width" $ G.PropertyDouble 800 From 7837a14456d4ee6f5c44fb6197e13ab814bad51b Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 26 Dec 2016 14:14:34 +0100 Subject: [PATCH 14/15] disable example04 --- affection.cabal | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/affection.cabal b/affection.cabal index e88248e..6b7c526 100644 --- a/affection.cabal +++ b/affection.cabal @@ -133,20 +133,20 @@ executable example03 else buildable: False -executable example04 - hs-source-dirs: examples - main-is: example04.hs - ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , mtl - , random - else - buildable: False +-- executable example04 +-- hs-source-dirs: examples +-- main-is: example04.hs +-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , mtl +-- , random +-- else +-- buildable: False From 10c889af56841a32a5d0fdb8af06704ca846fbd5 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 26 Dec 2016 14:14:54 +0100 Subject: [PATCH 15/15] rename drawRect' to drawRect and clean Affection.Draw --- examples/example01.hs | 2 +- examples/example02.hs | 2 +- src/Affection/Draw.hs | 77 ++----------------------------------------- 3 files changed, 5 insertions(+), 76 deletions(-) diff --git a/examples/example01.hs b/examples/example01.hs index 89675e5..d13abd1 100644 --- a/examples/example01.hs +++ b/examples/example01.hs @@ -86,7 +86,7 @@ draw :: Affection UserData () draw = do traceM "drawing" UserData{..} <- getAffection - drawRect' (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground + drawRect (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground liftIO $ G.gegl_node_process $ nodeGraph M.! "sink" update :: Double -> AffectionState (AffectionData UserData) IO () diff --git a/examples/example02.hs b/examples/example02.hs index dcd0142..00f538a 100644 --- a/examples/example02.hs +++ b/examples/example02.hs @@ -90,7 +90,7 @@ draw = do let (w, h) = (fromIntegral rw, fromIntegral rh) liftIO $ clearArea foreground (GeglRectangle 0 0 w h) maybe (return ()) (\(x, y) -> - drawRect' + drawRect (nodeGraph M.! "nop") (G.RGBA 1 0 0 0.5) (Fill) diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 8826e10..557c5ab 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -2,9 +2,7 @@ -- | Module for drawing primitives module Affection.Draw - ( - -- drawRect - drawRect' + ( drawRect -- , clear , handleDrawRequest , invalidateDrawRequest @@ -30,53 +28,14 @@ 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' +drawRect :: G.GeglNode -- ^ Target Node -> G.Color -- ^ Color to draw in -> DrawType -- ^ Draw type -> G.GeglRectangle -- ^ Dimensions of Rectangle -> G.GeglBuffer -- ^ Final Buffer -> Affection us () -drawRect' node color Fill rect@GeglRectangle{..} buf = do +drawRect node color Fill rect@GeglRectangle{..} buf = do ad <- get tempRoot <- liftIO $ G.gegl_node_new opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle" @@ -105,30 +64,6 @@ present rect buf kill = do { drawStack = (DrawRequest rect buf k) : drawStack ad } --- -- | force a blit of a specified area. Do not use often as it slows down the program --- present --- :: G.GeglNode -- ^ Node to blit --- -> G.GeglBuffer -- ^ BUffer to draw --- -> G.GeglRectangle -- ^ Area to blit --- -> Bool -- ^ Shall the drawing be cleared in the next run? --- -> Affection us () --- present node buf rect pers = do --- ad <- get --- put $ ad --- { drawStack = (DrawRequest rect buf pers) : drawStack ad --- } --- ad <- get --- format <- liftIO $ B.babl_format $ B.PixelFormat B.RGBA B.CFu8 --- liftIO $ SDL.lockSurface $ drawSurface ad --- liftIO $ G.gegl_node_blit --- rect --- format --- nullPtr --- 0 --- [G.GeglBlitDefault] --- liftIO $ SDL.unlockSurface $ drawSurface ad --- liftIO $ SDL.updateWindowSurface $ drawWindow ad - -- | function for handling 'DrawRequest's and updating the output handleDrawRequest :: Ptr a -- ^ Pixel buffer to blit to @@ -233,12 +168,6 @@ unsafeColorize col = , G.CVdouble $ CDouble $ a ) --- -- | Clear all data from a buffer --- clear --- :: G.GeglBuffer -- ^ Target buffer --- -> IO () --- clear buf = clearArea buf =<< G.gegl_rectangle_infinite_plane - -- | Clear a specified area of a buffer from all data clearArea :: G.GeglBuffer -- ^ Target buffer