surface: Add SDL_FillRect binding.
[guile-sdl2.git] / sdl2 / surface.scm
CommitLineData
8a3a26bb
DT
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)
db3dea0c 29 #:use-module (rnrs bytevectors)
cfe2a2f4
DT
30 #:use-module (srfi srfi-4)
31 #:use-module (srfi srfi-9)
8a3a26bb
DT
32 #:use-module (system foreign)
33 #:use-module ((sdl2 bindings) #:prefix ffi:)
34 #:use-module (sdl2)
cfe2a2f4
DT
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?
429d7c01 46 pixel-format-name
cfe2a2f4
DT
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
2fb7f399 56 bytevector->surface
a1fe5d2a 57 surface?
8a3a26bb
DT
58 delete-surface!
59 call-with-surface
db3dea0c 60 load-bmp
cfe2a2f4 61 surface-pixel-format
db3dea0c
DT
62 surface-width
63 surface-height
64 surface-pitch
8e8fe427 65 surface-pixels
6b8bef24 66 convert-surface-format
5ef8b648 67 blit-surface
4b2c1907
DT
68 blit-scaled
69 fill-rect))
8a3a26bb 70
cfe2a2f4
DT
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
214format 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
220format 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
226format 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
232format PF."
233 (pixel-format-parse-match pf
234 ((_ _ _ _ _ _ _ alpha-mask) alpha-mask)))
235
236\f
237;;;
238;;; Surface
239;;;
240
8a3a26bb
DT
241(define-wrapped-pointer-type <surface>
242 surface?
243 wrap-surface unwrap-surface
d17351ee 244 (lambda (surface port)
8a3a26bb 245 (format port "#<surface ~x>"
d17351ee 246 (pointer-address (unwrap-surface surface)))))
8a3a26bb 247
a1fe5d2a
DT
248(define (make-rgb-surface width height depth)
249 "Create a new SDL surface with the dimensions WIDTH and HEIGHT and
250DEPTH 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
2fb7f399
DT
264(define (bytevector->surface bv width height depth pitch)
265 "Convert BV, a bytevector of pixel data with dimenions WIDTHxHEIGHT,
266to an SDL surface. Each pixel is DEPTH bits in size, and each row of
267pixels 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
8a3a26bb
DT
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
289PROC."
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))))
db3dea0c
DT
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
29228696
DT
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 ...))
db3dea0c
DT
327
328(define (surface-width surface)
329 "Return the width of SURFACE in pixels."
29228696
DT
330 (surface-parse-match surface
331 ((_ _ width _ _ _) width)))
db3dea0c
DT
332
333(define (surface-height surface)
334 "Return the height of SURFACE in pixels."
29228696
DT
335 (surface-parse-match surface
336 ((_ _ _ height _ _) height)))
db3dea0c
DT
337
338(define (surface-pitch surface)
339 "Return the length of a row of pixels in SURFACE in bytes."
29228696
DT
340 (surface-parse-match surface
341 ((_ _ _ _ pitch _) pitch)))
db3dea0c
DT
342
343(define (surface-pixels surface)
344 "Return a bytevector containing the raw pixel data in SURFACE."
29228696
DT
345 (surface-parse-match surface
346 ((_ _ _ height pitch pixels)
347 (pointer->bytevector pixels (* height pitch)))))
8e8fe427 348
cfe2a2f4
DT
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
8e8fe427
DT
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
395specific pixel format, and return a new surface object.
396
397Valid 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")
241918b1 439 (wrap-surface ptr))))
6b8bef24
DT
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
443surface 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)))
5ef8b648
DT
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
457surface 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)))
4b2c1907
DT
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)))