blob: c15a0b7325c5401962b080db839e0f7e585057d3 (
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
|
;;; Chickadee Game Toolkit
;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; 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))))))
|
