diff options
Diffstat (limited to 'pnm')
| -rw-r--r-- | pnm/pbm.scm | 53 | ||||
| -rw-r--r-- | pnm/read.scm | 39 | ||||
| -rw-r--r-- | pnm/write.scm | 2 |
3 files changed, 79 insertions, 15 deletions
diff --git a/pnm/pbm.scm b/pnm/pbm.scm new file mode 100644 index 0000000..d711b82 --- /dev/null +++ b/pnm/pbm.scm @@ -0,0 +1,53 @@ +;;; 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 (pnm pbm) + (export make-pbm-image) + (import (scheme base) + (scheme case-lambda) + (pnm image)) + (cond-expand + ((library (scheme bitwise)) + (import (only (scheme bitwise) bit-set? copy-bit))) + ((library (srfi 60)) + (import (only (srfi 60) bit-set? copy-bit)))) + (begin + (define make-pbm-image + (case-lambda + ((width height) + (let* ((byte-width (ceiling (/ width 8))) + (byte-count (* byte-width height)) + (data (make-bytevector byte-count 0))) + (make-pbm-image width height data))) + ((width height data) + (let* ((byte-width (ceiling (/ width 8)))) + (define (xy->byte-idx+bit-idx x y) + (let-values (((byte-x bit-x) (floor/ x 8))) + (values (+ (* y byte-width) + byte-x) + bit-x))) + (define (pixel-getter x y) + (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y))) + (let ((byte (bytevector-u8-ref data byte-idx))) + (bit-set? (- 7 bit-idx) byte)))) + (define (pixel-setter x y b) + (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y))) + (let ((byte (bytevector-u8-ref data byte-idx))) + (bytevector-u8-set! data byte-idx + (copy-bit (- 7 bit-idx) byte b))))) + (make-image 'pbm width height 1 data pixel-getter pixel-setter))))))) diff --git a/pnm/read.scm b/pnm/read.scm index e88f958..ae7676f 100644 --- a/pnm/read.scm +++ b/pnm/read.scm @@ -20,6 +20,7 @@ (export image-read) (import (scheme base) (pnm image) + (pnm pbm) (pnm pgm) (pnm ppm)) (begin @@ -56,21 +57,28 @@ (let ((width (read-number in))) (read-whitespaces*) (let ((height (read-number in))) - (read-whitespaces*) - (let ((maxval (read-number in))) - (unless (whitespace? (read-u8*)) - (unexpected-char-error)) - (case magic-number - ((P6) - (make-ppm-image width height maxval - (if (< maxval 256) - (read-bytevector (* 3 width height) in) - (read-bytevector (* 6 width height) in)))) - ((P5) - (make-pgm-image width height maxval - (if (< maxval 256) - (read-bytevector (* width height) in) - (read-bytevector (* 2 width height) in)))))))))) + (case magic-number + ((P4) + (unless (whitespace? (read-u8*)) + (unexpected-char-error)) + (make-pbm-image width height + (read-bytevector (* (ceiling (/ width 8)) height) in))) + (else + (read-whitespaces*) + (let ((maxval (read-number in))) + (unless (whitespace? (read-u8*)) + (unexpected-char-error)) + (case magic-number + ((P6) + (make-ppm-image width height maxval + (if (< maxval 256) + (read-bytevector (* 3 width height) in) + (read-bytevector (* 6 width height) in)))) + ((P5) + (make-pgm-image width height maxval + (if (< maxval 256) + (read-bytevector (* width height) in) + (read-bytevector (* 2 width height) in)))))))))))) (define (whitespace? u8) (case (integer->char u8) @@ -111,6 +119,7 @@ ((or (eof-object? u8-1) (eof-object? u8-2)) (eof-object)) ((and (= u8-1 P/u8) (= u8-2/int 6)) 'P6) ((and (= u8-1 P/u8) (= u8-2/int 5)) 'P5) + ((and (= u8-1 P/u8) (= u8-2/int 4)) 'P4) (else #f)))) (define (read-whitespaces in) diff --git a/pnm/write.scm b/pnm/write.scm index b41a0d9..75cd433 100644 --- a/pnm/write.scm +++ b/pnm/write.scm @@ -30,6 +30,8 @@ (write-string-u8 "P6\n")) ((pgm) (write-string-u8 "P5\n")) + ((pbm) + (write-string-u8 "P4\n")) (else (error "(pnm write) pnm-write: Not supported type" (image-type image)))) (write-string-u8 (number->string (image-width image))) |