it works. what do you want more?

examples/example04.hs

@@ -10,6 +10,8 @@ import Data.Maybe (fromJust)
 import Control.Monad (when)
 import qualified Control.Monad.Parallel as MP
 
+import Foreign.C.Types
+
 import Debug.Trace
 
 main :: IO ()
@@ -32,8 +34,9 @@ data UserData = UserData
   { nodeGraph    :: M.Map String G.GeglNode
   , actors       :: M.Map String (Actor String)
   , foreground   :: G.GeglBuffer
-  , lastTick     :: Double
   , updateActors :: [Actor String]
+  , keyDown      :: Maybe SDL.Keycode
+  , cameraX      :: Int
   }
 
 load :: IO UserData
@@ -56,7 +59,7 @@ load = do
   traceM "background"
   over <- G.gegl_node_new_child root G.defaultOverOperation
   traceM "over"
-  buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
+  buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 3289 600) =<<
     B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
   sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
     props $
@@ -72,8 +75,8 @@ load = do
   traceM "rect"
   crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
     props $ do
-      prop "width" (800::Double)
+      prop "width" (3289 :: Double)
-      prop "height" (600::Double)
+      prop "height" (600 :: Double)
   G.gegl_node_link_many [bg, bgTrans, bgScale, over, crop, sink]
   _ <- G.gegl_node_connect_to rect "output" over "aux"
   rectActor <- return $ Actor (map
@@ -122,14 +125,17 @@ load = do
     { nodeGraph    = myMap
     , actors       = actorMap
     , foreground   = buffer
-    , lastTick     = 0
     , updateActors = []
+    , keyDown      = Nothing
+    , cameraX      = 0
     }
 
--- drawInit :: Affection UserData ()
+drawInit :: Affection UserData ()
--- drawInit = do
+drawInit = do
---   UserData{..} <- getAffection
+  ad <- get
---   present (GeglRectangle 0 0 800 600) foreground True
+  ud <- getAffection
+  process (nodeGraph ud M.! "sink")
+  present (GeglRectangle 0 0 3289 600) (foreground ud) True
 
 draw :: Affection UserData ()
 draw = do
@@ -139,88 +145,79 @@ draw = do
     { updateActors = []
     }
   process (nodeGraph M.! "sink")
-  present (GeglRectangle 0 0 800 600) foreground True
+  present (GeglRectangle cameraX 0 800 600) foreground True
+  render
+    (Just $ G.GeglRectangle cameraX 0 800 600)
+    Nothing
 
-update :: Affection UserData ()
+update :: Double -> Affection UserData ()
-update = do
+update dt = do
   traceM "updating"
 
-  tick <- getElapsedTime
   ud <- getAffection
-  putAffection $ ud { lastTick = tick }
 
-  let dt = tick - lastTick ud
-  return ()
   traceM $ show (1 / dt) ++ " FPS"
 
-handle :: SDL.EventPayload -> Affection UserData ()
+  maybe (return ()) (\code -> do
-handle (SDL.KeyboardEvent dat) =
+    let vel = 400 -- velocity in Pixels per second
-  when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
+        leg = floor (vel * dt)
-    ud <- getAffection
     (G.PropertyDouble xpos) <-
       return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
         actorProperties $ actors ud M.! "rect"
-    if xpos >= 40 && xpos <= 760
+    nmap <- return $ M.adjust
-    then do
+      (updateProperties $ props $ prop "x" $
-      nmap <- return $ M.adjust
+        case code of
-        (updateProperties $ props $ prop "x" $
+          SDL.KeycodeLeft ->
-          case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
+            if xpos > 0
-            SDL.KeycodeLeft -> xpos - 20
+            then xpos - fromIntegral leg
-            SDL.KeycodeRight -> xpos + 20
+            else xpos
-            _ -> xpos
+          SDL.KeycodeRight ->
-          )
+            if xpos < 3269
-        "rect"
+            then xpos + fromIntegral leg
-        (actors ud)
+            else xpos
+          _ -> xpos
+        )
+      "rect"
+      (actors ud)
+    putAffection ud
+      { actors = nmap
+      , updateActors = (nmap M.! "rect") : updateActors ud
+      }
+    ud2 <- getAffection
+    (G.PropertyDouble xpos2) <-
+      return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
+        actorProperties $ actors ud M.! "rect"
+    ncx <-
+      if xpos2 - fromIntegral (cameraX ud2) > 750
+      then return $
+        if cameraX ud2 + leg > 2489 && code == SDL.KeycodeRight
+        then cameraX ud2
+        else cameraX ud2 + leg
+      else
+        if xpos2 - fromIntegral (cameraX ud2) < 50
+        then return $ 
+          if cameraX ud2 - leg < 0 && code == SDL.KeycodeLeft
+          then cameraX ud2
+          else cameraX ud2 - leg
+        else
+          return $ cameraX ud2 
+    putAffection ud2
+      { cameraX = ncx
+      }
+    ) (keyDown ud)
+
+handle :: SDL.EventPayload -> Affection UserData ()
+handle (SDL.KeyboardEvent dat) =
+  when (not (SDL.keyboardEventRepeat dat)) $ do
+    ud <- getAffection
+    if (SDL.keyboardEventKeyMotion dat == SDL.Pressed)
+    then
       putAffection ud
-        { actors = nmap
+        { keyDown = Just $ SDL.keysymKeycode $ SDL.keyboardEventKeysym dat
-        , updateActors = (nmap M.! "rect") : updateActors ud
         }
-    else do
+    else
-      (G.PropertyDouble bgPos) <-
-        return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
-          actorProperties $ actors ud M.! "background"
-      nmap <- return $ M.adjust
-        (updateProperties $ props $ prop "x" $
-          if xpos < 40
-          then
-            case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
-              SDL.KeycodeLeft ->
-                if bgPos <= 0 then bgPos + 20 else bgPos
-              SDL.KeycodeRight ->
-                bgPos
-              _ -> bgPos
-          else
-            case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
-              SDL.KeycodeLeft ->
-                bgPos
-              SDL.KeycodeRight ->
-                if bgPos >= -2489 then bgPos - 20 else bgPos
-              _ -> bgPos
-          )
-        "background"
-        (actors ud)
-      nmap2 <- return $ M.adjust
-        (updateProperties $ props $ prop "x" $
-          case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
-            SDL.KeycodeLeft ->
-              if xpos < 40
-              then
-                xpos
-              else
-                xpos - 20
-            SDL.KeycodeRight ->
-              if xpos < 40
-              then
-                xpos + 20
-              else
-                xpos
-            _ -> xpos
-          )
-        "rect"
-        nmap
       putAffection ud
-        { actors = nmap2
+        { keyDown = Nothing
-        , updateActors = (nmap2 M.! "background") : (nmap2 M.! "rect") : updateActors ud
         }
 
 handle (SDL.WindowClosedEvent _) = do

src/Affection.hs

@@ -114,7 +114,7 @@ withAffection AffectionConfig{..} = do
     , drawStack       = []
     , elapsedTime     = 0
     , dt              = 0
-    }) <$> loadState surface
+    }) <$> loadState
   (_, nState) <- runStateT ( A.runState $ do
     preLoop
     whileM_ (do
@@ -128,7 +128,7 @@ withAffection AffectionConfig{..} = do
         -- get state
         ad <- get
         -- clean draw requests from last run
-        mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad)
+        mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad)
         -- clean the renderer form last time
         -- SDL.clear renderer
         -- compute dt and update elapsedTime
