Add image module.

2 files changed, 108 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index 848741f..ba5ac74 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -66,6 +66,7 @@ SOURCES = 					\
   chickadee/audio/wav.scm			\
   chickadee/audio.scm				\
   chickadee/pixbuf.scm				\
+  chickadee/image.scm				\
   chickadee/image/jpeg.scm			\
   chickadee/image/png.scm			\
   chickadee/graphics/gl.scm			\
diff --git a/chickadee/image.scm b/chickadee/image.scm
new file mode 100644
index 0000000..c5ec5dc
--- /dev/null
+++ b/chickadee/image.scm
@@ -0,0 +1,107 @@
+;;; 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:
+;;
+;; Data type for representing images on disk.
+;;
+;;; Code:
+
+(define-module (chickadee image)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee image jpeg)
+  #:use-module (chickadee image png)
+  #:use-module (chickadee pixbuf)
+  #:use-module (chickadee utils)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:export (make-image
+            image?
+            image-file-name
+            temp-image-file-name
+            read-image
+            write-image))
+
+;; An image is pixel data that is stored on disk in one of a variety
+;; of formats.
+(define-record-type <image>
+  (%make-image file-name)
+  image?
+  (file-name image-file-name))
+
+(define (make-image file-name)
+  (%make-image (absolute-file-name file-name)))
+
+(define (print-image image port)
+  ;; Rendering in a format that Geiser understands so that images can
+  ;; be viewed inline at the REPL.
+  (format port "#<Image: ~a>" (image-file-name image)))
+
+(set-record-type-printer! <image> print-image)
+
+(define (image-format image)
+  (match (file-extension (image-file-name image))
+    ((or "jpg" "jpeg") 'jpeg)
+    ("png" 'png)
+    (_ 'unknown)))
+
+(define (image-error message irritants)
+ (raise-exception
+  (make-exception
+   (make-exception-with-message message)
+   (make-exception-with-irritants irritants))))
+
+(define* (read-image image)
+  "Read data from IMAGE and return a pixbuf."
+  (define-values (pixels width height)
+    (case (image-format image)
+      ((jpeg)
+       (load-jpeg (image-file-name image)))
+      ((png)
+       (load-png (image-file-name image)))
+      (else
+       (image-error "unsupported image format: ~a" (image-format image)))))
+  (bytevector->pixbuf pixels width height #:format 'rgba #:bit-depth 8))
+
+;; Not guaranteed to be a file that doesn't exist, but good enough.
+(define (temp-image-file-name format)
+  (string-append (tmpdir) "/"
+                 (symbol->string
+                  (gensym "chickadee-"))
+                 "."
+                 (symbol->string format)))
+
+(define* (write-image pixbuf
+                      #:optional (file-name (temp-image-file-name 'png))
+                      #:key (format 'png))
+  "Write PIXBUF to FILE-NAME and return an image object.  FORMAT may be
+either 'png' or 'jpeg'."
+  (unless (and (eq? (pixbuf-format pixbuf) 'rgba)
+               (= (pixbuf-bit-depth pixbuf) 8))
+    (image-error "can only write RGBA pixbufs with 8 bit depth: ~a" pixbuf))
+  (case format
+    ((png)
+     (save-png (pixbuf-pixels pixbuf)
+               (pixbuf-width pixbuf)
+               (pixbuf-height pixbuf)
+               file-name))
+    (else
+     (image-error "unsupport image format: ~a" format)))
+  (make-image file-name))