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 --- pnm/write.scm | 123 ---------------------------------------------------------- 1 file changed, 123 deletions(-) delete mode 100644 pnm/write.scm (limited to 'pnm/write.scm') 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