Add pixbuf module.

2 files changed, 184 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index 55f626e..848741f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -65,6 +65,7 @@ SOURCES = 					\
   chickadee/audio/vorbis.scm			\
   chickadee/audio/wav.scm			\
   chickadee/audio.scm				\
+  chickadee/pixbuf.scm				\
   chickadee/image/jpeg.scm			\
   chickadee/image/png.scm			\
   chickadee/graphics/gl.scm			\
diff --git a/chickadee/pixbuf.scm b/chickadee/pixbuf.scm
new file mode 100644
index 0000000..09db6ee
--- /dev/null
+++ b/chickadee/pixbuf.scm
@@ -0,0 +1,183 @@
+;;; 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 (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 message irritants)
+  (error 'pixbuff-error message 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))))))