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
, clock
, glib
, bytestring
-- , sdl2-image
executable example00

View file

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

View file

@ -14,9 +14,11 @@ module Affection.Draw
import Affection.Types
import Data.Maybe (maybe)
import Data.ByteString (ByteString)
import Foreign
import Foreign.C.Types
import Foreign.Marshal.Alloc (malloc, free)
import Control.Monad.State (get, put)
import Control.Monad (when, unless)
@ -93,6 +95,49 @@ putToSurface pixels realRect stride cpp DrawRequest{..} = do
G.GeglAbyssNone
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
handleDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to
@ -108,7 +153,8 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
requestArea
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
maybe (return()) (\realRect ->
putToSurface pixels realRect stride cpp dr
-- putToSurface pixels realRect stride cpp dr
putToTexture realRect stride cpp dr
) mrealRect
case requestPersist of
Persist ->
@ -131,7 +177,8 @@ invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
maybe (return()) (\realRect -> do
liftIO $ clearArea requestBuffer realRect
putToSurface pixels realRect stride cpp dr
-- putToSurface pixels realRect stride cpp dr
putToTexture realRect stride cpp dr
) mrealRect
case requestPersist of
Kill (Just victim) ->

View file

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