render: Add SDL_RenderDrawLines binding.
[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 (sdl2)
32 #:use-module ((sdl2 bindings) #:prefix ffi:)
33 #:export (make-renderer
34 renderer?
35 delete-renderer!
36 call-with-renderer
37 clear-renderer
38 present-renderer
39 render-copy
40 set-render-draw-color
41 render-draw-line
42 render-draw-lines
43 render-draw-point
44 render-draw-points
45
46 delete-texture!
47 surface->texture))
48
49 \f
50 ;;;
51 ;;; Renderer
52 ;;;
53
54 (define-wrapped-pointer-type <renderer>
55 renderer?
56 wrap-renderer unwrap-renderer
57 (lambda (context port)
58 (format port "#<renderer ~x>"
59 (pointer-address (unwrap-renderer context)))))
60
61 (define (renderer-flags->bitmask flags)
62 (apply logior
63 (map (match-lambda
64 ('software ffi:SDL_RENDERER_SOFTWARE)
65 ('accelerated ffi:SDL_RENDERER_ACCELERATED)
66 ('vsync ffi:SDL_RENDERER_PRESENTVSYNC)
67 ('texture ffi:SDL_RENDERER_TARGETTEXTURE))
68 flags)))
69
70 (define* (make-renderer window #:optional (flags '(accelerated vsync)))
71 "Return a new renderer for WINDOW created with the options specified
72 in FLAGS, a list of symbols. The valid symbols that may appear in
73 FLAGS are:
74
75 * software, to use a software renderer fallback
76 * accelerated, to use hardware acceleration
77 * vsync, to synchronize rendering with the monitor's refresh rate
78 * texture, for render to texture support"
79 (let ((ptr (ffi:sdl-create-renderer ((@@ (sdl2 video) unwrap-window)
80 window)
81 -1 ; pick driver automatically
82 (renderer-flags->bitmask flags))))
83 (if (null-pointer? ptr)
84 (sdl-error "make-renderer" "failed to create renderer")
85 (wrap-renderer ptr))))
86
87 (define (delete-renderer! renderer)
88 "Delete the rendering context RENDERER."
89 (ffi:sdl-destroy-renderer (unwrap-renderer renderer)))
90
91 (define (call-with-renderer renderer proc)
92 "Call PROC, passing it RENDERER and closing RENDERER upon exit of
93 PROC."
94 (dynamic-wind
95 (const #t)
96 (lambda ()
97 (proc renderer))
98 (lambda ()
99 (delete-renderer! renderer))))
100
101 (define (clear-renderer renderer)
102 "Clear the rendering target RENDERER with the current drawing
103 color."
104 (unless (zero? (ffi:sdl-render-clear (unwrap-renderer renderer)))
105 (sdl-error "clear-renderer!" "failed to clear renderer")))
106
107 (define (present-renderer renderer)
108 "Display RENDERER."
109 (ffi:sdl-render-present (unwrap-renderer renderer)))
110
111 (define (set-render-draw-color renderer r g b a)
112 "Set draw color of RENDERER."
113 (ffi:sdl-set-render-draw-color (unwrap-renderer renderer) r g b a))
114
115 (define (render-draw-line renderer x1 y1 x2 y2)
116 "Draw line on RENDERER."
117 (ffi:sdl-render-draw-line (unwrap-renderer renderer) x1 y1 x2 y2))
118
119 (define (render-draw-lines renderer points)
120 "Draw lines connecting POINTS on RENDERER."
121 (define (fill-bv bv l n)
122 (match l
123 (() bv)
124 (((x y) . r)
125 (s32vector-set! bv n x)
126 (s32vector-set! bv (+ n 1) y)
127 (fill-bv bv r (+ 2 n)))))
128 (let* ((count (length points))
129 (bv (fill-bv (make-s32vector (* count 2)) points 0)))
130 (ffi:sdl-render-draw-lines (unwrap-renderer renderer)
131 (bytevector->pointer bv)
132 count)))
133
134 (define (render-draw-point renderer x y)
135 "Draw point on RENDERER."
136 (ffi:sdl-render-draw-point (unwrap-renderer renderer) x y))
137
138 (define (render-draw-points renderer points)
139 "Draw POINTS on RENDERER."
140 (define (fill-bv bv l n)
141 (match l
142 (() bv)
143 (((x y) . r)
144 (s32vector-set! bv n x)
145 (s32vector-set! bv (+ n 1) y)
146 (fill-bv bv r (+ 2 n)))))
147 (let* ((count (length points))
148 (bv (fill-bv (make-s32vector (* count 2)) points 0)))
149 (ffi:sdl-render-draw-points (unwrap-renderer renderer)
150 (bytevector->pointer bv)
151 count)))
152
153 \f
154 ;;;
155 ;;; Texture
156 ;;;
157
158 (define-wrapped-pointer-type <texture>
159 texture?
160 wrap-texture unwrap-texture
161 (lambda (context port)
162 (format port "#<texture ~x>"
163 (pointer-address (unwrap-texture context)))))
164
165 (define (surface->texture renderer surface)
166 "Convert SURFACE to a texture suitable for RENDERER."
167 (let ((ptr (ffi:sdl-create-texture-from-surface
168 (unwrap-renderer renderer)
169 ((@@ (sdl2 surface) unwrap-surface) surface))))
170 (if (null-pointer? ptr)
171 (sdl-error "surface->texture" "failed to convert surface to texture")
172 (wrap-texture ptr))))
173
174 (define (delete-texture! texture)
175 "Free the memory used by TEXTURE."
176 (ffi:sdl-destroy-texture (unwrap-texture texture)))
177
178 (define* (render-copy renderer texture
179 #:key (angle 0) srcrect dstrect center)
180 "Copy TEXTURE to the rendering target of RENDERER."
181 (let ((result (ffi:sdl-render-copy-ex
182 (unwrap-renderer renderer)
183 (unwrap-texture texture)
184 (if srcrect
185 (make-c-struct ffi:sdl-rect srcrect)
186 %null-pointer)
187 (if dstrect
188 (make-c-struct ffi:sdl-rect dstrect)
189 %null-pointer)
190 angle
191 (if center
192 (make-c-struct ffi:sdl-point center)
193 %null-pointer)
194 0)))
195 (unless (zero? result)
196 (sdl-error "render-copy" "failed to copy texture"))))