From f468fdaaf53fbda2e6649470858363cb3c226550 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 21 Dec 2016 04:28:57 +0100 Subject: [PATCH] *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