diff options
Diffstat (limited to 'image-format/pnm/pgm.scm')
| -rw-r--r-- | image-format/pnm/pgm.scm | 91 |
1 files changed, 91 insertions, 0 deletions
diff --git a/image-format/pnm/pgm.scm b/image-format/pnm/pgm.scm new file mode 100644 index 0000000..39711e9 --- /dev/null +++ b/image-format/pnm/pgm.scm @@ -0,0 +1,91 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo <masaya@tojo.tokyo> +;;; +;;; This file is part of R7RS-PNM. +;;; +;;; R7RS-PNM is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; R7RS-PNM 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 Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public License +;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>. + +(define-library (image-format pnm pgm) + (export make-pgm-image + %make-pgm-image) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image) + (image-format pnm private checker) + (image-format pnm private double-byte)) + (begin + (define make-pgm-image + (case-lambda + ((width height) + (make-pgm-image width height 255 #f)) + ((width height maxval) + (make-pgm-image width height maxval #f)) + ((width height maxval unsafe?) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(image-format pnm pgm) make-pgm: maxval is out of range")) + (let* ((byte-count (* width height + (if (< maxval 256) + 1 + 2))) + (data (make-bytevector byte-count 0))) + (%make-pgm-image width height maxval data unsafe?))))) + + (define (%make-pgm-image width height maxval data unsafe?) + (define (make-safe-pixel-getter pixel-getter) + (let ((check-xy (make-xy-checker width height))) + (lambda (x y) + (check-xy x y) + (pixel-getter x y)))) + (define (make-safe-pixel-setter pixel-setter) + (let ((check-xy (make-xy-checker width height)) + (check-value (make-value-checker maxval 'v))) + (lambda (x y v) + (check-xy x y) + (check-value v) + (pixel-setter x y v)))) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(image-format pnm pgm) make-pgm: maxval is out of range")) + (if (< maxval 256) + (let ((byte-count (* width height))) + (define (xy->idx x y) + (+ x (* y width))) + (define (pixel-getter x y) + (let ((idx (xy->idx x y))) + (bytevector-u8-ref data idx))) + (define (pixel-setter x y v) + (let ((idx (xy->idx x y))) + (bytevector-u8-set! data idx v))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (make-pnm-image 'pgm width height maxval data + (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter)) + (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter)))) + (let ((byte-count (* width height 2))) + (define (xy->idx x y) (+ x (* y width))) + (define (pixel-getter x y) + (let ((idx (xy->idx x y))) + (combine-bytes (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1))))) + (define (pixel-setter x y v) + (let ((idx (xy->idx x y))) + (let-values (((v1 v2) (split-double-byte v))) + (bytevector-u8-set! data idx v1) + (bytevector-u8-set! data (+ idx 1) v2)))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (make-pnm-image 'pgm width height maxval data + (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter)) + (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter)))))))) |