blob: 61af06f91944b979f8e4621f7f3c1a214d1e72fc (
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
|
;;; Chickadee Game Toolkit
;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
;;;
;;; Chickadee is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Chickadee 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 General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; CPU-side pixel data buffers.
;;
;;; Code:
(define-module (chickadee pixbuf)
#:use-module (chickadee graphics color)
#:use-module (chickadee utils)
#:use-module (ice-9 exceptions)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (make-pixbuf
bytevector->pixbuf
pixbuf?
pixbuf-alpha?
pixbuf-pixels
pixbuf-width
pixbuf-height
pixbuf-format
pixbuf-bit-depth
pixbuf-copy-raw!
pixbuf-flip-vertically!
pixbuf-color-key!))
(define &pixbuf-error
(make-exception-type '&pixbuf-error &error '()))
(define make-pixbuf-error (record-constructor &pixbuf-error))
(define (pixbuf-error message irritants)
(raise-exception
(make-exception
(make-pixbuf-error)
(make-exception-with-message message)
(make-exception-with-irritants irritants))))
;; A pixbuf is raw pixel data stored in memory that can be saved to
;; disk or loaded into a GPU texture.
(define-record-type <pixbuf>
(%make-pixbuf pixels width height format bit-depth)
pixbuf?
(pixels pixbuf-pixels)
(width pixbuf-width)
(height pixbuf-height)
(format pixbuf-format)
(bit-depth pixbuf-bit-depth))
(define (print-pixbuf pixbuf port)
(format port "#<pixbuf width: ~a height: ~a format: ~a bit-depth: ~a>"
(pixbuf-width pixbuf)
(pixbuf-height pixbuf)
(pixbuf-format pixbuf)
(pixbuf-bit-depth pixbuf)))
(set-record-type-printer! <pixbuf> print-pixbuf)
(define (channel-count format)
(case format
((rgba) 4)))
(define (byte-depth bit-depth)
(/ bit-depth 8))
(define (buffer-length width height format bit-depth)
(* width height
(byte-depth bit-depth)
(channel-count format)))
(define* (make-pixbuf width height #:key (format 'rgba) (bit-depth 8))
"Return a new pixbuf object of WIDTH x HEIGHT pixels using color
channel FORMAT and BIT-DEPTH bits per channel. Initially, all color
channel values are 0. Currently, the only supported format is 'rgba'
and the only supported bit depth is 8."
(unless (= bit-depth 8)
(pixbuf-error "unsupported bit depth" (list bit-depth)))
(unless (eq? format 'rgba)
(pixbuf-error "unsupported format" (list format)))
(let* ((n (buffer-length width height format bit-depth))
(buffer (make-bytevector n 0)))
(%make-pixbuf buffer width height format bit-depth)))
(define* (bytevector->pixbuf bv width height #:key (format 'rgba) (bit-depth 8))
(let ((pixbuf (make-pixbuf width height
#:format format
#:bit-depth bit-depth)))
(pixbuf-copy-raw! pixbuf bv)
pixbuf))
(define (pixbuf-alpha? pixbuf)
"Return #t if PIXBUF has an alpha channel."
(case (pixbuf-format pixbuf)
((rgba) #t)
(else #f)))
(define (pixbuf-byte-depth pixbuf)
(byte-depth (pixbuf-bit-depth pixbuf)))
(define (pixbuf-red-channel-index pixbuf)
(case (pixbuf-format pixbuf)
((rgba) 0)))
(define (pixbuf-green-channel-index pixbuf)
(case (pixbuf-format pixbuf)
((rgba) 1)))
(define (pixbuf-blue-channel-index pixbuf)
(case (pixbuf-format pixbuf)
((rgba) 2)))
(define (pixbuf-alpha-channel-index pixbuf)
(case (pixbuf-format pixbuf)
((rgba) 3)))
(define (pixbuf-channel-count pixbuf)
"Return the number of channels per pixel in PIXBUF."
(channel-count (pixbuf-format pixbuf)))
(define (pixbuf-copy-raw! pixbuf bv)
"Copy the contents of the bytevector BV into PIXBUF. BV must be
exactly the same size as the underlying buffer of PIXBUF."
(let* ((pixels (pixbuf-pixels pixbuf))
(n (bytevector-length pixels)))
(if (= (bytevector-length bv) n)
(bytevector-copy! bv 0 pixels 0 n)
(pixbuf-error "improperly sized bytevector" (list bv)))))
(define (pixbuf-flip-vertically! pixbuf)
"Flip the pixel data in PIXBUF upside-down."
(let* ((w (pixbuf-width pixbuf))
(h (pixbuf-height pixbuf))
(n (pixbuf-channel-count pixbuf))
(d (pixbuf-byte-depth pixbuf))
(row-length (* w n d))
(temp-row (make-bytevector row-length 0))
(pixels (pixbuf-pixels pixbuf)))
(for-range ((y (floor (/ h 2))))
(let* ((y* (- h y 1))
(source-start (* y row-length))
(target-start (* y* row-length)))
;; Copy the target row into the temp row.
(bytevector-copy! pixels target-start temp-row 0 row-length)
;; Overwrite the target row with the source row.
(bytevector-copy! pixels source-start pixels target-start row-length)
;; Overwrite the source row with the temp row.
(bytevector-copy! temp-row 0 pixels source-start row-length)))))
(define (pixbuf-color-key! pixbuf color)
"Overwrite the alpha channel for pixels in PIXBUF that match COLOR
with full transparency."
(when (pixbuf-alpha? pixbuf)
(let* ((w (pixbuf-width pixbuf))
(h (pixbuf-height pixbuf))
(n (pixbuf-channel-count pixbuf))
(d (pixbuf-byte-depth pixbuf))
(ri (pixbuf-red-channel-index pixbuf))
(gi (pixbuf-green-channel-index pixbuf))
(bi (pixbuf-blue-channel-index pixbuf))
(ai (pixbuf-alpha-channel-index pixbuf))
(high (- (expt 256 d) 1))
(r (inexact->exact (* (color-r color) high)))
(g (inexact->exact (* (color-g color) high)))
(b (inexact->exact (* (color-b color) high)))
(pixels (pixbuf-pixels pixbuf)))
(define (channel-ref i offset)
(bytevector-uint-ref pixels (+ i offset) (native-endianness) d))
(define (channel-set! i offset x)
(bytevector-uint-set! pixels (+ i offset) x (native-endianness) d))
(for-range ((i (bytevector-length pixels) 0 (* n d)))
;; Zero the alpha channel of pixels that match the transparent
;; color key.
(when (and (= r (channel-ref i ri))
(= g (channel-ref i gi))
(= b (channel-ref i bi)))
(channel-set! i ai 0))))))
|
