render: Add SDL_SetRenderTarget bindings.
[guile-sdl2.git] / sdl2 / render.scm
1 ;;; guile-sdl2 --- FFI bindings for SDL2
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;; Copyright © 2019 Pierre-Antoine Rouby <contact@parouby.fr>
4 ;;;
5 ;;; This file is part of guile-sdl2.
6 ;;;
7 ;;; Guile-sdl2 is free software; you can redistribute it and/or modify
8 ;;; it under the terms of the GNU Lesser General Public License as
9 ;;; published by the Free Software Foundation; either version 3 of the
10 ;;; License, or (at your option) any later version.
11 ;;;
12 ;;; Guile-sdl2 is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;; General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU Lesser General Public
18 ;;; License along with guile-sdl2. If not, see
19 ;;; <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22 ;;
23 ;; SDL 2D accelerated rendering.
24 ;;
25 ;;; Code:
26
27 (define-module (sdl2 render)
28 #:use-module (ice-9 format)
29 #:use-module (ice-9 match)
30 #:use-module (system foreign)
31 #:use-module (rnrs bytevectors)
32 #:use-module (sdl2)
33 #:use-module ((sdl2 bindings) #:prefix ffi:)
34 #:export (make-renderer
35 renderer?
36 delete-renderer!
37 call-with-renderer
38 clear-renderer
39 present-renderer
40 render-copy
41 set-render-target!
42 get-render-target
43 set-render-draw-color
44 render-draw-line
45 render-draw-lines
46 render-draw-point
47 render-draw-points
48 render-draw-rect
49 render-draw-rects
50 render-fill-rect
51 render-fill-rects
52
53 make-texture
54 delete-texture!
55 surface->texture))
56
57 \f
58 ;;;
59 ;;; Renderer
60 ;;;
61
62 (define-wrapped-pointer-type <renderer>
63 renderer?
64 wrap-renderer unwrap-renderer
65 (lambda (context port)
66 (format port "#<renderer ~x>"
67 (pointer-address (unwrap-renderer context)))))
68
69 (define (renderer-flags->bitmask flags)
70 (apply logior
71 (map (match-lambda
72 ('software ffi:SDL_RENDERER_SOFTWARE)
73 ('accelerated ffi:SDL_RENDERER_ACCELERATED)
74 ('vsync ffi:SDL_RENDERER_PRESENTVSYNC)
75 ('texture ffi:SDL_RENDERER_TARGETTEXTURE))
76 flags)))
77
78 (define* (make-renderer window #:optional (flags '(accelerated vsync)))
79 "Return a new renderer for WINDOW created with the options specified
80 in FLAGS, a list of symbols. The valid symbols that may appear in
81 FLAGS are:
82
83 * software, to use a software renderer fallback
84 * accelerated, to use hardware acceleration
85 * vsync, to synchronize rendering with the monitor's refresh rate
86 * texture, for render to texture support"
87 (let ((ptr (ffi:sdl-create-renderer ((@@ (sdl2 video) unwrap-window)
88 window)
89 -1 ; pick driver automatically
90 (renderer-flags->bitmask flags))))
91 (if (null-pointer? ptr)
92 (sdl-error "make-renderer" "failed to create renderer")
93 (wrap-renderer ptr))))
94
95 (define (delete-renderer! renderer)
96 "Delete the rendering context RENDERER."
97 (ffi:sdl-destroy-renderer (unwrap-renderer renderer)))
98
99 (define (call-with-renderer renderer proc)
100 "Call PROC, passing it RENDERER and closing RENDERER upon exit of
101 PROC."
102 (dynamic-wind
103 (const #t)
104 (lambda ()
105 (proc renderer))
106 (lambda ()
107 (delete-renderer! renderer))))
108
109 (define (clear-renderer renderer)
110 "Clear the rendering target RENDERER with the current drawing
111 color."
112 (unless (zero? (ffi:sdl-render-clear (unwrap-renderer renderer)))
113 (sdl-error "clear-renderer!" "failed to clear renderer")))
114
115 (define (present-renderer renderer)
116 "Display RENDERER."
117 (ffi:sdl-render-present (unwrap-renderer renderer)))
118
119 (define (set-render-draw-color renderer r g b a)
120 "Set draw color of RENDERER."
121 (ffi:sdl-set-render-draw-color (unwrap-renderer renderer) r g b a))
122
123 (define (render-draw-line renderer x1 y1 x2 y2)
124 "Draw line on RENDERER."
125 (ffi:sdl-render-draw-line (unwrap-renderer renderer) x1 y1 x2 y2))
126
127 (define (render-draw-lines renderer points)
128 "Draw lines connecting POINTS on RENDERER."
129 (define (fill-bv bv l n)
130 (match l
131 (() bv)
132 (((x y) . r)
133 (s32vector-set! bv n x)
134 (s32vector-set! bv (+ n 1) y)
135 (fill-bv bv r (+ 2 n)))))
136 (let* ((count (length points))
137 (bv (fill-bv (make-s32vector (* count 2)) points 0)))
138 (ffi:sdl-render-draw-lines (unwrap-renderer renderer)
139 (bytevector->pointer bv)
140 count)))
141
142 (define (render-draw-point renderer x y)
143 "Draw point on RENDERER."
144 (ffi:sdl-render-draw-point (unwrap-renderer renderer) x y))
145
146 (define (render-draw-points renderer points)
147 "Draw POINTS on RENDERER."
148 (define (fill-bv bv l n)
149 (match l
150 (() bv)
151 (((x y) . r)
152 (s32vector-set! bv n x)
153 (s32vector-set! bv (+ n 1) y)
154 (fill-bv bv r (+ 2 n)))))
155 (let* ((count (length points))
156 (bv (fill-bv (make-s32vector (* count 2)) points 0)))
157 (ffi:sdl-render-draw-points (unwrap-renderer renderer)
158 (bytevector->pointer bv)
159 count)))
160
161 (define (render-draw-rect renderer rect)
162 "Draw RECT on RENDERER."
163 (ffi:sdl-render-draw-rect
164 (unwrap-renderer renderer)
165 ((@@ (sdl2 rect) unwrap-rect) rect)))
166
167 (define (render-draw-rects renderer rects)
168 "Draw RECTS on RENDERER."
169 (let* ((count (length rects))
170 (bv (make-s32vector (* count 4))))
171 (for-each (lambda (rect i)
172 (bytevector-copy! ((@@ (sdl2 rect) rect-bv) rect) 0
173 bv (* i 4 4) (* 4 4)))
174 rects (iota count))
175 (ffi:sdl-render-draw-rects (unwrap-renderer renderer)
176 (bytevector->pointer bv)
177 count)))
178
179 (define (render-fill-rect renderer rect)
180 "Fill RECT on RENDERER."
181 (ffi:sdl-render-fill-rect
182 (unwrap-renderer renderer)
183 ((@@ (sdl2 rect) unwrap-rect) rect)))
184
185 (define (render-fill-rects renderer rects)
186 "Fill RECTS on RENDERER."
187 (let* ((count (length rects))
188 (bv (make-s32vector (* count 4))))
189 (for-each (lambda (rect i)
190 (bytevector-copy! ((@@ (sdl2 rect) rect-bv) rect) 0
191 bv (* i 4 4) (* 4 4)))
192 rects (iota count))
193 (ffi:sdl-render-fill-rects (unwrap-renderer renderer)
194 (bytevector->pointer bv)
195 count)))
196
197 \f
198 ;;;
199 ;;; Texture
200 ;;;
201
202 (define-wrapped-pointer-type <texture>
203 texture?
204 wrap-texture unwrap-texture
205 (lambda (context port)
206 (format port "#<texture ~x>"
207 (pointer-address (unwrap-texture context)))))
208
209 (define (make-texture renderer format access width height)
210 "Returns a new texture for RENDERER with pixel FORMAT.
211 ACCESS is one of the symbols:
212
213 * static: changes rarely, not lockable
214 * streaming: changes frequently, lockable
215 * target: can be used as a render target (requires that renderer was
216 created with 'texture')"
217 (let ((ptr (ffi:sdl-create-texture (unwrap-renderer renderer)
218 ((@@ (sdl2 surface) symbol->sdl-pixel-format) format)
219 (match access
220 ('static ffi:SDL_TEXTUREACCESS_STATIC)
221 ('streaming ffi:SDL_TEXTUREACCESS_STREAMING)
222 ('target ffi:SDL_TEXTUREACCESS_TARGET))
223 width height)))
224 (if (null-pointer? ptr)
225 (sdl-error "make-texture" "Failed to create texture")
226 (wrap-texture ptr))))
227
228 (define (surface->texture renderer surface)
229 "Convert SURFACE to a texture suitable for RENDERER."
230 (let ((ptr (ffi:sdl-create-texture-from-surface
231 (unwrap-renderer renderer)
232 ((@@ (sdl2 surface) unwrap-surface) surface))))
233 (if (null-pointer? ptr)
234 (sdl-error "surface->texture" "failed to convert surface to texture")
235 (wrap-texture ptr))))
236
237 (define (delete-texture! texture)
238 "Free the memory used by TEXTURE."
239 (ffi:sdl-destroy-texture (unwrap-texture texture)))
240
241 (define* (render-copy renderer texture
242 #:key (angle 0) srcrect dstrect center)
243 "Copy TEXTURE to the rendering target of RENDERER."
244 (let ((result (ffi:sdl-render-copy-ex
245 (unwrap-renderer renderer)
246 (unwrap-texture texture)
247 (if srcrect
248 (make-c-struct ffi:sdl-rect srcrect)
249 %null-pointer)
250 (if dstrect
251 (make-c-struct ffi:sdl-rect dstrect)
252 %null-pointer)
253 angle
254 (if center
255 (make-c-struct ffi:sdl-point center)
256 %null-pointer)
257 0)))
258 (unless (zero? result)
259 (sdl-error "render-copy" "failed to copy texture"))))
260
261 (define (set-render-target! renderer texture)
262 "Sets the render target for RENDERER to TEXTURE, making all comming draw
263 requests redirect to TEXTURE.
264
265 Pass #f to reset it to the default target."
266 (let ((result (ffi:sdl-set-render-target
267 (unwrap-renderer renderer)
268 (if texture
269 (unwrap-texture texture)
270 %null-pointer))))
271 (unless (zero? result)
272 (sdl-error "set-render-target!" "failed to set render target"))))
273
274 (define (get-render-target renderer)
275 "Returns the current render target of RENDERER. #f if it's a texture."
276 (let ((ptr (ffi:sdl-get-render-target (unwrap-renderer renderer))))
277 (if (null-pointer? ptr)
278 #f (wrap-texture ptr))))