blob: 98ddf700bffe6e18c3bc497bfcd75810aa284a6a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
;;; guile-sdl2 --- FFI bindings for SDL2
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; This file is part of guile-sdl2.
;;;
;;; Guile-sdl2 is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Guile-sdl2 is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with guile-sdl2. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; SDL surface manipulation.
;;
;;; Code:
(define-module (sdl2 surface)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:use-module ((sdl2 bindings) #:prefix ffi:)
#:use-module (sdl2)
#:export (surface?
delete-surface!
call-with-surface
load-bmp
surface-width
surface-height
surface-pitch
surface-pixels
convert-surface-format))
(define-wrapped-pointer-type <surface>
surface?
wrap-surface unwrap-surface
(lambda (surface port)
(format port "#<surface ~x>"
(pointer-address (unwrap-surface surface)))))
(define (delete-surface! surface)
"Free the memory used by SURFACE."
(ffi:sdl-free-surface (unwrap-surface surface)))
(define (call-with-surface surface proc)
"Call PROC, passing it SURFACE and deleting SURFACE upon exit of
PROC."
(dynamic-wind
(const #t)
(lambda ()
(proc surface))
(lambda ()
(delete-surface! surface))))
;; The equivalent of the SDL_LoadBMP C macro.
(define (load-bmp file)
"Create a new surface from the bitmap data in FILE."
(let ((ptr (ffi:sdl-load-bmp-rw (ffi:sdl-rw-from-file (string->pointer file)
(string->pointer "rb"))
1)))
(if (null-pointer? ptr)
(sdl-error "load-bmp" "failed to load bitmap")
(wrap-surface ptr))))
(define %int-size (sizeof int))
(define %pointer-size (sizeof '*))
(define (pointer-int-ref pointer offset)
(bytevector-sint-ref (pointer->bytevector pointer %int-size offset)
0 (native-endianness) %int-size))
;; The offsets below correspond to the SDL_Surface struct elements
;; that come before the element in question.
(define %width-offset (sizeof (list uint32 '*)))
(define %height-offset (sizeof (list uint32 '* int)))
(define %pitch-offset (sizeof (list uint32 '* int int)))
(define %pixels-offset 32)
(define (surface-width surface)
"Return the width of SURFACE in pixels."
(pointer-int-ref (unwrap-surface surface) %width-offset))
(define (surface-height surface)
"Return the height of SURFACE in pixels."
(pointer-int-ref (unwrap-surface surface) %height-offset))
(define (surface-pitch surface)
"Return the length of a row of pixels in SURFACE in bytes."
(pointer-int-ref (unwrap-surface surface) %pitch-offset))
(define (surface-pixels surface)
"Return a bytevector containing the raw pixel data in SURFACE."
(let* ((ptr (unwrap-surface surface))
(height (pointer-int-ref ptr %height-offset))
(pitch (pointer-int-ref ptr %pitch-offset))
(pixels-ptr (pointer->bytevector ptr %pointer-size %pixels-offset))
(pixels (make-pointer
(bytevector-uint-ref pixels-ptr
0
(native-endianness)
%pointer-size))))
(pointer->bytevector pixels (* height pitch))))
(define (symbol->sdl-pixel-format sym)
(match sym
('index1lsb ffi:SDL_PIXELFORMAT_INDEX1LSB)
('index1msb ffi:SDL_PIXELFORMAT_INDEX1MSB)
('index4lsb ffi:SDL_PIXELFORMAT_INDEX4LSB)
('index4msb ffi:SDL_PIXELFORMAT_INDEX4MSB)
('index8 ffi:SDL_PIXELFORMAT_INDEX8)
('rgb332 ffi:SDL_PIXELFORMAT_RGB332)
('rgb444 ffi:SDL_PIXELFORMAT_RGB444)
('rgb555 ffi:SDL_PIXELFORMAT_RGB555)
('bgr555 ffi:SDL_PIXELFORMAT_BGR555)
('argb4444 ffi:SDL_PIXELFORMAT_ARGB4444)
('rgba4444 ffi:SDL_PIXELFORMAT_RGBA4444)
('abgr4444 ffi:SDL_PIXELFORMAT_ABGR4444)
('bgra4444 ffi:SDL_PIXELFORMAT_BGRA4444)
('argb1555 ffi:SDL_PIXELFORMAT_ARGB1555)
('rgba5551 ffi:SDL_PIXELFORMAT_RGBA5551)
('abgr1555 ffi:SDL_PIXELFORMAT_ABGR1555)
('bgra5551 ffi:SDL_PIXELFORMAT_BGRA5551)
('rgb565 ffi:SDL_PIXELFORMAT_RGB565)
('bgr565 ffi:SDL_PIXELFORMAT_BGR565)
('rgb24 ffi:SDL_PIXELFORMAT_RGB24)
('bgr24 ffi:SDL_PIXELFORMAT_BGR24)
('rgb888 ffi:SDL_PIXELFORMAT_RGB888)
('rgbx8888 ffi:SDL_PIXELFORMAT_RGBX8888)
('bgr888 ffi:SDL_PIXELFORMAT_BGR888)
('bgrx8888 ffi:SDL_PIXELFORMAT_BGRX8888)
('argb8888 ffi:SDL_PIXELFORMAT_ARGB8888)
('rgba8888 ffi:SDL_PIXELFORMAT_RGBA8888)
('abgr8888 ffi:SDL_PIXELFORMAT_ABGR8888)
('bgra8888 ffi:SDL_PIXELFORMAT_BGRA8888)
('argb2101010 ffi:SDL_PIXELFORMAT_ARGB2101010)
('yv12 ffi:SDL_PIXELFORMAT_YV12)
('iyuv ffi:SDL_PIXELFORMAT_IYUV)
('yuy2 ffi:SDL_PIXELFORMAT_YUY2)
('uyvy ffi:SDL_PIXELFORMAT_UYVY)
('yvyu ffi:SDL_PIXELFORMAT_YVYU)))
(define (convert-surface-format surface format)
"Convert the pixels in SURFACE to FORMAT, a symbol representing a
specific pixel format, and return a new surface object.
Valid format types are:
- index1lsb
- index1msb
- index4lsb
- index4msb
- index8
- rgb332
- rgb444
- rgb555
- bgr555
- argb4444
- rgba4444
- abgr4444
- bgra4444
- argb1555
- rgba5551
- abgr1555
- bgra5551
- rgb565
- bgr565
- rgb24
- bgr24
- rgb888
- rgbx8888
- bgr888
- bgrx8888
- argb8888
- rgba8888
- abgr8888
- bgra8888
- argb2101010
- yv12
- iyuv
- yuy2
- uyvy
- yvyu"
(let ((ptr (ffi:sdl-convert-surface-format (unwrap-surface surface)
(symbol->sdl-pixel-format format)
0)))
(if (null-pointer? ptr)
(sdl-error "convert-surface-format" "failed to convert surface format")
(wrap-surface surface))))
|