@@ -143,23 +143,19 @@ withAffection AffectionConfig{..} = do
         evs <- preHandleEvents =<< liftIO SDL.pollEvents
         MP.mapM_ eventLoop evs
         -- execute user defined update loop
-        updateLoop
+        updateLoop dt
         -- execute user defined draw loop
         drawLoop
         -- handle all new draw requests
         ad2 <- get
         clear <- catMaybes <$>
-          mapM (handleDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad2)
+          mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2)
         -- save all draw requests to clear in next run
         put $ ad2
           { drawStack = clear }
-        -- get texture from surface
-        -- texture <- SDL.createTextureFromSurface (windowRenderer ad2) (drawSurface ad2)
         -- actual drawing
-        SDL.copy (windowRenderer ad2) texture Nothing Nothing
+        -- SDL.copy (windowRenderer ad2) texture Nothing Nothing
         SDL.present (windowRenderer ad2)
-        -- clean the texture
-        -- SDL.destroyTexture texture
         -- save new time
         liftIO $ writeIORef execTime now
       )

src/Affection/Draw.hs

@@ -6,8 +6,9 @@ module Affection.Draw
   , clear
   , handleDrawRequest
   , invalidateDrawRequest
-  , present
   , process
+  , present
+  , render
   , clearArea
   ) where
 
