From 9d052c650ba59ddc8132bce881bd487df31c5348 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sat, 10 Aug 2024 23:08:10 +0900 Subject: Add `image-format` prefix to library name --- README.md | 4 +- image-format/pnm.scm | 39 +++++ image-format/pnm/image.scm | 53 +++++++ image-format/pnm/pbm.scm | 70 +++++++++ image-format/pnm/pgm.scm | 91 +++++++++++ image-format/pnm/ppm.scm | 111 ++++++++++++++ image-format/pnm/private/bitwise.scm | 38 +++++ image-format/pnm/private/checker.scm | 65 ++++++++ image-format/pnm/private/double-byte.scm | 29 ++++ image-format/pnm/read.scm | 253 +++++++++++++++++++++++++++++++ image-format/pnm/write.scm | 123 +++++++++++++++ pnm.scm | 39 ----- pnm/image.scm | 53 ------- pnm/pbm.scm | 70 --------- pnm/pgm.scm | 91 ----------- pnm/ppm.scm | 111 -------------- pnm/private/bitwise.scm | 38 ----- pnm/private/checker.scm | 65 -------- pnm/private/double-byte.scm | 29 ---- pnm/read.scm | 253 ------------------------------- pnm/write.scm | 123 --------------- 21 files changed, 874 insertions(+), 874 deletions(-) create mode 100644 image-format/pnm.scm create mode 100644 image-format/pnm/image.scm create mode 100644 image-format/pnm/pbm.scm create mode 100644 image-format/pnm/pgm.scm create mode 100644 image-format/pnm/ppm.scm create mode 100644 image-format/pnm/private/bitwise.scm create mode 100644 image-format/pnm/private/checker.scm create mode 100644 image-format/pnm/private/double-byte.scm create mode 100644 image-format/pnm/read.scm create mode 100644 image-format/pnm/write.scm delete mode 100644 pnm.scm delete mode 100644 pnm/image.scm delete mode 100644 pnm/pbm.scm delete mode 100644 pnm/pgm.scm delete mode 100644 pnm/ppm.scm delete mode 100644 pnm/private/bitwise.scm delete mode 100644 pnm/private/checker.scm delete mode 100644 pnm/private/double-byte.scm delete mode 100644 pnm/read.scm delete mode 100644 pnm/write.scm diff --git a/README.md b/README.md index 34ec222..54cccd9 100644 --- a/README.md +++ b/README.md @@ -6,10 +6,10 @@ accessing and modifying pixel data. ## Usage -### Import `(pnm)` library +### Import `(image-format pnm)` library ```scheme -(import (pnm)) +(import (image-format pnm)) ``` ### Image diff --git a/image-format/pnm.scm b/image-format/pnm.scm new file mode 100644 index 0000000..f4f93da --- /dev/null +++ b/image-format/pnm.scm @@ -0,0 +1,39 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm) + (export make-pbm-image + make-ppm-image + make-pgm-image + pnm-image? + pnm-image-type + pnm-image-width + pnm-image-height + pnm-image-maxval + pnm-image-ref + pnm-image-set! + pnm-image-read + pnm-parse-error? + pnm-image-write) + (import (scheme base) + (image-format pnm image) + (image-format pnm pbm) + (image-format pnm pgm) + (image-format pnm ppm) + (image-format pnm read) + (image-format pnm write))) diff --git a/image-format/pnm/image.scm b/image-format/pnm/image.scm new file mode 100644 index 0000000..2e64752 --- /dev/null +++ b/image-format/pnm/image.scm @@ -0,0 +1,53 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm image) + (export make-pnm-image + pnm-image? + pnm-image-type + pnm-image-width + pnm-image-height + pnm-image-maxval + pnm-image-data + pnm-image-pixel-getter + pnm-image-pixel-setter + pnm-image-ref + pnm-image-set!) + (import (scheme base) + (scheme case-lambda)) + (begin + (define-record-type + (make-pnm-image type width height maxval data pixel-getter pixel-setter) + pnm-image? + (type pnm-image-type) + (width pnm-image-width) + (height pnm-image-height) + (maxval pnm-image-maxval) + (data pnm-image-data) + (pixel-getter pnm-image-pixel-getter) + (pixel-setter pnm-image-pixel-setter)) + + (define (pnm-image-ref pnm-image x y) + ((pnm-image-pixel-getter pnm-image) x y)) + + (define pnm-image-set! + (case-lambda + ((pnm-image x y v) + ((pnm-image-pixel-setter pnm-image) x y v)) + ((pnm-image x y r g b) + ((pnm-image-pixel-setter pnm-image) x y r g b)))))) diff --git a/image-format/pnm/pbm.scm b/image-format/pnm/pbm.scm new file mode 100644 index 0000000..eda2677 --- /dev/null +++ b/image-format/pnm/pbm.scm @@ -0,0 +1,70 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm pbm) + (export make-pbm-image + %make-pbm-image) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image) + (image-format pnm private checker) + (image-format pnm private bitwise)) + (begin + (define make-pbm-image + (case-lambda + ((width height) + (make-pbm-image width height #f)) + ((width height unsafe?) + (let* ((byte-width (ceiling (/ width 8))) + (byte-count (* byte-width height)) + (data (make-bytevector byte-count 0))) + (%make-pbm-image width height data unsafe?))))) + + (define (%make-pbm-image width height data unsafe?) + (let* ((byte-width (ceiling (/ width 8))) + (byte-count (* byte-width height))) + (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))))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (let ((check-xy (make-xy-checker width height)) + (check-boolean-value (make-boolean-value-checker))) + (make-pnm-image 'pbm width height #t data + (if unsafe? + pixel-getter + (lambda (x y) + (check-xy x y) + (pixel-getter x y))) + (if unsafe? + pixel-setter + (lambda (x y v) + (check-xy x y) + (check-boolean-value v) + (pixel-setter x y v))))))))) 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 +;;; +;;; 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 . + +(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)))))))) diff --git a/image-format/pnm/ppm.scm b/image-format/pnm/ppm.scm new file mode 100644 index 0000000..2a644bf --- /dev/null +++ b/image-format/pnm/ppm.scm @@ -0,0 +1,111 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm ppm) + (export make-ppm-image + %make-ppm-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-ppm-image + (case-lambda + ((width height) + (make-ppm-image width height 255)) + ((width height maxval) + (make-ppm-image width height maxval #f)) + ((width height maxval unsafe?) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(image-format pnm ppm) make-ppm-image: Maxval is out of range")) + (let ((data (make-bytevector (* width + height + (if (< maxval 256) + 3 + 6)) + 0))) + (%make-ppm-image width height maxval data unsafe?))))) + + (define (%make-ppm-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-r (make-value-checker maxval 'r)) + (check-value-g (make-value-checker maxval 'g)) + (check-value-b (make-value-checker maxval 'b))) + (lambda (x y r g b) + (check-xy x y) + (check-value-r r) + (check-value-g g) + (check-value-b b) + (pixel-setter x y r g b)))) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(image-format pnm ppm) make-ppm-image: Maxval is out of range")) + (if (< maxval 256) + (let* ((w*3 (* width 3)) + (byte-count (* w*3 height))) + (define (xy->idx x y) (+ (* 3 x) (* y w*3))) + (define (pixel-getter x y) + (let ((idx (xy->idx x y))) + (values (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1)) + (bytevector-u8-ref data (+ idx 2))))) + (define (pixel-setter x y r g b) + (let ((idx (xy->idx x y))) + (bytevector-u8-set! data idx r) + (bytevector-u8-set! data (+ idx 1) g) + (bytevector-u8-set! data (+ idx 2) b))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (make-pnm-image 'ppm 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* ((w*6 (* width 6)) + (byte-count (* w*6 height))) + (define (xy->idx x y) (+ (* 6 x) (* y w*6))) + (define (pixel-getter x y) + (let ((idx (xy->idx x y))) + (values (combine-bytes (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1))) + (combine-bytes (bytevector-u8-ref data (+ idx 2)) + (bytevector-u8-ref data (+ idx 3))) + (combine-bytes (bytevector-u8-ref data (+ idx 4)) + (bytevector-u8-ref data (+ idx 5)))))) + (define (pixel-setter x y r g b) + (let ((idx (xy->idx x y))) + (let-values (((r1 r2) (split-double-byte r)) + ((g1 g2) (split-double-byte g)) + ((b1 b2) (split-double-byte b))) + (bytevector-u8-set! data idx r1) + (bytevector-u8-set! data (+ idx 1) r2) + (bytevector-u8-set! data (+ idx 2) g1) + (bytevector-u8-set! data (+ idx 3) g2) + (bytevector-u8-set! data (+ idx 4) b1) + (bytevector-u8-set! data (+ idx 5) b2)))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (make-pnm-image 'ppm width height maxval data + (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter)) + (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter)))))))) diff --git a/image-format/pnm/private/bitwise.scm b/image-format/pnm/private/bitwise.scm new file mode 100644 index 0000000..ffca4e9 --- /dev/null +++ b/image-format/pnm/private/bitwise.scm @@ -0,0 +1,38 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm private bitwise) + (export bitwise-and + bitwise-ior + arithmetic-shift + bit-set? + copy-bit) + (import (scheme base)) + (cond-expand + ((library (scheme bitwise)) + (import (only (scheme bitwise) + bitwise-and bitwise-ior arithmetic-shift + bit-set? copy-bit))) + ((library (srfi 60)) + (import (only (srfi 60) + bitwise-and bitwise-ior arithmetic-shift + bit-set? copy-bit))) + ((library (srfi 151)) + (import (only (srfi 151) + bitwise-and bitwise-ior arithmetic-shift + bit-set? copy-bit))))) diff --git a/image-format/pnm/private/checker.scm b/image-format/pnm/private/checker.scm new file mode 100644 index 0000000..8b7fcb6 --- /dev/null +++ b/image-format/pnm/private/checker.scm @@ -0,0 +1,65 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm private checker) + (export make-xy-checker + make-value-checker + make-boolean-value-checker) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image)) + (begin + (define (make-xy-checker width height) + (lambda (x y) + (when (or (not (exact-integer? x)) + (< x 0) + (<= width x)) + (error (string-append "`x` must be an integer such that 0 <= `x` < " + (number->string width)) + x)) + (when (and (not (exact-integer? y)) + (< y 0) + (<= height y)) + (error (string-append "`y` must be an integer such that 0 <= `y` < " + (number->string width)) + y)))) + + (define (make-value-checker maxval sym) + (define message + (string-append "`" (symbol->string sym) "`" + " must be an integer such that 0 < " + "`" (symbol->string sym) "`" + " < " + (number->string maxval))) + (lambda (v) + (when (or (not (exact-integer? v)) + (< v 0) + (< maxval v)) + (error message v)))) + + (define (make-boolean-value-checker) + (lambda (v) + (when (not (boolean? v)) + (error "`v` must be a boolean value" v)))) + + (define (split-value v) + (values (modulo (quotient v 256) 256) + (modulo v 256))) + + (define (combine-values l r) + (+ (* 256 l) r)))) diff --git a/image-format/pnm/private/double-byte.scm b/image-format/pnm/private/double-byte.scm new file mode 100644 index 0000000..156b409 --- /dev/null +++ b/image-format/pnm/private/double-byte.scm @@ -0,0 +1,29 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm private double-byte) + (export split-double-byte combine-bytes) + (import (scheme base) + (image-format pnm private bitwise)) + (begin + (define (split-double-byte v) + (values (arithmetic-shift v -8) + (bitwise-and v 255))) + + (define (combine-bytes l r) + (bitwise-ior (arithmetic-shift l 8) r)))) diff --git a/image-format/pnm/read.scm b/image-format/pnm/read.scm new file mode 100644 index 0000000..0086113 --- /dev/null +++ b/image-format/pnm/read.scm @@ -0,0 +1,253 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm read) + (export pnm-image-read + pnm-parse-error?) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image) + (image-format pnm pbm) + (image-format pnm pgm) + (image-format pnm ppm)) + (begin + (define pnm-image-read + (case-lambda + ((in) + (pnm-image-read in #f)) + ((in unsafe?) + (define (read-u8*) + (let ((u8 (read-u8 in))) + (when (eof-object? u8) + (unexpected-eof-error)) + u8)) + (define (read-magic-number*) + (let ((magic-number (read-magic-number in))) + (when (eof-object? magic-number) + (unexpected-eof-error)) + (unless magic-number + (unexpected-magic-number-error)) + magic-number)) + (define (read-number*) + (let ((n (read-number in))) + (when (eof-object? n) + (unexpected-eof-error)) + (unless n + (unexpected-character-error)) + n)) + (define (read-whitespaces*) + (let ((result (read-whitespaces in))) + (when (eof-object? result) + (unexpected-eof-error)) + (unless result + (unexpected-character-error)))) + (define (read-single-whitespace*) + (unless (whitespace? (read-u8*)) + (unexpected-character-error))) + + (let ((magic-number (read-magic-number*))) + (read-whitespaces*) + (let ((width (read-number in))) + (read-whitespaces*) + (let ((height (read-number in))) + (case magic-number + ((P4) + (read-single-whitespace*) + (%make-pbm-image width height + (read-bytevector (* (ceiling (/ width 8)) height) in) + unsafe?)) + ((P1) + (let ((byte-width (ceiling (/ width 8))) + (pbm-image (make-pbm-image width height unsafe?))) + (read-text-raster width height #f in + (lambda (x y v) + (pnm-image-set! pbm-image x y (= v 1))) + unexpected-eof-error + unexpected-character-error) + pbm-image)) + (else + (read-whitespaces*) + (let ((maxval (read-number in))) + (case magic-number + ((P6) + (read-single-whitespace*) + (%make-ppm-image width height maxval + (if (< maxval 256) + (read-bytevector (* 3 width height) in) + (read-bytevector (* 6 width height) in)) + unsafe?)) + ((P3) + (let ((ppm-image (make-ppm-image width height maxval unsafe?))) + (read-text-raster width height #t in (pnm-image-pixel-setter ppm-image) + unexpected-eof-error + unexpected-character-error) + ppm-image)) + ((P5) + (read-single-whitespace*) + (%make-pgm-image width height maxval + (if (< maxval 256) + (read-bytevector (* width height) in) + (read-bytevector (* 2 width height) in)) + unsafe?)) + ((P2) + (let ((pgm-image (make-pgm-image width height maxval unsafe?))) + (read-text-raster width height #f in (pnm-image-pixel-setter pgm-image) + unexpected-eof-error + unexpected-character-error) + pgm-image)))))))))))) + + (define (whitespace? u8) + (case (integer->char u8) + ((#\newline + #\return + #\tab + #\space + #\x000B ;; Vertical Tab + #\x000c ;; Form Feed + ) + #t) + (else #f))) + + (define (comment? u8) + (char=? #\# (integer->char u8))) + + (define (newline? u8) + (case (integer->char u8) + ((#\newline) #t) + (else #f))) + + (define (read-comment in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((newline? u8) + (read-u8 in) + (skip-whitespace in)) + (else + (read-u8 in) + (read-comment in))))) + + (define (skip-whitespace in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) #t) + ((whitespace? u8) + (read-u8 in) + (skip-whitespace in)) + ((comment? u8) + (read-u8 in) + (read-comment in)) + (else #t)))) + + (define (digit? u8) + (and (<= 48 u8) + (<= u8 57))) + + (define (u8->integer u8) + (- u8 48)) + + (define (read-magic-number in) + (let* ((P/u8 (char->integer #\P)) + (u8-1 (read-u8 in)) + (u8-2 (read-u8 in)) + (u8-2/int (u8->integer u8-2))) + (cond ((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) + ((and (= u8-1 P/u8) (= u8-2/int 3)) 'P3) + ((and (= u8-1 P/u8) (= u8-2/int 2)) 'P2) + ((and (= u8-1 P/u8) (= u8-2/int 1)) 'P1) + (else #f)))) + + (define (read-whitespaces in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((whitespace? u8) + (read-u8 in) + (skip-whitespace in)) + (else #f)))) + + (define (read-text-raster width height rgb? in proc fail-eof-object fail-unexpected-char) + (call-with-current-continuation + (lambda (return) + (define (read-whitespaces*) + (let ((result (read-whitespaces in))) + (when (eof-object? result) + (return (fail-eof-object))) + (unless result + (return (fail-unexpected-char))))) + (define (read-number*) + (let ((number (read-number in))) + (when (eof-object? number) + (return (fail-eof-object))) + (unless number + (return (fail-unexpected-char))) + number)) + (let ((size (* width height))) + (do ((y 0 (+ y 1))) + ((= y height)) + (do ((x 0 (+ x 1))) + ((= x width)) + (if rgb? + (let* ((r (begin (read-whitespaces*) (read-number*))) + (g (begin (read-whitespaces*) (read-number*))) + (b (begin (read-whitespaces*) (read-number*)))) + (proc x y r g b)) + (proc x y (begin (read-whitespaces*) (read-number*)))))))))) + + (define (read-number in) + (call-with-current-continuation + (lambda (return) + (let ((u8 (peek-u8 in))) + (when (eof-object? u8) + (return (eof-object))) + (when (not (digit? u8)) + (return #f))) + (let loop ((number 0)) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((digit? u8) + (read-u8 in) + (loop (+ (* number 10) (u8->integer u8)))) + (else number))))))) + + (define (unexpected-magic-number-error) + (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Not supported magic number"))) + (define (unexpected-eof-error) + (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Unexpected end of file"))) + (define (unexpected-character-error) + (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Unexpected character")))) + (cond-expand + ((library (srfi 35)) + (import (srfi 35)) + (begin + (define-condition-type &pnm-parse-error &error + pnm-parse-error?) + + (define (pnm-parse-error msg) + (raise (condition (&pnm-parse-error) + (&message + (message msg))))))) + (r7rs + (begin + (define-record-type + (make-pnm-parse-error message) + pnm-parse-error? + (message pnm-parse-error-message)) + + (define (pnm-parse-error msg) + (raise (make-pnm-parse-error msg))))))) diff --git a/image-format/pnm/write.scm b/image-format/pnm/write.scm new file mode 100644 index 0000000..b2f807c --- /dev/null +++ b/image-format/pnm/write.scm @@ -0,0 +1,123 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (image-format pnm write) + (export pnm-image-write) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image)) + (begin + (define pnm-image-write + (case-lambda + ((pnm-image out) + (case (pnm-image-type pnm-image) + ((ppm) + (write-string-u8 "P6\n" out)) + ((pgm) + (write-string-u8 "P5\n" out)) + ((pbm) + (write-string-u8 "P4\n" out)) + (else + (error "(image-format pnm write) pnm-image-write: Not supported type" (pnm-image-type pnm-image)))) + (write-string-u8 (number->string (pnm-image-width pnm-image)) out) + (write-string-u8 " " out) + (write-string-u8 (number->string (pnm-image-height pnm-image)) out) + (write-string-u8 "\n" out) + (case (pnm-image-type pnm-image) + ((pgm ppm) + (write-string-u8 (number->string (pnm-image-maxval pnm-image)) out) + (write-string-u8 "\n" out))) + (write-bytevector (pnm-image-data pnm-image) out)) + ((pnm-image out plain?) + (if plain? + (pnm-image-write/plan pnm-image out) + (pnm-image-write pnm-image out))))) + + (define (pnm-image-write/plan pnm-image out) + (case (pnm-image-type pnm-image) + ((ppm) + (write-string-u8 "P3\n" out)) + ((pgm) + (write-string-u8 "P2\n" out)) + ((pbm) + (write-string-u8 "P1\n" out)) + (else + (error "(image-format pnm write) image-write: Not supported type" (pnm-image-type pnm-image)))) + (write-string-u8 (number->string (pnm-image-width pnm-image)) out) + (write-string-u8 " " out) + (write-string-u8 (number->string (pnm-image-height pnm-image)) out) + (write-string-u8 "\n" out) + (case (pnm-image-type pnm-image) + ((pgm ppm) + (write-string-u8 (number->string (pnm-image-maxval pnm-image)) out) + (write-string-u8 "\n" out))) + (let-values (((write-token write-newline) + (limit-line-length-writer 70 out))) + (let ((width (pnm-image-width pnm-image)) + (height (pnm-image-height pnm-image))) + (define (write-raster write-pixel) + (do ((y 0 (+ y 1))) + ((= y height)) + (write-pixel 0 y) + (do ((x 1 (+ x 1))) + ((= x width)) + (write-pixel x y)) + (write-newline))) + (case (pnm-image-type pnm-image) + ((ppm) + (write-raster + (lambda (x y) + (let-values (((r g b) (pnm-image-ref pnm-image x y))) + (write-token (number->string r)) + (write-token (number->string g)) + (write-token (number->string b)))))) + ((pgm) + (write-raster + (lambda (x y) + (let ((v (pnm-image-ref pnm-image x y))) + (write-token (number->string v)))))) + ((pbm) + (write-raster + (lambda (x y) + (let ((b (pnm-image-ref pnm-image x y))) + (write-token (if b "1" "0")))))))))) + + (define (write-string-u8 str out) + (string-for-each (lambda (c) (write-u8 (char->integer c) out)) + str)) + + (define (limit-line-length-writer limit out) + (let ((current-length 0)) + (define (write-token str) + (let ((str-len (string-length str))) + (cond ((zero? current-length) + (write-string-u8 str out) + (set! current-length str-len)) + ((<= (+ current-length str-len 1) limit) + (write-string-u8 " " out) + (write-string-u8 str out) + (set! current-length (+ current-length 1 str-len))) + (else + (write-string-u8 "\n" out) + (write-string-u8 str out) + (set! current-length str-len))))) + (define (write-newline) + (write-string-u8 "\n" out) + (set! current-length 0)) + (values write-token + write-newline))))) diff --git a/pnm.scm b/pnm.scm deleted file mode 100644 index 46fc730..0000000 --- a/pnm.scm +++ /dev/null @@ -1,39 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm) - (export make-pbm-image - make-ppm-image - make-pgm-image - pnm-image? - pnm-image-type - pnm-image-width - pnm-image-height - pnm-image-maxval - pnm-image-ref - pnm-image-set! - pnm-image-read - pnm-parse-error? - pnm-image-write) - (import (scheme base) - (pnm image) - (pnm pbm) - (pnm pgm) - (pnm ppm) - (pnm read) - (pnm write))) diff --git a/pnm/image.scm b/pnm/image.scm deleted file mode 100644 index f9d0b83..0000000 --- a/pnm/image.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm image) - (export make-pnm-image - pnm-image? - pnm-image-type - pnm-image-width - pnm-image-height - pnm-image-maxval - pnm-image-data - pnm-image-pixel-getter - pnm-image-pixel-setter - pnm-image-ref - pnm-image-set!) - (import (scheme base) - (scheme case-lambda)) - (begin - (define-record-type - (make-pnm-image type width height maxval data pixel-getter pixel-setter) - pnm-image? - (type pnm-image-type) - (width pnm-image-width) - (height pnm-image-height) - (maxval pnm-image-maxval) - (data pnm-image-data) - (pixel-getter pnm-image-pixel-getter) - (pixel-setter pnm-image-pixel-setter)) - - (define (pnm-image-ref pnm-image x y) - ((pnm-image-pixel-getter pnm-image) x y)) - - (define pnm-image-set! - (case-lambda - ((pnm-image x y v) - ((pnm-image-pixel-setter pnm-image) x y v)) - ((pnm-image x y r g b) - ((pnm-image-pixel-setter pnm-image) x y r g b)))))) diff --git a/pnm/pbm.scm b/pnm/pbm.scm deleted file mode 100644 index d580616..0000000 --- a/pnm/pbm.scm +++ /dev/null @@ -1,70 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm pbm) - (export make-pbm-image - %make-pbm-image) - (import (scheme base) - (scheme case-lambda) - (pnm image) - (pnm private checker) - (pnm private bitwise)) - (begin - (define make-pbm-image - (case-lambda - ((width height) - (make-pbm-image width height #f)) - ((width height unsafe?) - (let* ((byte-width (ceiling (/ width 8))) - (byte-count (* byte-width height)) - (data (make-bytevector byte-count 0))) - (%make-pbm-image width height data unsafe?))))) - - (define (%make-pbm-image width height data unsafe?) - (let* ((byte-width (ceiling (/ width 8))) - (byte-count (* byte-width height))) - (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))))) - (unless (= byte-count (bytevector-length data)) - (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) - (let ((check-xy (make-xy-checker width height)) - (check-boolean-value (make-boolean-value-checker))) - (make-pnm-image 'pbm width height #t data - (if unsafe? - pixel-getter - (lambda (x y) - (check-xy x y) - (pixel-getter x y))) - (if unsafe? - pixel-setter - (lambda (x y v) - (check-xy x y) - (check-boolean-value v) - (pixel-setter x y v))))))))) diff --git a/pnm/pgm.scm b/pnm/pgm.scm deleted file mode 100644 index 5a4f027..0000000 --- a/pnm/pgm.scm +++ /dev/null @@ -1,91 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm pgm) - (export make-pgm-image - %make-pgm-image) - (import (scheme base) - (scheme case-lambda) - (pnm image) - (pnm private checker) - (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 "(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 "(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 "(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 "(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)))))))) diff --git a/pnm/ppm.scm b/pnm/ppm.scm deleted file mode 100644 index ff1abb3..0000000 --- a/pnm/ppm.scm +++ /dev/null @@ -1,111 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm ppm) - (export make-ppm-image - %make-ppm-image) - (import (scheme base) - (scheme case-lambda) - (pnm image) - (pnm private checker) - (pnm private double-byte)) - (begin - (define make-ppm-image - (case-lambda - ((width height) - (make-ppm-image width height 255)) - ((width height maxval) - (make-ppm-image width height maxval #f)) - ((width height maxval unsafe?) - (when (or (< maxval 0) - (< 65536 maxval)) - (error "(pnm ppm) make-ppm-image: Maxval is out of range")) - (let ((data (make-bytevector (* width - height - (if (< maxval 256) - 3 - 6)) - 0))) - (%make-ppm-image width height maxval data unsafe?))))) - - (define (%make-ppm-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-r (make-value-checker maxval 'r)) - (check-value-g (make-value-checker maxval 'g)) - (check-value-b (make-value-checker maxval 'b))) - (lambda (x y r g b) - (check-xy x y) - (check-value-r r) - (check-value-g g) - (check-value-b b) - (pixel-setter x y r g b)))) - (when (or (< maxval 0) - (< 65536 maxval)) - (error "(pnm ppm) make-ppm-image: Maxval is out of range")) - (if (< maxval 256) - (let* ((w*3 (* width 3)) - (byte-count (* w*3 height))) - (define (xy->idx x y) (+ (* 3 x) (* y w*3))) - (define (pixel-getter x y) - (let ((idx (xy->idx x y))) - (values (bytevector-u8-ref data idx) - (bytevector-u8-ref data (+ idx 1)) - (bytevector-u8-ref data (+ idx 2))))) - (define (pixel-setter x y r g b) - (let ((idx (xy->idx x y))) - (bytevector-u8-set! data idx r) - (bytevector-u8-set! data (+ idx 1) g) - (bytevector-u8-set! data (+ idx 2) b))) - (unless (= byte-count (bytevector-length data)) - (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) - (make-pnm-image 'ppm 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* ((w*6 (* width 6)) - (byte-count (* w*6 height))) - (define (xy->idx x y) (+ (* 6 x) (* y w*6))) - (define (pixel-getter x y) - (let ((idx (xy->idx x y))) - (values (combine-bytes (bytevector-u8-ref data idx) - (bytevector-u8-ref data (+ idx 1))) - (combine-bytes (bytevector-u8-ref data (+ idx 2)) - (bytevector-u8-ref data (+ idx 3))) - (combine-bytes (bytevector-u8-ref data (+ idx 4)) - (bytevector-u8-ref data (+ idx 5)))))) - (define (pixel-setter x y r g b) - (let ((idx (xy->idx x y))) - (let-values (((r1 r2) (split-double-byte r)) - ((g1 g2) (split-double-byte g)) - ((b1 b2) (split-double-byte b))) - (bytevector-u8-set! data idx r1) - (bytevector-u8-set! data (+ idx 1) r2) - (bytevector-u8-set! data (+ idx 2) g1) - (bytevector-u8-set! data (+ idx 3) g2) - (bytevector-u8-set! data (+ idx 4) b1) - (bytevector-u8-set! data (+ idx 5) b2)))) - (unless (= byte-count (bytevector-length data)) - (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) - (make-pnm-image 'ppm width height maxval data - (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter)) - (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter)))))))) diff --git a/pnm/private/bitwise.scm b/pnm/private/bitwise.scm deleted file mode 100644 index a2f2f74..0000000 --- a/pnm/private/bitwise.scm +++ /dev/null @@ -1,38 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm private bitwise) - (export bitwise-and - bitwise-ior - arithmetic-shift - bit-set? - copy-bit) - (import (scheme base)) - (cond-expand - ((library (scheme bitwise)) - (import (only (scheme bitwise) - bitwise-and bitwise-ior arithmetic-shift - bit-set? copy-bit))) - ((library (srfi 60)) - (import (only (srfi 60) - bitwise-and bitwise-ior arithmetic-shift - bit-set? copy-bit))) - ((library (srfi 151)) - (import (only (srfi 151) - bitwise-and bitwise-ior arithmetic-shift - bit-set? copy-bit))))) diff --git a/pnm/private/checker.scm b/pnm/private/checker.scm deleted file mode 100644 index e212948..0000000 --- a/pnm/private/checker.scm +++ /dev/null @@ -1,65 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm private checker) - (export make-xy-checker - make-value-checker - make-boolean-value-checker) - (import (scheme base) - (scheme case-lambda) - (pnm image)) - (begin - (define (make-xy-checker width height) - (lambda (x y) - (when (or (not (exact-integer? x)) - (< x 0) - (<= width x)) - (error (string-append "`x` must be an integer such that 0 <= `x` < " - (number->string width)) - x)) - (when (and (not (exact-integer? y)) - (< y 0) - (<= height y)) - (error (string-append "`y` must be an integer such that 0 <= `y` < " - (number->string width)) - y)))) - - (define (make-value-checker maxval sym) - (define message - (string-append "`" (symbol->string sym) "`" - " must be an integer such that 0 < " - "`" (symbol->string sym) "`" - " < " - (number->string maxval))) - (lambda (v) - (when (or (not (exact-integer? v)) - (< v 0) - (< maxval v)) - (error message v)))) - - (define (make-boolean-value-checker) - (lambda (v) - (when (not (boolean? v)) - (error "`v` must be a boolean value" v)))) - - (define (split-value v) - (values (modulo (quotient v 256) 256) - (modulo v 256))) - - (define (combine-values l r) - (+ (* 256 l) r)))) diff --git a/pnm/private/double-byte.scm b/pnm/private/double-byte.scm deleted file mode 100644 index fd40336..0000000 --- a/pnm/private/double-byte.scm +++ /dev/null @@ -1,29 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm private double-byte) - (export split-double-byte combine-bytes) - (import (scheme base) - (pnm private bitwise)) - (begin - (define (split-double-byte v) - (values (arithmetic-shift v -8) - (bitwise-and v 255))) - - (define (combine-bytes l r) - (bitwise-ior (arithmetic-shift l 8) r)))) diff --git a/pnm/read.scm b/pnm/read.scm deleted file mode 100644 index 4c7dd52..0000000 --- a/pnm/read.scm +++ /dev/null @@ -1,253 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm read) - (export pnm-image-read - pnm-parse-error?) - (import (scheme base) - (scheme case-lambda) - (pnm image) - (pnm pbm) - (pnm pgm) - (pnm ppm)) - (begin - (define pnm-image-read - (case-lambda - ((in) - (pnm-image-read in #f)) - ((in unsafe?) - (define (read-u8*) - (let ((u8 (read-u8 in))) - (when (eof-object? u8) - (unexpected-eof-error)) - u8)) - (define (read-magic-number*) - (let ((magic-number (read-magic-number in))) - (when (eof-object? magic-number) - (unexpected-eof-error)) - (unless magic-number - (unexpected-magic-number-error)) - magic-number)) - (define (read-number*) - (let ((n (read-number in))) - (when (eof-object? n) - (unexpected-eof-error)) - (unless n - (unexpected-character-error)) - n)) - (define (read-whitespaces*) - (let ((result (read-whitespaces in))) - (when (eof-object? result) - (unexpected-eof-error)) - (unless result - (unexpected-character-error)))) - (define (read-single-whitespace*) - (unless (whitespace? (read-u8*)) - (unexpected-character-error))) - - (let ((magic-number (read-magic-number*))) - (read-whitespaces*) - (let ((width (read-number in))) - (read-whitespaces*) - (let ((height (read-number in))) - (case magic-number - ((P4) - (read-single-whitespace*) - (%make-pbm-image width height - (read-bytevector (* (ceiling (/ width 8)) height) in) - unsafe?)) - ((P1) - (let ((byte-width (ceiling (/ width 8))) - (pbm-image (make-pbm-image width height unsafe?))) - (read-text-raster width height #f in - (lambda (x y v) - (pnm-image-set! pbm-image x y (= v 1))) - unexpected-eof-error - unexpected-character-error) - pbm-image)) - (else - (read-whitespaces*) - (let ((maxval (read-number in))) - (case magic-number - ((P6) - (read-single-whitespace*) - (%make-ppm-image width height maxval - (if (< maxval 256) - (read-bytevector (* 3 width height) in) - (read-bytevector (* 6 width height) in)) - unsafe?)) - ((P3) - (let ((ppm-image (make-ppm-image width height maxval unsafe?))) - (read-text-raster width height #t in (pnm-image-pixel-setter ppm-image) - unexpected-eof-error - unexpected-character-error) - ppm-image)) - ((P5) - (read-single-whitespace*) - (%make-pgm-image width height maxval - (if (< maxval 256) - (read-bytevector (* width height) in) - (read-bytevector (* 2 width height) in)) - unsafe?)) - ((P2) - (let ((pgm-image (make-pgm-image width height maxval unsafe?))) - (read-text-raster width height #f in (pnm-image-pixel-setter pgm-image) - unexpected-eof-error - unexpected-character-error) - pgm-image)))))))))))) - - (define (whitespace? u8) - (case (integer->char u8) - ((#\newline - #\return - #\tab - #\space - #\x000B ;; Vertical Tab - #\x000c ;; Form Feed - ) - #t) - (else #f))) - - (define (comment? u8) - (char=? #\# (integer->char u8))) - - (define (newline? u8) - (case (integer->char u8) - ((#\newline) #t) - (else #f))) - - (define (read-comment in) - (let ((u8 (peek-u8 in))) - (cond ((eof-object? u8) (eof-object)) - ((newline? u8) - (read-u8 in) - (skip-whitespace in)) - (else - (read-u8 in) - (read-comment in))))) - - (define (skip-whitespace in) - (let ((u8 (peek-u8 in))) - (cond ((eof-object? u8) #t) - ((whitespace? u8) - (read-u8 in) - (skip-whitespace in)) - ((comment? u8) - (read-u8 in) - (read-comment in)) - (else #t)))) - - (define (digit? u8) - (and (<= 48 u8) - (<= u8 57))) - - (define (u8->integer u8) - (- u8 48)) - - (define (read-magic-number in) - (let* ((P/u8 (char->integer #\P)) - (u8-1 (read-u8 in)) - (u8-2 (read-u8 in)) - (u8-2/int (u8->integer u8-2))) - (cond ((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) - ((and (= u8-1 P/u8) (= u8-2/int 3)) 'P3) - ((and (= u8-1 P/u8) (= u8-2/int 2)) 'P2) - ((and (= u8-1 P/u8) (= u8-2/int 1)) 'P1) - (else #f)))) - - (define (read-whitespaces in) - (let ((u8 (peek-u8 in))) - (cond ((eof-object? u8) (eof-object)) - ((whitespace? u8) - (read-u8 in) - (skip-whitespace in)) - (else #f)))) - - (define (read-text-raster width height rgb? in proc fail-eof-object fail-unexpected-char) - (call-with-current-continuation - (lambda (return) - (define (read-whitespaces*) - (let ((result (read-whitespaces in))) - (when (eof-object? result) - (return (fail-eof-object))) - (unless result - (return (fail-unexpected-char))))) - (define (read-number*) - (let ((number (read-number in))) - (when (eof-object? number) - (return (fail-eof-object))) - (unless number - (return (fail-unexpected-char))) - number)) - (let ((size (* width height))) - (do ((y 0 (+ y 1))) - ((= y height)) - (do ((x 0 (+ x 1))) - ((= x width)) - (if rgb? - (let* ((r (begin (read-whitespaces*) (read-number*))) - (g (begin (read-whitespaces*) (read-number*))) - (b (begin (read-whitespaces*) (read-number*)))) - (proc x y r g b)) - (proc x y (begin (read-whitespaces*) (read-number*)))))))))) - - (define (read-number in) - (call-with-current-continuation - (lambda (return) - (let ((u8 (peek-u8 in))) - (when (eof-object? u8) - (return (eof-object))) - (when (not (digit? u8)) - (return #f))) - (let loop ((number 0)) - (let ((u8 (peek-u8 in))) - (cond ((eof-object? u8) (eof-object)) - ((digit? u8) - (read-u8 in) - (loop (+ (* number 10) (u8->integer u8)))) - (else number))))))) - - (define (unexpected-magic-number-error) - (raise (pnm-parse-error "(pnm read) pnm-image-read: Not supported magic number"))) - (define (unexpected-eof-error) - (raise (pnm-parse-error "(pnm read) pnm-image-read: Unexpected end of file"))) - (define (unexpected-character-error) - (raise (pnm-parse-error "(pnm read) pnm-image-read: Unexpected character")))) - (cond-expand - ((library (srfi 35)) - (import (srfi 35)) - (begin - (define-condition-type &pnm-parse-error &error - pnm-parse-error?) - - (define (pnm-parse-error msg) - (raise (condition (&pnm-parse-error) - (&message - (message msg))))))) - (r7rs - (begin - (define-record-type - (make-pnm-parse-error message) - pnm-parse-error? - (message pnm-parse-error-message)) - - (define (pnm-parse-error msg) - (raise (make-pnm-parse-error msg))))))) diff --git a/pnm/write.scm b/pnm/write.scm deleted file mode 100644 index 60dbd0e..0000000 --- a/pnm/write.scm +++ /dev/null @@ -1,123 +0,0 @@ -;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS -;;; Copyright © 2024 Masaya Tojo -;;; -;;; 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 . - -(define-library (pnm write) - (export pnm-image-write) - (import (scheme base) - (scheme case-lambda) - (pnm image)) - (begin - (define pnm-image-write - (case-lambda - ((pnm-image out) - (case (pnm-image-type pnm-image) - ((ppm) - (write-string-u8 "P6\n" out)) - ((pgm) - (write-string-u8 "P5\n" out)) - ((pbm) - (write-string-u8 "P4\n" out)) - (else - (error "(pnm write) pnm-image-write: Not supported type" (pnm-image-type pnm-image)))) - (write-string-u8 (number->string (pnm-image-width pnm-image)) out) - (write-string-u8 " " out) - (write-string-u8 (number->string (pnm-image-height pnm-image)) out) - (write-string-u8 "\n" out) - (case (pnm-image-type pnm-image) - ((pgm ppm) - (write-string-u8 (number->string (pnm-image-maxval pnm-image)) out) - (write-string-u8 "\n" out))) - (write-bytevector (pnm-image-data pnm-image) out)) - ((pnm-image out plain?) - (if plain? - (pnm-image-write/plan pnm-image out) - (pnm-image-write pnm-image out))))) - - (define (pnm-image-write/plan pnm-image out) - (case (pnm-image-type pnm-image) - ((ppm) - (write-string-u8 "P3\n" out)) - ((pgm) - (write-string-u8 "P2\n" out)) - ((pbm) - (write-string-u8 "P1\n" out)) - (else - (error "(pnm write) image-write: Not supported type" (pnm-image-type pnm-image)))) - (write-string-u8 (number->string (pnm-image-width pnm-image)) out) - (write-string-u8 " " out) - (write-string-u8 (number->string (pnm-image-height pnm-image)) out) - (write-string-u8 "\n" out) - (case (pnm-image-type pnm-image) - ((pgm ppm) - (write-string-u8 (number->string (pnm-image-maxval pnm-image)) out) - (write-string-u8 "\n" out))) - (let-values (((write-token write-newline) - (limit-line-length-writer 70 out))) - (let ((width (pnm-image-width pnm-image)) - (height (pnm-image-height pnm-image))) - (define (write-raster write-pixel) - (do ((y 0 (+ y 1))) - ((= y height)) - (write-pixel 0 y) - (do ((x 1 (+ x 1))) - ((= x width)) - (write-pixel x y)) - (write-newline))) - (case (pnm-image-type pnm-image) - ((ppm) - (write-raster - (lambda (x y) - (let-values (((r g b) (pnm-image-ref pnm-image x y))) - (write-token (number->string r)) - (write-token (number->string g)) - (write-token (number->string b)))))) - ((pgm) - (write-raster - (lambda (x y) - (let ((v (pnm-image-ref pnm-image x y))) - (write-token (number->string v)))))) - ((pbm) - (write-raster - (lambda (x y) - (let ((b (pnm-image-ref pnm-image x y))) - (write-token (if b "1" "0")))))))))) - - (define (write-string-u8 str out) - (string-for-each (lambda (c) (write-u8 (char->integer c) out)) - str)) - - (define (limit-line-length-writer limit out) - (let ((current-length 0)) - (define (write-token str) - (let ((str-len (string-length str))) - (cond ((zero? current-length) - (write-string-u8 str out) - (set! current-length str-len)) - ((<= (+ current-length str-len 1) limit) - (write-string-u8 " " out) - (write-string-u8 str out) - (set! current-length (+ current-length 1 str-len))) - (else - (write-string-u8 "\n" out) - (write-string-u8 str out) - (set! current-length str-len))))) - (define (write-newline) - (write-string-u8 "\n" out) - (set! current-length 0)) - (values write-token - write-newline))))) -- cgit v1.2.3