diff options
author | Masaya Tojo <masaya@tojo.tokyo> | 2024-08-10 23:08:10 +0900 |
---|---|---|
committer | Masaya Tojo <masaya@tojo.tokyo> | 2024-08-10 23:13:11 +0900 |
commit | 9d052c650ba59ddc8132bce881bd487df31c5348 (patch) | |
tree | 6437286280cf2694f4220809c3c7d92a15a406d5 /image-format/pnm/write.scm | |
parent | e59d89f39f090f8feb16a48ed150e5ac48c2858f (diff) |
Add `image-format` prefix to library name
Diffstat (limited to 'image-format/pnm/write.scm')
-rw-r--r-- | image-format/pnm/write.scm | 123 |
1 files changed, 123 insertions, 0 deletions
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 <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 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))))) |