*vomiting sounds*

This commit is contained in:
nek0 2016-12-21 04:28:57 +01:00
parent 52da5e54bd
commit f468fdaaf5
7 changed files with 117 additions and 65 deletions

View file

@ -130,3 +130,21 @@ executable example03
, random , random
else else
buildable: False 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

View file

@ -52,7 +52,7 @@ load _ = do
traceM "checkerboard" traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over" 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) B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
[ G.Property "buffer" $ G.PropertyBuffer buffer [ G.Property "buffer" $ G.PropertyBuffer buffer

View file

@ -3,10 +3,13 @@
import Affection import Affection
import qualified SDL import qualified SDL
import qualified GEGL as G import qualified GEGL as G
import qualified GEGL.FFI.Buffer as G
import qualified BABL as B import qualified BABL as B
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Foreign.C.Types import Foreign.C.Types
import Foreign.Marshal.Utils (new)
import Foreign.Ptr (castPtr)
import Debug.Trace import Debug.Trace
@ -16,7 +19,7 @@ main = do
{ initComponents = All { initComponents = All
, windowTitle = "Affection: example00" , windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow , windowConfig = SDL.defaultWindow
, preLoop = drawInit , preLoop = return ()
, drawLoop = draw , drawLoop = draw
, updateLoop = update , updateLoop = update
, loadState = load , loadState = load
@ -42,20 +45,24 @@ load _ = do
traceM "checkerboard" traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over" 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) B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation bufPtr <- new b
[ G.Property "buffer" $ G.PropertyBuffer buffer sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink"
[ G.Property "buffer" $ G.PropertyPointer $ castPtr bufPtr
] ]
traceM "buffer-source" traceM "buffer-sink"
G.gegl_node_link checkerboard over nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
G.gegl_node_connect_to bufsrc "output" over "aux" traceM "nop"
G.gegl_node_link_many [checkerboard, over, sink]
G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made" traceM "connections made"
myMap <- return $ M.fromList myMap <- return $ M.fromList
[ ("root" , root) [ ("root" , root)
, ("over" , over) , ("over" , over)
, ("background" , checkerboard) , ("background" , checkerboard)
, ("foreground" , bufsrc) , ("sink" , sink)
, ("nop" , nop)
] ]
traceM "loading complete" traceM "loading complete"
return $ UserData return $ UserData
@ -64,10 +71,10 @@ load _ = do
, coordinates = Nothing , coordinates = Nothing
} }
drawInit :: Affection UserData () -- drawInit :: Affection UserData ()
drawInit = do -- drawInit = do
UserData{..} <- getAffection -- UserData{..} <- getAffection
present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True -- present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
@ -78,12 +85,12 @@ draw = do
let (w, h) = (fromIntegral rw, fromIntegral rh) let (w, h) = (fromIntegral rw, fromIntegral rh)
liftIO $ clearArea foreground (GeglRectangle 0 0 w h) liftIO $ clearArea foreground (GeglRectangle 0 0 w h)
maybe (return ()) (\(x, y) -> maybe (return ()) (\(x, y) ->
drawRect drawRect'
foreground (nodeGraph M.! "nop")
(nodeGraph M.! "over")
(G.RGBA 1 0 0 0.5) (G.RGBA 1 0 0 0.5)
(Line 7) (Fill)
(G.GeglRectangle (x - 10) (y - 10) 20 20) (G.GeglRectangle (x - 10) (y - 10) 20 20)
foreground
) coordinates ) coordinates
update :: Double -> AffectionState (AffectionData UserData) IO () update :: Double -> AffectionState (AffectionData UserData) IO ()

View file

@ -45,7 +45,7 @@ load _ = do
traceM "checkerboard" traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over" 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) B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
[ G.Property "buffer" $ G.PropertyBuffer buffer [ G.Property "buffer" $ G.PropertyBuffer buffer

View file

@ -63,6 +63,7 @@ withAffection AffectionConfig{..} = do
, userState = x , userState = x
, drawWindow = window , drawWindow = window
, drawSurface = surface , drawSurface = surface
, drawFormat = format
, drawStack = [] , drawStack = []
}) <$> loadState surface }) <$> loadState surface
(_, nState) <- runStateT ( A.runState $ do (_, nState) <- runStateT ( A.runState $ do
@ -79,7 +80,7 @@ withAffection AffectionConfig{..} = do
-- get state -- get state
ad <- get ad <- get
-- clean draw requests from last run -- clean draw requests from last run
mapM_ (invalidateDrawRequest pixels format stride cpp) $ drawStack ad mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
put $ ad put $ ad
{ drawStack = [] } { drawStack = [] }
-- execute user defined draw loop -- execute user defined draw loop
@ -89,7 +90,7 @@ withAffection AffectionConfig{..} = do
(fromIntegral 10 ^ 9) (fromIntegral 10 ^ 9)
-- handle all new draw requests -- handle all new draw requests
ad2 <- get 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 -- save all draw requests to clear in next run
put $ ad2 put $ ad2
{ drawStack = clear } { drawStack = clear }

View file

@ -3,10 +3,11 @@
-- | Module for drawing primitives -- | Module for drawing primitives
module Affection.Draw module Affection.Draw
( drawRect ( drawRect
, drawRect'
-- , clear -- , clear
, handleDrawRequest , handleDrawRequest
, invalidateDrawRequest , invalidateDrawRequest
, present -- , present
, clearArea , clearArea
) where ) where
@ -16,7 +17,7 @@ import Foreign.Ptr (Ptr, plusPtr, nullPtr)
import Foreign.C.Types import Foreign.C.Types
import Control.Monad.State (get, put) import Control.Monad.State (get, put)
import Control.Monad (when) import Control.Monad (when, unless)
import qualified SDL import qualified SDL
@ -43,7 +44,7 @@ drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
) )
ad@AffectionData{..} <- get ad@AffectionData{..} <- get
put $ ad 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 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 $ 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 ad@AffectionData{..} <- get
put $ ad 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 rectangleWidth size)
-- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight) -- 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 + rectangleWidth - size) rectangleY size rectangleHeight)
-- drawRect buf node color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size) -- 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 drawRect'
present :: G.GeglNode -- ^ Target Node
:: G.GeglNode -- ^ Node to blit -> G.Color -- ^ Color to draw in
-> G.GeglBuffer -- ^ BUffer to draw -> DrawType -- ^ Draw type
-> G.GeglRectangle -- ^ Area to blit -> G.GeglRectangle -- ^ Dimensions of Rectangle
-> Bool -- ^ Shall the drawing be cleared in the next run? -> G.GeglBuffer -- ^ Final Buffer
-> Affection us () -> Affection us ()
present node buf rect pers = do drawRect' node color Fill rect@GeglRectangle{..} buf = do
ad <- get 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 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 -- -- | force a blit of a specified area. Do not use often as it slows down the program
liftIO $ SDL.lockSurface $ drawSurface ad -- present
liftIO $ G.gegl_node_blit -- :: G.GeglNode -- ^ Node to blit
node -- -> G.GeglBuffer -- ^ BUffer to draw
1 -- -> G.GeglRectangle -- ^ Area to blit
rect -- -> Bool -- ^ Shall the drawing be cleared in the next run?
format -- -> Affection us ()
nullPtr -- present node buf rect pers = do
0 -- ad <- get
[G.GeglBlitDefault] -- put $ ad
liftIO $ SDL.unlockSurface $ drawSurface ad -- { drawStack = (DrawRequest rect buf pers) : drawStack ad
liftIO $ SDL.updateWindowSurface $ drawWindow 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 -- | function for handling 'DrawRequest's and updating the output
handleDrawRequest handleDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to :: Ptr a -- ^ Pixel buffer to blit to
-> B.BablFormatPtr -- ^ format to blit in -- -> B.BablFormatPtr -- ^ format to blit in
-> Int -- ^ Stride -> Int -- ^ Stride
-> Int -- ^ Components per Pixel -> Int -- ^ Components per Pixel
-> DrawRequest -- ^ 'DrawRequest' to handle -> DrawRequest -- ^ 'DrawRequest' to handle
-> Affection us (Maybe DrawRequest) -> Affection us (Maybe DrawRequest)
handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
ad <- get ad <- get
let surf = drawSurface ad let surf = drawSurface ad
liftIO $ SDL.lockSurface surf liftIO $ SDL.lockSurface surf
liftIO $ G.gegl_node_blit liftIO $ G.gegl_buffer_get
requestNode requestBuffer
(Just requestArea)
1 1
requestArea (Just $ drawFormat ad)
format
(pixels `plusPtr` (pixels `plusPtr`
(rectangleX requestArea * cpp + rectangleY requestArea * stride)) (rectangleX requestArea * cpp + rectangleY requestArea * stride))
stride stride
[G.GeglBlitDefault] G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf liftIO $ SDL.unlockSurface surf
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad -- liftIO $ SDL.updateWindowSurface $ drawWindow ad
if requestPersist if requestPersist
@ -123,25 +144,25 @@ handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do
-- | clear a previously drawn area -- | clear a previously drawn area
invalidateDrawRequest invalidateDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to :: Ptr a -- ^ Pixel buffer to blit to
-> B.BablFormatPtr -- ^ format to blit in -- -> B.BablFormatPtr -- ^ format to blit in
-> Int -- ^ Stride -> Int -- ^ Stride
-> Int -- ^ Components per Pixel -> Int -- ^ Components per Pixel
-> DrawRequest -- ^ Drawrequest to invalidate -> DrawRequest -- ^ Drawrequest to invalidate
-> Affection us () -> Affection us ()
invalidateDrawRequest pixels format stride cpp dr@DrawRequest{..} = do invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
ad <- get ad <- get
let !surf = drawSurface ad let !surf = drawSurface ad
liftIO $ clearArea requestBuffer requestArea liftIO $ clearArea requestBuffer requestArea
liftIO $ SDL.lockSurface surf liftIO $ SDL.lockSurface surf
liftIO $ G.gegl_node_blit liftIO $ G.gegl_buffer_get
requestNode requestBuffer
(Just requestArea)
1 1
requestArea (Just $ drawFormat ad)
format
(pixels `plusPtr` (pixels `plusPtr`
(rectangleX requestArea * cpp + rectangleY requestArea * stride)) (rectangleX requestArea * cpp + rectangleY requestArea * stride))
stride stride
[G.GeglBlitDefault] G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf liftIO $ SDL.unlockSurface surf
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad -- liftIO $ SDL.updateWindowSurface $ drawWindow ad

View file

@ -30,7 +30,9 @@ module Affection.Types
import qualified SDL.Init as SDL import qualified SDL.Init as SDL
import qualified SDL.Video as SDL import qualified SDL.Video as SDL
import qualified Data.Text as T import qualified Data.Text as T
import qualified GEGL as G import qualified GEGL as G
import qualified BABL as B
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State import Control.Monad.State
@ -58,6 +60,11 @@ data AffectionConfig us = AffectionConfig
-- ^ Provide your own finisher function to clean your data. -- ^ 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. -- | Main type for defining the look, feel and action of the whole application.
data AffectionData us = AffectionData data AffectionData us = AffectionData
-- { affectionConfig :: AffectionConfig us -- ^ Application configuration. -- { affectionConfig :: AffectionConfig us -- ^ Application configuration.
@ -65,22 +72,20 @@ data AffectionData us = AffectionData
, userState :: us -- ^ State data provided by user , userState :: us -- ^ State data provided by user
, drawWindow :: SDL.Window -- ^ SDL window , drawWindow :: SDL.Window -- ^ SDL window
, drawSurface :: SDL.Surface -- ^ SDL surface , drawSurface :: SDL.Surface -- ^ SDL surface
, drawFormat :: B.BablFormatPtr -- ^ Target format
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
, clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated , clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated
} }
-- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
data DrawRequest = DrawRequest 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 , requestBuffer :: G.GeglBuffer -- ^ Buffer to draw
, requestPersist :: Bool -- ^ Shall the drawRequest persist , requestPersist :: Bool -- ^ Shall the drawRequest persist
} }
-- | Components to initialize in SDL. -- | A type for storing 'DrawRequest' results to be executed frequently. TODO
data InitComponents data DrawAsset = DrawAsset
= All
| Only [SDL.InitFlag]
-- | Inner 'StateT' monad for the update state -- | Inner 'StateT' monad for the update state
-- type AffectionStateInner us m a = StateT (AffectionData us) m a -- type AffectionStateInner us m a = StateT (AffectionData us) m a