From 779de2fcdca7943a4abf4426cb282a9ce9bc4621 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Thu, 6 Jun 2019 04:43:38 +0200
Subject: render: Add SDL_SetRenderTarget bindings.

* sdl2/bindings.scm (SDL_TEXTUREACCESS_STATIC,
  SDL_TEXTUREACCESS_STREAMING, SDL_TEXTUREACCESS_TARGET): New
  variables.
  (sdl-create-texture, sdl-set-render-target, sdl-get-render-target):
  New procedures.
* sdl2/render.scm (symbol->sdl-access-format, make-texture,
  set-render-target!, get-render-target): New procedures.
* doc/api.texi: Document new procedures.
---
 sdl2/bindings.scm | 13 +++++++++++++
 sdl2/render.scm   | 41 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 54 insertions(+)

(limited to 'sdl2')

diff --git a/sdl2/bindings.scm b/sdl2/bindings.scm
index ae7f0d0..2ebc2ed 100644
--- a/sdl2/bindings.scm
+++ b/sdl2/bindings.scm
@@ -240,6 +240,19 @@ RETURN-TYPE and accept arguments of ARG-TYPES."
 (define-foreign sdl-render-copy-ex
   int "SDL_RenderCopyEx" (list '* '* '* '* double '* int))
 
+(define-public SDL_TEXTUREACCESS_STATIC    0)
+(define-public SDL_TEXTUREACCESS_STREAMING 1)
+(define-public SDL_TEXTUREACCESS_TARGET    2)
+
+(define-foreign sdl-create-texture
+  '* "SDL_CreateTexture" (list '* uint32 int int int))
+
+(define-foreign sdl-set-render-target
+  int "SDL_SetRenderTarget" '(* *))
+
+(define-foreign sdl-get-render-target
+  '* "SDL_GetRenderTarget" '(*))
+
 (define-foreign sdl-create-texture-from-surface
   '* "SDL_CreateTextureFromSurface" '(* *))
 
diff --git a/sdl2/render.scm b/sdl2/render.scm
index 6504ce9..57a0e17 100644
--- a/sdl2/render.scm
+++ b/sdl2/render.scm
@@ -38,6 +38,8 @@
             clear-renderer
             present-renderer
             render-copy
+            set-render-target!
+            get-render-target
             set-render-draw-color
             render-draw-line
             render-draw-lines
@@ -48,6 +50,7 @@
             render-fill-rect
             render-fill-rects
 
+            make-texture
             delete-texture!
             surface->texture))
 
@@ -203,6 +206,25 @@ color."
     (format port "#<texture ~x>"
             (pointer-address (unwrap-texture context)))))
 
+(define (make-texture renderer format access width height)
+  "Returns a new texture for RENDERER with pixel FORMAT.
+ACCESS is one of the symbols:
+
+* static: changes rarely, not lockable
+* streaming: changes frequently, lockable
+* target: can be used as a render target (requires that renderer was
+created with 'texture')"
+  (let ((ptr (ffi:sdl-create-texture (unwrap-renderer renderer)
+                                     ((@@ (sdl2 surface) symbol->sdl-pixel-format) format)
+                                     (match access
+                                       ('static    ffi:SDL_TEXTUREACCESS_STATIC)
+                                       ('streaming ffi:SDL_TEXTUREACCESS_STREAMING)
+                                       ('target    ffi:SDL_TEXTUREACCESS_TARGET))
+                                     width height)))
+    (if (null-pointer? ptr)
+        (sdl-error "make-texture" "Failed to create texture")
+        (wrap-texture ptr))))
+
 (define (surface->texture renderer surface)
   "Convert SURFACE to a texture suitable for RENDERER."
   (let ((ptr (ffi:sdl-create-texture-from-surface
@@ -235,3 +257,22 @@ color."
                  0)))
     (unless (zero? result)
       (sdl-error "render-copy" "failed to copy texture"))))
+
+(define (set-render-target! renderer texture)
+  "Sets the render target for RENDERER to TEXTURE, making all comming draw
+requests redirect to TEXTURE.
+
+Pass #f to reset it to the default target."
+  (let ((result (ffi:sdl-set-render-target
+          (unwrap-renderer renderer)
+          (if texture
+              (unwrap-texture texture)
+              %null-pointer))))
+    (unless (zero? result)
+      (sdl-error "set-render-target!" "failed to set render target"))))
+
+(define (get-render-target renderer)
+  "Returns the current render target of RENDERER. #f if it's a texture."
+  (let ((ptr (ffi:sdl-get-render-target (unwrap-renderer renderer))))
+    (if (null-pointer? ptr)
+        #f (wrap-texture ptr))))
-- 
cgit v1.2.3