3770a17d7d4b279b9a25cfb4c64c8ad9db74bd9f
[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
70 \f
71 ;;;
72 ;;; Color
73 ;;;
74
75 (define-record-type <color>
76 (make-color r g b a)
77 color?
78 (r color-r)
79 (g color-g)
80 (b color-b)
81 (a color-a))
82
83 \f
84 ;;;
85 ;;; Palette
86 ;;;
87
88 (define-wrapped-pointer-type <palette>
89 palette?
90 wrap-palette unwrap-palette
91 (lambda (palette port)
92 (format port "#<palette length: ~d>"
93 (palette-length palette))))
94
95 (define %palette-types
96 (list int ; number of colors
97 '*)) ; colors
98
99 (define-syntax-rule (palette-parse-match palette matchers ...)
100 (match (parse-c-struct (unwrap-palette palette) %palette-types)
101 matchers ...))
102
103 (define (palette-length palette)
104 "Return the number of colors in PALETTE."
105 (palette-parse-match palette
106 ((length _) length)))
107
108 (define (palette-colors palette)
109 "Return the colors in PALETTE."
110 (palette-parse-match palette
111 ((length colors)
112 (let ((bv (pointer->bytevector colors (* length 4)))
113 (colors (make-vector length)))
114 (let loop ((i 0))
115 (if (< i length)
116 (let ((offset (* i 4)))
117 (vector-set! colors i
118 (make-color (u8vector-ref bv offset)
119 (u8vector-ref bv (+ offset 1))
120 (u8vector-ref bv (+ offset 2))
121 (u8vector-ref bv (+ offset 3))))
122 (loop (1+ i)))
123 colors))))))
124
125 \f
126 ;;;
127 ;;; Pixel Format
128 ;;;
129
130 (define-wrapped-pointer-type <pixel-format>
131 pixel-format?
132 wrap-pixel-format unwrap-pixel-format
133 (lambda (pf port)
134 (format port "#<pixel-format name: ~s bpp: ~d>"
135 (pixel-format-name pf)
136 (pixel-format-bytes-per-pixel pf))))
137
138 (define %pixel-format-types
139 (list uint32 ; format
140 '* ; palette
141 uint8 ; bits per pixel
142 uint8 ; bytes per pixel
143 uint32 ; red mask
144 uint32 ; green mask
145 uint32 ; blue mask
146 uint32)) ; alpha mask
147
148 (define-syntax-rule (pixel-format-parse-match pf matchers ...)
149 (match (parse-c-struct (unwrap-pixel-format pf) %pixel-format-types)
150 matchers ...))
151
152 (define (pixel-format-name pf)
153 "Return the symbolic name of the pixel format PF."
154 (pixel-format-parse-match pf
155 ((format _ _ _ _ _ _ _)
156 (cond
157 ((= format ffi:SDL_PIXELFORMAT_INDEX1LSB) 'index1lsb)
158 ((= format ffi:SDL_PIXELFORMAT_INDEX1MSB) 'index1msb)
159 ((= format ffi:SDL_PIXELFORMAT_INDEX4LSB) 'index4lsb)
160 ((= format ffi:SDL_PIXELFORMAT_INDEX4MSB) 'index4msb)
161 ((= format ffi:SDL_PIXELFORMAT_INDEX8) 'index8)
162 ((= format ffi:SDL_PIXELFORMAT_RGB332) 'rgb332)
163 ((= format ffi:SDL_PIXELFORMAT_RGB444) 'rgb444)
164 ((= format ffi:SDL_PIXELFORMAT_RGB555) 'rgb555)
165 ((= format ffi:SDL_PIXELFORMAT_BGR555) 'bgr555)
166 ((= format ffi:SDL_PIXELFORMAT_ARGB4444) 'argb4444)
167 ((= format ffi:SDL_PIXELFORMAT_RGBA4444) 'rgba4444)
168 ((= format ffi:SDL_PIXELFORMAT_ABGR4444) 'abgr4444)
169 ((= format ffi:SDL_PIXELFORMAT_BGRA4444) 'bgra4444)
170 ((= format ffi:SDL_PIXELFORMAT_ARGB1555) 'argb1555)
171 ((= format ffi:SDL_PIXELFORMAT_RGBA5551) 'rgba5551)
172 ((= format ffi:SDL_PIXELFORMAT_ABGR1555) 'abgr1555)
173 ((= format ffi:SDL_PIXELFORMAT_BGRA5551) 'bgra5551)
174 ((= format ffi:SDL_PIXELFORMAT_RGB565) 'rgb565)
175 ((= format ffi:SDL_PIXELFORMAT_BGR565) 'bgr565)
176 ((= format ffi:SDL_PIXELFORMAT_RGB24) 'rgb24)
177 ((= format ffi:SDL_PIXELFORMAT_BGR24) 'bgr24)
178 ((= format ffi:SDL_PIXELFORMAT_RGB888) 'rgb888)
179 ((= format ffi:SDL_PIXELFORMAT_RGBX8888) 'rgbx8888)
180 ((= format ffi:SDL_PIXELFORMAT_BGR888) 'bgr888)
181 ((= format ffi:SDL_PIXELFORMAT_BGRX8888) 'bgrx8888)
182 ((= format ffi:SDL_PIXELFORMAT_ARGB8888) 'argb8888)
183 ((= format ffi:SDL_PIXELFORMAT_RGBA8888) 'rgba8888)
184 ((= format ffi:SDL_PIXELFORMAT_ABGR8888) 'abgr8888)
185 ((= format ffi:SDL_PIXELFORMAT_BGRA8888) 'bgra8888)
186 ((= format ffi:SDL_PIXELFORMAT_ARGB2101010) 'argb2101010)
187 ((= format ffi:SDL_PIXELFORMAT_YV12) 'yv12)
188 ((= format ffi:SDL_PIXELFORMAT_IYUV) 'iyuv)
189 ((= format ffi:SDL_PIXELFORMAT_YUY2) 'yuy2)
190 ((= format ffi:SDL_PIXELFORMAT_UYVY) 'uyvy)
191 ((= format ffi:SDL_PIXELFORMAT_YVYU) 'yvyu)))))
192
193 (define (pixel-format-palette pf)
194 "Return the palette for the pixel format PF."
195 (pixel-format-parse-match pf
196 ((_ palette _ _ _ _ _ _)
197 (if (null-pointer? palette)
198 #f
199 (wrap-palette palette)))))
200
201 (define (pixel-format-bits-per-pixel pf)
202 "Return the number of bits per pixel for the pixel format PF."
203 (pixel-format-parse-match pf
204 ((_ _ bits _ _ _ _ _) bits)))
205
206 (define (pixel-format-bytes-per-pixel pf)
207 "Return the number of bytes per pixel for the pixel format PF."
208 (pixel-format-parse-match pf
209 ((_ _ _ bytes _ _ _ _) bytes)))
210
211 (define (pixel-format-red-mask pf)
212 "Return the bitmask for the red component of a pixel in the pixel
213 format PF."
214 (pixel-format-parse-match pf
215 ((_ _ _ _ red-mask _ _ _) red-mask)))
216
217 (define (pixel-format-green-mask pf)
218 "Return the bitmask for the green component of a pixel in the pixel
219 format PF."
220 (pixel-format-parse-match pf
221 ((_ _ _ _ _ green-mask _ _) green-mask)))
222
223 (define (pixel-format-blue-mask pf)
224 "Return the bitmask for the blue component of a pixel in the pixel
225 format PF."
226 (pixel-format-parse-match pf
227 ((_ _ _ _ _ _ blue-mask _) blue-mask)))
228
229 (define (pixel-format-alpha-mask pf)
230 "Return the bitmask for the alpha component of a pixel in the pixel
231 format PF."
232 (pixel-format-parse-match pf
233 ((_ _ _ _ _ _ _ alpha-mask) alpha-mask)))
234
235 \f
236 ;;;
237 ;;; Surface
238 ;;;
239
240 (define-wrapped-pointer-type <surface>
241 surface?
242 wrap-surface unwrap-surface
243 (lambda (surface port)
244 (format port "#<surface ~x>"
245 (pointer-address (unwrap-surface surface)))))
246
247 (define (make-rgb-surface width height depth)
248 "Create a new SDL surface with the dimensions WIDTH and HEIGHT and
249 DEPTH bits per pixel."
250 (wrap-surface
251 (if (eq? (native-endianness) 'big)
252 (ffi:sdl-create-rgb-surface 0 width height depth
253 #xff000000
254 #x00ff0000
255 #x0000ff00
256 #x000000ff)
257 (ffi:sdl-create-rgb-surface 0 width height depth
258 #x000000ff
259 #x0000ff00
260 #x00ff0000
261 #xff000000))))
262
263 (define (bytevector->surface bv width height depth pitch)
264 "Convert BV, a bytevector of pixel data with dimenions WIDTHxHEIGHT,
265 to an SDL surface. Each pixel is DEPTH bits in size, and each row of
266 pixels is PITCH bytes in size."
267 (wrap-surface
268 (if (eq? (native-endianness) 'big)
269 (ffi:sdl-create-rgb-surface-from (bytevector->pointer bv)
270 width height depth pitch
271 #xff000000
272 #x00ff0000
273 #x0000ff00
274 #x000000ff)
275 (ffi:sdl-create-rgb-surface-from (bytevector->pointer bv)
276 width height depth pitch
277 #x000000ff
278 #x0000ff00
279 #x00ff0000
280 #xff000000))))
281
282 (define (delete-surface! surface)
283 "Free the memory used by SURFACE."
284 (ffi:sdl-free-surface (unwrap-surface surface)))
285
286 (define (call-with-surface surface proc)
287 "Call PROC, passing it SURFACE and deleting SURFACE upon exit of
288 PROC."
289 (dynamic-wind
290 (const #t)
291 (lambda ()
292 (proc surface))
293 (lambda ()
294 (delete-surface! surface))))
295
296 ;; The equivalent of the SDL_LoadBMP C macro.
297 (define (load-bmp file)
298 "Create a new surface from the bitmap data in FILE."
299 (let ((ptr (ffi:sdl-load-bmp-rw (ffi:sdl-rw-from-file (string->pointer file)
300 (string->pointer "rb"))
301 1)))
302 (if (null-pointer? ptr)
303 (sdl-error "load-bmp" "failed to load bitmap")
304 (wrap-surface ptr))))
305
306 (define %int-size (sizeof int))
307 (define %pointer-size (sizeof '*))
308
309 (define (pointer-int-ref pointer offset)
310 (bytevector-sint-ref (pointer->bytevector pointer %int-size offset)
311 0 (native-endianness) %int-size))
312
313 ;; A partial list of surface types so that we can parse the data we
314 ;; need out of the SDL_Surface struct pointer.
315 (define %surface-types
316 (list uint32 ; flags
317 '* ; format
318 int ; width
319 int ; height
320 int ; pitch
321 '*)) ; pixels
322
323 (define-syntax-rule (surface-parse-match surface matchers ...)
324 (match (parse-c-struct (unwrap-surface surface) %surface-types)
325 matchers ...))
326
327 (define (surface-width surface)
328 "Return the width of SURFACE in pixels."
329 (surface-parse-match surface
330 ((_ _ width _ _ _) width)))
331
332 (define (surface-height surface)
333 "Return the height of SURFACE in pixels."
334 (surface-parse-match surface
335 ((_ _ _ height _ _) height)))
336
337 (define (surface-pitch surface)
338 "Return the length of a row of pixels in SURFACE in bytes."
339 (surface-parse-match surface
340 ((_ _ _ _ pitch _) pitch)))
341
342 (define (surface-pixels surface)
343 "Return a bytevector containing the raw pixel data in SURFACE."
344 (surface-parse-match surface
345 ((_ _ _ height pitch pixels)
346 (pointer->bytevector pixels (* height pitch)))))
347
348 (define (surface-pixel-format surface)
349 "Return the pixel format for SURFACE."
350 (surface-parse-match surface
351 ((_ format _ _ _ _)
352 (wrap-pixel-format format))))
353
354 (define (symbol->sdl-pixel-format sym)
355 (match sym
356 ('index1lsb ffi:SDL_PIXELFORMAT_INDEX1LSB)
357 ('index1msb ffi:SDL_PIXELFORMAT_INDEX1MSB)
358 ('index4lsb ffi:SDL_PIXELFORMAT_INDEX4LSB)
359 ('index4msb ffi:SDL_PIXELFORMAT_INDEX4MSB)
360 ('index8 ffi:SDL_PIXELFORMAT_INDEX8)
361 ('rgb332 ffi:SDL_PIXELFORMAT_RGB332)
362 ('rgb444 ffi:SDL_PIXELFORMAT_RGB444)
363 ('rgb555 ffi:SDL_PIXELFORMAT_RGB555)
364 ('bgr555 ffi:SDL_PIXELFORMAT_BGR555)
365 ('argb4444 ffi:SDL_PIXELFORMAT_ARGB4444)
366 ('rgba4444 ffi:SDL_PIXELFORMAT_RGBA4444)
367 ('abgr4444 ffi:SDL_PIXELFORMAT_ABGR4444)
368 ('bgra4444 ffi:SDL_PIXELFORMAT_BGRA4444)
369 ('argb1555 ffi:SDL_PIXELFORMAT_ARGB1555)
370 ('rgba5551 ffi:SDL_PIXELFORMAT_RGBA5551)
371 ('abgr1555 ffi:SDL_PIXELFORMAT_ABGR1555)
372 ('bgra5551 ffi:SDL_PIXELFORMAT_BGRA5551)
373 ('rgb565 ffi:SDL_PIXELFORMAT_RGB565)
374 ('bgr565 ffi:SDL_PIXELFORMAT_BGR565)
375 ('rgb24 ffi:SDL_PIXELFORMAT_RGB24)
376 ('bgr24 ffi:SDL_PIXELFORMAT_BGR24)
377 ('rgb888 ffi:SDL_PIXELFORMAT_RGB888)
378 ('rgbx8888 ffi:SDL_PIXELFORMAT_RGBX8888)
379 ('bgr888 ffi:SDL_PIXELFORMAT_BGR888)
380 ('bgrx8888 ffi:SDL_PIXELFORMAT_BGRX8888)
381 ('argb8888 ffi:SDL_PIXELFORMAT_ARGB8888)
382 ('rgba8888 ffi:SDL_PIXELFORMAT_RGBA8888)
383 ('abgr8888 ffi:SDL_PIXELFORMAT_ABGR8888)
384 ('bgra8888 ffi:SDL_PIXELFORMAT_BGRA8888)
385 ('argb2101010 ffi:SDL_PIXELFORMAT_ARGB2101010)
386 ('yv12 ffi:SDL_PIXELFORMAT_YV12)
387 ('iyuv ffi:SDL_PIXELFORMAT_IYUV)
388 ('yuy2 ffi:SDL_PIXELFORMAT_YUY2)
389 ('uyvy ffi:SDL_PIXELFORMAT_UYVY)
390 ('yvyu ffi:SDL_PIXELFORMAT_YVYU)))
391
392 (define (convert-surface-format surface format)
393 "Convert the pixels in SURFACE to FORMAT, a symbol representing a
394 specific pixel format, and return a new surface object.
395
396 Valid format types are:
397
398 - index1lsb
399 - index1msb
400 - index4lsb
401 - index4msb
402 - index8
403 - rgb332
404 - rgb444
405 - rgb555
406 - bgr555
407 - argb4444
408 - rgba4444
409 - abgr4444
410 - bgra4444
411 - argb1555
412 - rgba5551
413 - abgr1555
414 - bgra5551
415 - rgb565
416 - bgr565
417 - rgb24
418 - bgr24
419 - rgb888
420 - rgbx8888
421 - bgr888
422 - bgrx8888
423 - argb8888
424 - rgba8888
425 - abgr8888
426 - bgra8888
427 - argb2101010
428 - yv12
429 - iyuv
430 - yuy2
431 - uyvy
432 - yvyu"
433 (let ((ptr (ffi:sdl-convert-surface-format (unwrap-surface surface)
434 (symbol->sdl-pixel-format format)
435 0)))
436 (if (null-pointer? ptr)
437 (sdl-error "convert-surface-format" "failed to convert surface format")
438 (wrap-surface ptr))))
439
440 (define (blit-surface src src-rect dst dst-rect)
441 "Blit the rectangle SRC-RECT from the surface SRC to DST-RECT of the
442 surface DST."
443 (unless (zero?
444 (ffi:sdl-blit-surface (unwrap-surface src)
445 (if src-rect
446 ((@@ (sdl2 rect) unwrap-rect) src-rect)
447 %null-pointer)
448 (unwrap-surface dst)
449 (if dst-rect
450 ((@@ (sdl2 rect) unwrap-rect) dst-rect)
451 %null-pointer)))
452 (sdl-error "blit-surface" "failed to blit surface ~a to ~a" src dst)))
453
454 (define (blit-scaled src src-rect dst dst-rect)
455 "Blit the rectangle SRC-RECT from the surface SRC to DST-RECT of the
456 surface DST, scaling the source to fit the destination."
457 (unless (zero?
458 (ffi:sdl-blit-surface (unwrap-surface src)
459 (if src-rect
460 ((@@ (sdl2 rect) unwrap-rect) src-rect)
461 %null-pointer)
462 (unwrap-surface dst)
463 (if dst-rect
464 ((@@ (sdl2 rect) unwrap-rect) dst-rect)
465 %null-pointer)))
466 (sdl-error "blit-scaled" "failed to blit surface ~a to ~a" src dst)))