change to texture drawing

affection.cabal

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

src/Affection.hs

@@ -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
       )

src/Affection/Draw.hs

@@ -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) ->

src/Affection/Types.hs

@@ -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