change to texture drawing

This commit is contained in:
nek0 2017-03-22 16:59:24 +01:00
parent 22877d239b
commit ef40eed917
4 changed files with 61 additions and 5 deletions

View file

@ -69,6 +69,7 @@ library
, containers , containers
, clock , clock
, glib , glib
, bytestring
-- , sdl2-image -- , sdl2-image
executable example00 executable example00

View file

@ -73,6 +73,12 @@ withAffection AffectionConfig{..} = do
window window
(-1) (-1)
SDL.defaultRenderer SDL.defaultRenderer
-- make draw texture
texture <- SDL.createTexture
renderer
SDL.ABGR8888
SDL.TextureAccessStreaming
(SDL.windowInitialSize windowConfig)
-- make draw surface -- make draw surface
surface <- SDL.createRGBSurface surface <- SDL.createRGBSurface
(SDL.windowInitialSize windowConfig) (SDL.windowInitialSize windowConfig)
@ -91,7 +97,8 @@ withAffection AffectionConfig{..} = do
, userState = x , userState = x
, drawWindow = window , drawWindow = window
, windowRenderer = renderer , windowRenderer = renderer
, drawSurface = surface -- , drawSurface = surface
, drawTexture = texture
, drawFormat = format , drawFormat = format
, drawPixels = pixels , drawPixels = pixels
, drawDimensions = (w, h) , drawDimensions = (w, h)
@ -140,12 +147,12 @@ withAffection AffectionConfig{..} = do
put $ ad2 put $ ad2
{ drawStack = clear } { drawStack = clear }
-- get texture from surface -- get texture from surface
texture <- SDL.createTextureFromSurface (windowRenderer ad2) (drawSurface ad2) -- texture <- SDL.createTextureFromSurface (windowRenderer ad2) (drawSurface ad2)
-- actual drawing -- actual drawing
SDL.copy (windowRenderer ad2) texture Nothing Nothing SDL.copy (windowRenderer ad2) texture Nothing Nothing
SDL.present (windowRenderer ad2) SDL.present (windowRenderer ad2)
-- clean the texture -- clean the texture
SDL.destroyTexture texture -- SDL.destroyTexture texture
-- save new time -- save new time
liftIO $ writeIORef execTime now liftIO $ writeIORef execTime now
) )

View file

@ -14,9 +14,11 @@ module Affection.Draw
import Affection.Types import Affection.Types
import Data.Maybe (maybe) import Data.Maybe (maybe)
import Data.ByteString (ByteString)
import Foreign import Foreign
import Foreign.C.Types import Foreign.C.Types
import Foreign.Marshal.Alloc (malloc, free)
import Control.Monad.State (get, put) import Control.Monad.State (get, put)
import Control.Monad (when, unless) import Control.Monad (when, unless)
@ -93,6 +95,49 @@ putToSurface pixels realRect stride cpp DrawRequest{..} = do
G.GeglAbyssNone G.GeglAbyssNone
liftIO $ SDL.unlockSurface $ drawSurface ad liftIO $ SDL.unlockSurface $ drawSurface ad
putToTexture
:: G.GeglRectangle
-> Int
-> Int
-> DrawRequest
-> Affection us ()
putToTexture realRect stride cpp DrawRequest{..} = do
ad <- get
destRect <- return $
SDL.Rectangle
(SDL.P $ SDL.V2
(CInt $ fromIntegral $ rectangleX realRect)
(CInt $ fromIntegral $ rectangleY realRect)
)
(SDL.V2
(CInt $ fromIntegral $ rectangleWidth realRect)
(CInt $ fromIntegral $ rectangleHeight realRect)
)
(destPtr, destStride) <- SDL.lockTexture
(drawTexture ad)
(Just destRect)
-- destPtr <- liftIO $ malloc :: (Ptr ByteString)
liftIO $ G.gegl_buffer_get
requestBuffer
(Just realRect)
1
(Just $ drawFormat ad)
destPtr
stride
G.GeglAbyssNone
-- pixelData <- liftIO $ peekArray
-- (rectangleWidth realRect * rectangleHeight realRect)
-- destPtr
-- SDL.updateTexture
-- (drawTexture ad)
-- (Just $ SDL.Rectangle
-- (SDL.P $ SDL.V2 (rectangleX realRect) (rectangleY realRect))
-- (SDL.V2 (rectangleWidth realRect) (rectangleHeight realRect))
-- )
-- pixelData
-- (CInt $ fromIntegral stride)
SDL.unlockTexture $ drawTexture 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
@ -108,7 +153,8 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
requestArea requestArea
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) (uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
maybe (return()) (\realRect -> maybe (return()) (\realRect ->
putToSurface pixels realRect stride cpp dr -- putToSurface pixels realRect stride cpp dr
putToTexture realRect stride cpp dr
) mrealRect ) mrealRect
case requestPersist of case requestPersist of
Persist -> Persist ->
@ -131,7 +177,8 @@ invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) (uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
maybe (return()) (\realRect -> do maybe (return()) (\realRect -> do
liftIO $ clearArea requestBuffer realRect liftIO $ clearArea requestBuffer realRect
putToSurface pixels realRect stride cpp dr -- putToSurface pixels realRect stride cpp dr
putToTexture realRect stride cpp dr
) mrealRect ) mrealRect
case requestPersist of case requestPersist of
Kill (Just victim) -> Kill (Just victim) ->

View file

@ -82,6 +82,7 @@ data AffectionData us = AffectionData
, drawWindow :: SDL.Window -- ^ SDL window , drawWindow :: SDL.Window -- ^ SDL window
, windowRenderer :: SDL.Renderer -- ^ Internal renderer of window , windowRenderer :: SDL.Renderer -- ^ Internal renderer of window
, drawSurface :: SDL.Surface -- ^ SDL surface , drawSurface :: SDL.Surface -- ^ SDL surface
, drawTexture :: SDL.Texture -- ^ SDL Texture to draw to
, drawFormat :: B.BablFormatPtr -- ^ Target format , drawFormat :: B.BablFormatPtr -- ^ Target format
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
, drawPixels :: Ptr () -- ^ Destination Pixel buffer , drawPixels :: Ptr () -- ^ Destination Pixel buffer