@@ -56,7 +57,13 @@ drawRect node color Fill rect@GeglRectangle{..} buf = do
     { drawStack = DrawRequest rect buf (Kill (Just tempRoot)) : drawStack ad
     }
 
--- | Force update of a specific region on screen
+-- | Process a node graph
+process
+  :: G.GeglNode
+  -> Affection us ()
+process = liftIO . G.gegl_node_process
+
+-- | Update of a specific region on the texture
 present
   :: G.GeglRectangle -- ^ Area to be updated
   -> G.GeglBuffer    -- ^ Target buffer
@@ -69,31 +76,51 @@ present rect buf kill = do
     { drawStack = DrawRequest rect buf k : drawStack ad
     }
 
-process
+-- | Render the Texture or a clipping thereof. The clipping will be stretched
-  :: G.GeglNode
+-- to fit the render target.
+render
+  :: Maybe G.GeglRectangle
+    -- ^ Area of the texture to render.
+    -- Pass 'Nothing' to render the whole texture.
+  -> Maybe G.GeglRectangle
+    -- ^ Area of render target to draw to.
+    -- Pass 'Nothing' to render to the whole render target.
   -> Affection us ()
-process = liftIO . G.gegl_node_process
+render msrc mtgt =
+  do
+    AffectionData{..} <- get
+    SDL.copy
+      windowRenderer
+      drawTexture
+      src
+      tgt
+  where
+    toSdlRect (G.GeglRectangle x y w h) = SDL.Rectangle
+      (SDL.P $ SDL.V2 (CInt $ fromIntegral x) (CInt $ fromIntegral y))
+      (SDL.V2 (CInt $ fromIntegral w) (CInt $ fromIntegral h))
+    src = maybe Nothing (Just . toSdlRect) msrc
+    tgt = maybe Nothing (Just . toSdlRect) mtgt
 
-putToSurface
+-- putToSurface
-  :: Ptr a
+--   :: Ptr a
-  -> G.GeglRectangle
+--   -> G.GeglRectangle
-  -> Int
+--   -> Int
-  -> Int
+--   -> Int
-  -> DrawRequest
+--   -> DrawRequest
-  -> Affection us ()
+--   -> Affection us ()
-putToSurface pixels realRect stride cpp DrawRequest{..} = do
+-- putToSurface pixels realRect stride cpp DrawRequest{..} = do
-  ad <- get
+--   ad <- get
-  liftIO $ SDL.lockSurface $ drawSurface ad
+--   liftIO $ SDL.lockSurface $ drawSurface ad
-  liftIO $ G.gegl_buffer_get
+--   liftIO $ G.gegl_buffer_get
-    requestBuffer
+--     requestBuffer
-    (Just realRect)
+--     (Just realRect)
-    1
+--     1
-    (Just $ drawFormat ad)
+--     (Just $ drawFormat ad)
-    (pixels `plusPtr`
+--     (pixels `plusPtr`
-      (rectangleX realRect * cpp + rectangleY realRect * stride))
+--       (rectangleX realRect * cpp + rectangleY realRect * stride))
-    stride
+--     stride
-    G.GeglAbyssNone
+--     G.GeglAbyssNone
-  liftIO $ SDL.unlockSurface $ drawSurface ad
+--   liftIO $ SDL.unlockSurface $ drawSurface ad
 
 putToTexture
   :: G.GeglRectangle
