diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | chickadee/image.scm | 107 |
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)) |