diff --git a/affection.cabal b/affection.cabal index cf25000..6b7c526 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 @@ -59,7 +59,9 @@ library , gegl , babl , monad-loops + , containers , clock + , glib -- , sdl2-image executable example00 @@ -116,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) @@ -130,3 +132,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/example00.hs b/examples/example00.hs index 8046990..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 @@ -53,7 +54,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" @@ -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..d13abd1 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/example02.hs b/examples/example02.hs index c1fcfb5..00f538a 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,29 @@ 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 + bufPtr <- new b + 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 "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) + , ("crop" , crop) ] traceM "loading complete" return $ UserData @@ -64,10 +76,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 @@ -79,12 +91,13 @@ draw = do liftIO $ clearArea foreground (GeglRectangle 0 0 w h) maybe (return ()) (\(x, y) -> drawRect - foreground - (nodeGraph M.! "over") + (nodeGraph M.! "nop") (G.RGBA 1 0 0 0.5) - (Line 7) + (Fill) (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..8121058 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) @@ -29,7 +32,6 @@ main = do data UserData = UserData { nodeGraph :: M.Map String G.GeglNode , foreground :: G.GeglBuffer - , coordinates :: Maybe (Int, Int) , partsys :: ParticleSystem } @@ -45,37 +47,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 "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 + ] + 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 (ParticleStorage Nothing []) nop buffer } drawInit :: Affection UserData () drawInit = do UserData{..} <- getAffection - present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True + present (GeglRectangle 0 0 800 600) foreground 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,20 +121,47 @@ 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 + 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 + 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 - { coordinates = Just (fromIntegral x, fromIntegral y) - , partsys = (partsys ud) - { psParts = (Particle - { particleLife = life - , particlePosition = (fromIntegral x, fromIntegral y) - , particleRotation = Rad 0 - , particleVelocity = (vx, vy) - , particlePitchRate = Rad 0 - }) : (psParts $ partsys ud) - } + { partsys = ips } + -- when (not $ null $ psParts $ partsys ud) $ + -- liftIO $ G.gegl_node_link + -- tempOver + -- (particleStackCont $ head $ psParts $ partsys ud) else return () SDL.WindowClosedEvent _ -> do @@ -140,22 +179,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) - , particleLife = particleLife - sec } - where - newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity) - newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity) partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData () partDraw buf node Particle{..} = do - ud <- getAffection - drawRect + present + (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20) buf - node - (G.RGBA 1 0 0 0.5) - (Line 5) - (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20) + 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/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 () diff --git a/src/Affection.hs b/src/Affection.hs index 460cc63..343e16e 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -63,7 +63,9 @@ withAffection AffectionConfig{..} = do , userState = x , drawWindow = window , drawSurface = surface + , drawFormat = format , drawStack = [] + , elapsedTime = 0 }) <$> loadState surface (_, nState) <- runStateT ( A.runState $ do preLoop @@ -79,17 +81,20 @@ 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 + -- 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 dt -- execute user defined draw loop drawLoop - -- execute user defined update loop - updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / - (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..557c5ab 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -12,11 +12,13 @@ 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) +import Control.Monad (when, unless) + +import System.Glib.GObject import qualified SDL @@ -26,123 +28,99 @@ 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 + :: 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 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 +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" + [ 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 False) : drawStack + { drawStack = (DrawRequest rect buf (Kill (Just tempRoot))) : drawStack ad } -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 node 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 +-- | Force update of a specific region on screen 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? + :: G.GeglRectangle -- ^ Area to be updated + -> G.GeglBuffer -- ^ Target buffer + -> Bool -- ^ Shall the 'DrawRequest' persist? -> Affection us () -present node buf rect pers = do +present rect buf kill = do ad <- get - put $ ad - { drawStack = (DrawRequest node rect buf pers) : drawStack ad + let k = if not kill then Kill Nothing else Yes + put ad + { drawStack = (DrawRequest rect buf k) : 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 -- | 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 - then - return Nothing - else - return $ Just dr + case requestPersist of + Yes -> + return Nothing + Kill _ -> + return $ Just dr -- | 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 + 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 + case requestPersist of + Kill (Just victim) -> + liftIO $ G.gegl_node_drop victim + _ -> + return () -- liftIO $ SDL.updateWindowSurface $ drawWindow ad -- | compute color for a single pixel @@ -190,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 diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 1d4e900..311048f 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -5,30 +5,103 @@ module Affection.Particle ( updateParticle , drawParticles , updateParticleSystem + , insertParticle ) where import Affection.Types -import Data.Maybe (catMaybes) +import Control.Monad +import Control.Monad.State (get) + +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. 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 - -> Maybe Particle -- ^ resulting 'Particle' -updateParticle time funct p@Particle{..} = - if particleLife - time < 0 - then - Nothing - else - Just $ funct time $ p { particleLife = particleLife - time } + :: 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. + -- -> [Maybe Particle] + -> Particle + -- ^ 'Particle' to be processed + -- -> Affection us [Maybe Particle] + -> Affection us (Maybe Particle) + -- ^ resulting 'Particle' +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 + else do + 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 + :: [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 ()) @@ -39,11 +112,57 @@ 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 $ map (updateParticle sec upd) (psParts sys) - mapM_ (draw (psBuffer sys) (psNode sys)) x + 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) (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 bca87d0..c197961 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -13,11 +13,13 @@ module Affection.Types , RGBA(..) , DrawType(..) , DrawRequest(..) + , RequestPersist(..) , Angle(..) , ConvertAngle(..) -- | Particle system , Particle(..) , ParticleSystem(..) + , ParticleStorage(..) -- | Convenience exports , liftIO , SDL.WindowConfig(..) @@ -30,7 +32,10 @@ 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 import Control.Monad.IO.Class import Control.Monad.State @@ -58,6 +63,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 +75,25 @@ 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 + , elapsedTime :: Double -- ^ Elapsed time in seconds } -- | 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 + , requestPersist :: RequestPersist -- ^ Shall the drawRequest persist } --- | Components to initialize in SDL. -data InitComponents - = All - | Only [SDL.InitFlag] +data RequestPersist + = Yes + | Kill (Maybe G.GeglNode) + +-- | 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 @@ -154,20 +167,37 @@ instance Eq Angle where -- | A single particle data Particle = Particle - { particleLife :: Double + { particleTimeToLive :: Double -- ^ Time to live in seconds - , particlePosition :: (Double, Double) + , particleCreation :: Double + -- ^ Creation time of particle in seconds form program start + , 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) - -data ParticleSystem = ParticleSystem - { psParts :: [Particle] - , psNode :: G.GeglNode - , psBuffer :: G.GeglBuffer + , 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 + } + +-- | The particle system +data ParticleSystem = ParticleSystem + { 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 }