now works and cleans and everything \o/

This commit is contained in:
nek0 2016-12-11 20:24:16 +01:00
parent fd7f2ff8ba
commit cb158f1b2b
4 changed files with 70 additions and 19 deletions

View File

@ -19,6 +19,7 @@ main = do
{ initComponents = All
, windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow
, preLoop = drawInit
, drawLoop = draw
, updateLoop = update
, loadState = load
@ -77,6 +78,12 @@ load surface = do
, coordinates = Nothing
}
drawInit :: Affection UserData ()
drawInit = do
AffectionData{..} <- get
let UserData{..} = userState
present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
draw :: Affection UserData ()
draw = do
traceM "drawing"
@ -95,8 +102,8 @@ draw = do
drawRect
foreground
(nodeGraph M.! "over")
(G.RGB 1 0 0)
(Line 2)
(G.RGBA 1 0 0 0.5)
(Line 7)
(G.GeglRectangle (x - 10) (y - 10) 20 20)
) coordinates
-- liftIO $ G.gegl_node_process $ nodeGraph M.! "display"
@ -114,7 +121,6 @@ draw = do
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do
traceM "updating"
-- liftIO $ delaySec 5
ad@AffectionData{..} <- get
let ud@UserData{..} = userState
traceM $ (show $ 1 / sec) ++ " FPS"

View File

@ -63,6 +63,7 @@ withAffection AffectionConfig{..} = do
, drawStack = []
}) =<< loadState surface
(_, nState) <- runStateT ( A.runState $ do
preLoop
whileM_ (do
current <- get
return $ not $ A.quitEvent current
@ -70,11 +71,15 @@ withAffection AffectionConfig{..} = do
(do
now <- liftIO $ getTime Monotonic
lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime
drawLoop
ad <- get
mapM_ (handleDrawRequest pixels format stride cpp) $ drawStack ad
mapM_ (invalidateDrawRequest pixels format stride cpp) $ drawStack ad
put $ ad
{ drawStack = [] }
drawLoop
ad <- get
clear <- return . catMaybes =<< mapM (handleDrawRequest pixels format stride cpp) (drawStack ad)
put $ ad
{ drawStack = clear }
liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
(fromIntegral 10 ^ 9)

View File

@ -5,6 +5,7 @@ module Affection.Draw
( drawRect
-- , clear
, handleDrawRequest
, invalidateDrawRequest
, present
, clearArea
) where
@ -15,6 +16,7 @@ import Foreign.Ptr (Ptr, plusPtr)
import Foreign.C.Types
import Control.Monad.State (get, put)
import Control.Monad (when)
import qualified SDL
@ -22,6 +24,8 @@ import qualified BABL as B
import qualified GEGL as G
import Debug.Trace
-- | Draw a rectangle on target buffer
drawRect
:: G.GeglBuffer -- ^ Target buffer
@ -39,27 +43,29 @@ drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
)
ad@AffectionData{..} <- get
put $ ad
{ drawStack = (DrawRequest node rect) : drawStack
{ drawStack = (DrawRequest node rect buf False) : drawStack
}
drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do
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)
ad@AffectionData{..} <- get
put $ ad
{ drawStack = (DrawRequest node rect) : drawStack
}
-- ad@AffectionData{..} <- get
-- put $ ad
-- { drawStack = (DrawRequest node rect) : drawStack
-- }
-- | force a blit of a specified area
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 rect = do
present node buf rect pers = do
ad@AffectionData{..} <- get
put $ ad
{ drawStack = (DrawRequest node rect) : drawStack
{ drawStack = (DrawRequest node rect buf pers) : drawStack
}
-- | function for handling 'DrawRequest's and updating the output
@ -69,8 +75,8 @@ handleDrawRequest
-> Int -- ^ Stride
-> Int -- ^ Components per Pixel
-> DrawRequest -- ^ 'DrawRequest' to handle
-> Affection us ()
handleDrawRequest pixels format stride cpp DrawRequest{..} = do
-> Affection us (Maybe DrawRequest)
handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do
ad <- get
liftIO $ SDL.lockSurface $ drawSurface ad
liftIO $ G.gegl_node_blit
@ -84,6 +90,35 @@ handleDrawRequest pixels format stride cpp DrawRequest{..} = do
[G.GeglBlitDefault]
liftIO $ SDL.unlockSurface $ drawSurface ad
liftIO $ SDL.updateWindowSurface $ drawWindow ad
if requestPersist
then
return Nothing
else
return $ Just dr
-- | clear a previously drawn area
invalidateDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to
-> 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
ad <- get
liftIO $ clearArea requestBuffer requestArea
liftIO $ SDL.lockSurface $ drawSurface ad
liftIO $ G.gegl_node_blit
requestNode
1
requestArea
format
(pixels `plusPtr`
(rectangleX requestArea * cpp + rectangleY requestArea * stride))
stride
[G.GeglBlitDefault]
liftIO $ SDL.unlockSurface $ drawSurface ad
liftIO $ SDL.updateWindowSurface $ drawWindow ad
-- | compute color for a single pixel
colorize

View File

@ -41,9 +41,11 @@ data AffectionConfig us = AffectionConfig
-- ^ Window title
, windowConfig :: SDL.WindowConfig
-- ^ Window configuration
, drawLoop :: AffectionState (AffectionData us) IO ()
, preLoop :: Affection us ()
-- ^ Actions to be performed, before loop starts
, drawLoop :: Affection us ()
-- ^ Function for updating graphics.
, updateLoop :: Double -> AffectionState (AffectionData us) IO ()
, updateLoop :: Double -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, loadState :: SDL.Surface -> IO us
-- ^ Provide your own load function to create this data.
@ -58,13 +60,16 @@ data AffectionData us = AffectionData
, userState :: us -- ^ State data provided by user
, drawWindow :: SDL.Window -- ^ SDL window
, drawSurface :: SDL.Surface -- ^ SDL surface
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequests's to be processed
, 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
{ requestNode :: G.GeglNode -- ^ The 'G.GeglNode' to blit
, requestArea :: G.GeglRectangle -- ^ The area to update
, requestBuffer :: G.GeglBuffer -- ^ Buffer to draw
, requestPersist :: Bool -- ^ Shall the drawRequest persist
}
-- | Components to initialize in SDL.