summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--chickadee/image.scm107
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))