@@ -140,15 +167,15 @@ putToTexture realRect stride cpp DrawRequest{..} = do
 
 -- | function for handling 'DrawRequest's and updating the output
 handleDrawRequest
-  :: Ptr a           -- ^ Pixel buffer to blit to
+  -- :: Ptr a           -- ^ Pixel buffer to blit to
   -- -> B.BablFormatPtr -- ^ format to blit in
-  -> Int             -- ^ Stride
+  :: Int             -- ^ Stride
   -> Int             -- ^ Components per Pixel
   -> DrawRequest     -- ^ 'DrawRequest' to handle
   -> Affection us (Maybe DrawRequest)
-handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
+handleDrawRequest stride cpp dr@DrawRequest{..} = do
   ad <- get
-  let surf = drawSurface ad
+  -- let surf = drawSurface ad
   mrealRect <- liftIO $ G.gegl_rectangle_intersect
     requestArea
     (uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
@@ -164,13 +191,13 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
 
 -- | clear a previously drawn area
 invalidateDrawRequest
-  :: Ptr a           -- ^ Pixel buffer to blit to
+  -- :: Ptr a           -- ^ Pixel buffer to blit to
   -- -> B.BablFormatPtr -- ^ format to blit in
-  -> Int             -- ^ Stride
+  :: Int             -- ^ Stride
   -> Int             -- ^ Components per Pixel
   -> DrawRequest  -- ^ Drawrequest to invalidate
   -> Affection us ()
-invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
+invalidateDrawRequest stride cpp dr@DrawRequest{..} = do
   ad <- get
   mrealRect <- liftIO $ G.gegl_rectangle_intersect
     requestArea
@@ -243,6 +270,5 @@ clearArea = G.gegl_buffer_clear
 clear :: G.GeglBuffer -> Affection us ()
 clear buffer = do
   ad <- get 
-  SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad
+  let (w, h) = drawDimensions ad
-  let (w, h) = (fromIntegral rw, fromIntegral rh)
   liftIO $ clearArea buffer (GeglRectangle 0 0 w h)

src/Affection/Types.hs

@@ -59,13 +59,13 @@ data AffectionConfig us = AffectionConfig
       -- ^ size of the texture canvas
   , preLoop        :: Affection us ()
       -- ^ Actions to be performed, before loop starts
-  , eventLoop     :: SDL.EventPayload -> Affection us ()
+  , eventLoop      :: SDL.EventPayload -> Affection us ()
       -- ^ Main update function. Takes fractions of a second as input.
   , updateLoop     :: Double -> Affection us ()
       -- ^ Main update function. Takes fractions of a second as input.
   , drawLoop       :: Affection us ()
       -- ^ Function for updating graphics.
-  , loadState      :: SDL.Surface -> IO us
+  , loadState      :: IO us
       -- ^ Provide your own load function to create this data.
   , cleanUp        :: us -> IO ()
       -- ^ Provide your own finisher function to clean your data.
@@ -83,11 +83,11 @@ data AffectionData us = AffectionData
   , userState       :: us                 -- ^ State data provided by user
   , drawWindow      :: SDL.Window         -- ^ SDL 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
   , drawStack       :: [DrawRequest]      -- ^ Stack of 'DrawRequest's to be processed
-  , drawPixels      :: Ptr ()             -- ^ Destination Pixel buffer
+  -- , drawPixels      :: Ptr ()             -- ^ Destination Pixel buffer
   , drawDimensions  :: (Int, Int)         -- ^ Dimensions of target surface
   , drawStride      :: Int                -- ^ Stride of target buffer
   , drawCPP         :: Int                -- ^ Number of components per pixel