surface: Add SDL_FillRect binding.
[guile-sdl2.git] / sdl2 / surface.scm
1 ;;; guile-sdl2 --- FFI bindings for SDL2
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; This file is part of guile-sdl2.
5 ;;;
6 ;;; Guile-sdl2 is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation; either version 3 of the
9 ;;; License, or (at your option) any later version.
10 ;;;
11 ;;; Guile-sdl2 is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with guile-sdl2. If not, see
18 ;;; <http://www.gnu.org/licenses/>.
19
20 ;;; Commentary:
21 ;;
22 ;; SDL surface manipulation.
23 ;;
24 ;;; Code:
25
26 (define-module (sdl2 surface)
27 #:use-module (ice-9 format)
28 #:use-module (ice-9 match)
29 #:use-module (rnrs bytevectors)
30 #:use-module (srfi srfi-4)
31 #:use-module (srfi srfi-9)
32 #:use-module (system foreign)
33 #:use-module ((sdl2 bindings) #:prefix ffi:)
34 #:use-module (sdl2)
35 #:export (color?
36 color-r
37 color-g
38 color-b
39 color-a
40
41 palette?
42 palette-length
43 palette-colors
44
45 pixel-format?
46 pixel-format-name
47 pixel-format-palette
48 pixel-format-bits-per-pixel
49 pixel-format-bytes-per-pixel
50 pixel-format-red-mask
51 pixel-format-green-mask
52 pixel-format-blue-mask
53 pixel-format-alpha-mask
54
55 make-rgb-surface
56 bytevector->surface
57 surface?
58 delete-surface!
59 call-with-surface
60 load-bmp
61 surface-pixel-format
62 surface-width
63 surface-height
64 surface-pitch
65 surface-pixels
66 convert-surface-format
67 blit-surface
68 blit-scaled
69 fill-rect))
70
71 \f
72 ;;;
73 ;;; Color
74 ;;;
75
76 (define-record-type <color>
77 (make-color r g b a)
78 color?
79 (r color-r)
80 (g color-g)
81 (b color-b)
82 (a color-a))
83
84 \f
85 ;;;
86 ;;; Palette
87 ;;;
88
89 (define-wrapped-pointer-type <palette>
90 palette?
91 wrap-palette unwrap-palette
92 (lambda (palette port)
93 (format port "#<palette length: ~d>"
94 (palette-length palette))))
95
96 (define %palette-types
97 (list int ; number of colors
98 '*)) ; colors
99
100 (define-syntax-rule (palette-parse-match palette matchers ...)
101 (match (parse-c-struct (unwrap-palette palette) %palette-types)
102 matchers ...))
103
104 (define (palette-length palette)
105 "Return the number of colors in PALETTE."
106 (palette-parse-match palette
107 ((length _) length)))
108
109 (define (palette-colors palette)
110 "Return the colors in PALETTE."
111 (palette-parse-match palette
112 ((length colors)
113 (let ((bv (pointer->bytevector colors (* length 4)))
114 (colors (make-vector length)))
115 (let loop ((i 0))
116 (if (< i length)
117 (let ((offset (* i 4)))
118 (vector-set! colors i
119 (make-color (u8vector-ref bv offset)
120 (u8vector-ref bv (+ offset 1))
121 (u8vector-ref bv (+ offset 2))
122 (u8vector-ref bv (+ offset 3))))
123 (loop (1+ i)))
124 colors))))))
125
126 \f
127 ;;;
128 ;;; Pixel Format
129 ;;;
130
131 (define-wrapped-pointer-type <pixel-format>
132 pixel-format?
133 wrap-pixel-format unwrap-pixel-format
134 (lambda (pf port)
135 (format port "#<pixel-format name: ~s bpp: ~d>"
136 (pixel-format-name pf)
137 (pixel-format-bytes-per-pixel pf))))
138
139 (define %pixel-format-types
140 (list uint32 ; format
141 '* ; palette
142 uint8 ; bits per pixel
143 uint8 ; bytes per pixel
144 uint32 ; red mask
145 uint32 ; green mask
146 uint32 ; blue mask
147 uint32)) ; alpha mask
148
149 (define-syntax-rule (pixel-format-parse-match pf matchers ...)
150 (match (parse-c-struct (unwrap-pixel-format pf) %pixel-format-types)
151 matchers ...))
152
153 (define (pixel-format-name pf)
154 "Return the symbolic name of the pixel format PF."
155 (pixel-format-parse-match pf
156 ((format _ _ _ _ _ _ _)
157 (cond
158 ((= format ffi:SDL_PIXELFORMAT_INDEX1LSB) 'index1lsb)
159 ((= format ffi:SDL_PIXELFORMAT_INDEX1MSB) 'index1msb)
160 ((= format ffi:SDL_PIXELFORMAT_INDEX4LSB) 'index4lsb)
161 ((= format ffi:SDL_PIXELFORMAT_INDEX4MSB) 'index4msb)
162 ((= format ffi:SDL_PIXELFORMAT_INDEX8) 'index8)
163 ((= format ffi:SDL_PIXELFORMAT_RGB332) 'rgb332)
164 ((= format ffi:SDL_PIXELFORMAT_RGB444) 'rgb444)
165 ((= format ffi:SDL_PIXELFORMAT_RGB555) 'rgb555)
166 ((= format ffi:SDL_PIXELFORMAT_BGR555) 'bgr555)
167 ((= format ffi:SDL_PIXELFORMAT_ARGB4444) 'argb4444)
168 ((= format ffi:SDL_PIXELFORMAT_RGBA4444) 'rgba4444)
169 ((= format ffi:SDL_PIXELFORMAT_ABGR4444) 'abgr4444)
170 ((= format ffi:SDL_PIXELFORMAT_BGRA4444) 'bgra4444)
171 ((= format ffi:SDL_PIXELFORMAT_ARGB1555) 'argb1555)
172 ((= format ffi:SDL_PIXELFORMAT_RGBA5551) 'rgba5551)
173 ((= format ffi:SDL_PIXELFORMAT_ABGR1555) 'abgr1555)
174 ((= format ffi:SDL_PIXELFORMAT_BGRA5551) 'bgra5551)
175 ((= format ffi:SDL_PIXELFORMAT_RGB565) 'rgb565)
176 ((= format ffi:SDL_PIXELFORMAT_BGR565) 'bgr565)
177 ((= format ffi:SDL_PIXELFORMAT_RGB24) 'rgb24)
178 ((= format ffi:SDL_PIXELFORMAT_BGR24) 'bgr24)
179 ((= format ffi:SDL_PIXELFORMAT_RGB888) 'rgb888)
180 ((= format ffi:SDL_PIXELFORMAT_RGBX8888) 'rgbx8888)
181 ((= format ffi:SDL_PIXELFORMAT_BGR888) 'bgr888)
182 ((= format ffi:SDL_PIXELFORMAT_BGRX8888) 'bgrx8888)
183 ((= format ffi:SDL_PIXELFORMAT_ARGB8888) 'argb8888)
184 ((= format ffi:SDL_PIXELFORMAT_RGBA8888) 'rgba8888)
185 ((= format ffi:SDL_PIXELFORMAT_ABGR8888) 'abgr8888)
186 ((= format ffi:SDL_PIXELFORMAT_BGRA8888) 'bgra8888)
187 ((= format ffi:SDL_PIXELFORMAT_ARGB2101010) 'argb2101010)
188 ((= format ffi:SDL_PIXELFORMAT_YV12) 'yv12)
189 ((= format ffi:SDL_PIXELFORMAT_IYUV) 'iyuv)
190 ((= format ffi:SDL_PIXELFORMAT_YUY2) 'yuy2)
191 ((= format ffi:SDL_PIXELFORMAT_UYVY) 'uyvy)
192 ((= format ffi:SDL_PIXELFORMAT_YVYU) 'yvyu)))))
193
194 (define (pixel-format-palette pf)
195 "Return the palette for the pixel format PF."
196 (pixel-format-parse-match pf
197 ((_ palette _ _ _ _ _ _)
198 (if (null-pointer? palette)
199 #f
200 (wrap-palette palette)))))
201
202 (define (pixel-format-bits-per-pixel pf)
203 "Return the number of bits per pixel for the pixel format PF."
204 (pixel-format-parse-match pf
205 ((_ _ bits _ _ _ _ _) bits)))
206
207 (define (pixel-format-bytes-per-pixel pf)
208 "Return the number of bytes per pixel for the pixel format PF."
209 (pixel-format-parse-match pf
210 ((_ _ _ bytes _ _ _ _) bytes)))
211
212 (define (pixel-format-red-mask pf)
213 "Return the bitmask for the red component of a pixel in the pixel
214 format PF."
215 (pixel-format-parse-match pf
216 ((_ _ _ _ red-mask _ _ _) red-mask)))
217
218 (define (pixel-format-green-mask pf)
219 "Return the bitmask for the green component of a pixel in the pixel
220 format PF."
221 (pixel-format-parse-match pf
222 ((_ _ _ _ _ green-mask _ _) green-mask)))
223
224 (define (pixel-format-blue-mask pf)
225 "Return the bitmask for the blue component of a pixel in the pixel
226 format PF."
227 (pixel-format-parse-match pf
228 ((_ _ _ _ _ _ blue-mask _) blue-mask)))
229
230 (define (pixel-format-alpha-mask pf)
231 "Return the bitmask for the alpha component of a pixel in the pixel
232 format PF."
233 (pixel-format-parse-match pf
234 ((_ _ _ _ _ _ _ alpha-mask) alpha-mask)))
235
236 \f
237 ;;;
238 ;;; Surface
239 ;;;
240
241 (define-wrapped-pointer-type <surface>
242 surface?
243 wrap-surface unwrap-surface
244 (lambda (surface port)
245 (format port "#<surface ~x>"
246 (pointer-address (unwrap-surface surface)))))
247
248 (define (make-rgb-surface width height depth)
249 "Create a new SDL surface with the dimensions WIDTH and HEIGHT and
250 DEPTH bits per pixel."
251 (wrap-surface
252 (if (eq? (native-endianness) 'big)
253 (ffi:sdl-create-rgb-surface 0 width height depth
254 #xff000000
255 #x00ff0000
256 #x0000ff00
257 #x000000ff)
258 (ffi:sdl-create-rgb-surface 0 width height depth
259 #x000000ff
260 #x0000ff00
261 #x00ff0000
262 #xff000000))))
263
264 (define (bytevector->surface bv width height depth pitch)
265 "Convert BV, a bytevector of pixel data with dimenions WIDTHxHEIGHT,
266 to an SDL surface. Each pixel is DEPTH bits in size, and each row of
267 pixels is PITCH bytes in size."
268 (wrap-surface
269 (if (eq? (native-endianness) 'big)
270 (ffi:sdl-create-rgb-surface-from (bytevector->pointer bv)
271 width height depth pitch
272 #xff000000
273 #x00ff0000
274 #x0000ff00
275 #x000000ff)
276 (ffi:sdl-create-rgb-surface-from (bytevector->pointer bv)
277 width height depth pitch
278 #x000000ff
279 #x0000ff00
280 #x00ff0000
281 #xff000000))))
282
283 (define (delete-surface! surface)
284 "Free the memory used by SURFACE."
285 (ffi:sdl-free-surface (unwrap-surface surface)))
286
287 (define (call-with-surface surface proc)
288 "Call PROC, passing it SURFACE and deleting SURFACE upon exit of
289 PROC."
290 (dynamic-wind
291 (const #t)
292 (lambda ()
293 (proc surface))
294 (lambda ()
295 (delete-surface! surface))))
296
297 ;; The equivalent of the SDL_LoadBMP C macro.
298 (define (load-bmp file)
299 "Create a new surface from the bitmap data in FILE."
300 (let ((ptr (ffi:sdl-load-bmp-rw (ffi:sdl-rw-from-file (string->pointer file)
301 (string->pointer "rb"))
302 1)))
303 (if (null-pointer? ptr)
304 (sdl-error "load-bmp" "failed to load bitmap")
305 (wrap-surface ptr))))
306
307 (define %int-size (sizeof int))
308 (define %pointer-size (sizeof '*))
309
310 (define (pointer-int-ref pointer offset)
311 (bytevector-sint-ref (pointer->bytevector pointer %int-size offset)
312 0 (native-endianness) %int-size))
313
314 ;; A partial list of surface types so that we can parse the data we
315 ;; need out of the SDL_Surface struct pointer.
316 (define %surface-types
317 (list uint32 ; flags
318 '* ; format
319 int ; width
320 int ; height
321 int ; pitch
322 '*)) ; pixels
323
324 (define-syntax-rule (surface-parse-match surface matchers ...)
325 (match (parse-c-struct (unwrap-surface surface) %surface-types)
326 matchers ...))
327
328 (define (surface-width surface)
329 "Return the width of SURFACE in pixels."
330 (surface-parse-match surface
331 ((_ _ width _ _ _) width)))
332
333 (define (surface-height surface)
334 "Return the height of SURFACE in pixels."
335 (surface-parse-match surface
336 ((_ _ _ height _ _) height)))
337
338 (define (surface-pitch surface)
339 "Return the length of a row of pixels in SURFACE in bytes."
340 (surface-parse-match surface
341 ((_ _ _ _ pitch _) pitch)))
342
343 (define (surface-pixels surface)
344 "Return a bytevector containing the raw pixel data in SURFACE."
345 (surface-parse-match surface
346 ((_ _ _ height pitch pixels)
347 (pointer->bytevector pixels (* height pitch)))))
348
349 (define (surface-pixel-format surface)
350 "Return the pixel format for SURFACE."
351 (surface-parse-match surface
352 ((_ format _ _ _ _)
353 (wrap-pixel-format format))))
354
355 (define (symbol->sdl-pixel-format sym)
356 (match sym
357 ('index1lsb ffi:SDL_PIXELFORMAT_INDEX1LSB)
358 ('index1msb ffi:SDL_PIXELFORMAT_INDEX1MSB)
359 ('index4lsb ffi:SDL_PIXELFORMAT_INDEX4LSB)
360 ('index4msb ffi:SDL_PIXELFORMAT_INDEX4MSB)
361 ('index8 ffi:SDL_PIXELFORMAT_INDEX8)
362 ('rgb332 ffi:SDL_PIXELFORMAT_RGB332)
363 ('rgb444 ffi:SDL_PIXELFORMAT_RGB444)
364 ('rgb555 ffi:SDL_PIXELFORMAT_RGB555)
365 ('bgr555 ffi:SDL_PIXELFORMAT_BGR555)
366 ('argb4444 ffi:SDL_PIXELFORMAT_ARGB4444)
367 ('rgba4444 ffi:SDL_PIXELFORMAT_RGBA4444)
368 ('abgr4444 ffi:SDL_PIXELFORMAT_ABGR4444)
369 ('bgra4444 ffi:SDL_PIXELFORMAT_BGRA4444)
370 ('argb1555 ffi:SDL_PIXELFORMAT_ARGB1555)
371 ('rgba5551 ffi:SDL_PIXELFORMAT_RGBA5551)
372 ('abgr1555 ffi:SDL_PIXELFORMAT_ABGR1555)
373 ('bgra5551 ffi:SDL_PIXELFORMAT_BGRA5551)
374 ('rgb565 ffi:SDL_PIXELFORMAT_RGB565)
375 ('bgr565 ffi:SDL_PIXELFORMAT_BGR565)
376 ('rgb24 ffi:SDL_PIXELFORMAT_RGB24)
377 ('bgr24 ffi:SDL_PIXELFORMAT_BGR24)
378 ('rgb888 ffi:SDL_PIXELFORMAT_RGB888)
379 ('rgbx8888 ffi:SDL_PIXELFORMAT_RGBX8888)
380 ('bgr888 ffi:SDL_PIXELFORMAT_BGR888)
381 ('bgrx8888 ffi:SDL_PIXELFORMAT_BGRX8888)
382 ('argb8888 ffi:SDL_PIXELFORMAT_ARGB8888)
383 ('rgba8888 ffi:SDL_PIXELFORMAT_RGBA8888)
384 ('abgr8888 ffi:SDL_PIXELFORMAT_ABGR8888)
385 ('bgra8888 ffi:SDL_PIXELFORMAT_BGRA8888)
386 ('argb2101010 ffi:SDL_PIXELFORMAT_ARGB2101010)
387 ('yv12 ffi:SDL_PIXELFORMAT_YV12)
388 ('iyuv ffi:SDL_PIXELFORMAT_IYUV)
389 ('yuy2 ffi:SDL_PIXELFORMAT_YUY2)
390 ('uyvy ffi:SDL_PIXELFORMAT_UYVY)
391 ('yvyu ffi:SDL_PIXELFORMAT_YVYU)))
392
393 (define (convert-surface-format surface format)
394 "Convert the pixels in SURFACE to FORMAT, a symbol representing a
395 specific pixel format, and return a new surface object.
396
397 Valid format types are:
398
399 - index1lsb
400 - index1msb
401 - index4lsb
402 - index4msb
403 - index8
404 - rgb332
405 - rgb444
406 - rgb555
407 - bgr555
408 - argb4444
409 - rgba4444
410 - abgr4444
411 - bgra4444
412 - argb1555
413 - rgba5551
414 - abgr1555
415 - bgra5551
416 - rgb565
417 - bgr565
418 - rgb24
419 - bgr24
420 - rgb888
421 - rgbx8888
422 - bgr888
423 - bgrx8888
424 - argb8888
425 - rgba8888
426 - abgr8888
427 - bgra8888
428 - argb2101010
429 - yv12
430 - iyuv
431 - yuy2
432 - uyvy
433 - yvyu"
434 (let ((ptr (ffi:sdl-convert-surface-format (unwrap-surface surface)
435 (symbol->sdl-pixel-format format)
436 0)))
437 (if (null-pointer? ptr)
438 (sdl-error "convert-surface-format" "failed to convert surface format")
439 (wrap-surface ptr))))
440
441 (define (blit-surface src src-rect dst dst-rect)
442 "Blit the rectangle SRC-RECT from the surface SRC to DST-RECT of the
443 surface DST."
444 (unless (zero?
445 (ffi:sdl-blit-surface (unwrap-surface src)
446 (if src-rect
447 ((@@ (sdl2 rect) unwrap-rect) src-rect)
448 %null-pointer)
449 (unwrap-surface dst)
450 (if dst-rect
451 ((@@ (sdl2 rect) unwrap-rect) dst-rect)
452 %null-pointer)))
453 (sdl-error "blit-surface" "failed to blit surface ~a to ~a" src dst)))
454
455 (define (blit-scaled src src-rect dst dst-rect)
456 "Blit the rectangle SRC-RECT from the surface SRC to DST-RECT of the
457 surface DST, scaling the source to fit the destination."
458 (unless (zero?
459 (ffi:sdl-blit-surface (unwrap-surface src)
460 (if src-rect
461 ((@@ (sdl2 rect) unwrap-rect) src-rect)
462 %null-pointer)
463 (unwrap-surface dst)
464 (if dst-rect
465 ((@@ (sdl2 rect) unwrap-rect) dst-rect)
466 %null-pointer)))
467 (sdl-error "blit-scaled" "failed to blit surface ~a to ~a" src dst)))
468
469 (define (fill-rect dst rect color)
470 "Fill RECT with COLOR in the surface DST."
471 (unless (zero?
472 (ffi:sdl-fill-rect (unwrap-surface dst)
473 (if rect
474 ((@@ (sdl2 rect) unwrap-rect) rect)
475 %null-pointer)
476 color))
477 (sdl-error "fill-rect" "failed to fill rect in ~a" dst)))