From 831e793851d6a3be1b3fb0e6050af84715618aca Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sat, 3 Aug 2024 13:20:42 +0900 Subject: Initial commit --- pnm/pgm.scm | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ pnm/ppm.scm | 214 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 414 insertions(+) create mode 100644 pnm/pgm.scm create mode 100644 pnm/ppm.scm (limited to 'pnm') diff --git a/pnm/pgm.scm b/pnm/pgm.scm new file mode 100644 index 0000000..7f1675c --- /dev/null +++ b/pnm/pgm.scm @@ -0,0 +1,200 @@ +;;; 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-image + image-width + image-height + image-maxval + image-ref + image-set! + image-read + image-write) + (import (scheme base)) + (begin + (define-record-type + (%make-image width height maxval data getter setter) + image? + (width image-width) + (height image-height) + (maxval image-maxval) + (data image-data) + (getter image-getter) + (setter image-setter)) + + (define (make-image width height maxval) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(pnm pgm) make-image: maxval is out of range")) + (let ((data (make-bytevector (* width + height + (if (< maxval 256) + 1 + 2)) + 0))) + (make-image* width height maxval data))) + + (define (make-image* width height maxval data) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(pnm pgm) make-image: maxval is out of range")) + (if (< maxval 256) + (let () + (define (xy->idx x y) (+ x (* y width))) + (define (getter x y) + (let ((idx (xy->idx x y))) + (bytevector-u8-ref data idx))) + (define (setter x y v) + (let ((idx (xy->idx x y))) + (bytevector-u8-set! data idx v))) + (%make-image width height maxval data getter setter)) + (let () + (define (xy->idx x y) (+ x (* y width))) + (define (getter x y) + (let ((idx (xy->idx x y))) + (combine-values (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1))))) + (define (setter x y v) + (let ((idx (xy->idx x y))) + (let-values (((v1 v2) (split-value v))) + (bytevector-u8-set! data idx v1) + (bytevector-u8-set! data (+ idx 1) v2)))) + (%make-image width height maxval data getter setter)))) + + (define (split-value v) + (values (modulo (quotient v 256) 256) + (modulo v 256))) + + (define (combine-values l r) + (+ (* 256 l) r)) + + (define (image-set! image x y v) + ((image-setter image) x y v)) + + (define (image-ref image x y) + ((image-getter image) x y)) + + (define (image-read in) + (define (unexpected-eof-error) + (error "(pnm pgm) image-read: Unexpected end of file")) + (define (unexpected-char-error) + (error "(pnm pgm) image-read: Unexpected character")) + (define (read-u8*) + (let ((u8 (read-u8 in))) + (when (eof-object? u8) + (unexpected-eof-error)) + u8)) + (define (read-number*) + (let ((n (read-number in))) + (when (eof-object? n) + (unexpected-eof-error)) + (unless n + (unexpected-char-error)) + n)) + (define (read-whitespaces*) + (when (eof-object? (read-whitespaces in)) + (unexpected-eof-error))) + (let ((u8-1 (read-u8*)) + (u8-2 (read-u8*))) + (unless (p5? u8-1 u8-2) + (error "(pnm pgm) image-read: No expected magic number (expected P5)")) + (read-whitespaces*) + (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)) + (make-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) + ((#\newline #\return #\tab #\space) #t) + (else #f))) + + (define (comment? u8) + (char=? #\# (integer->char u8))) + + (define (newline? u8) + (case (integer->char u8) + ((#\newline #\return) #t) + (else #f))) + + (define (read-comment in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((newline? u8) + (read-u8 in) + (read-whitespaces in)) + (else + (read-u8 in) + (read-comment in))))) + + (define (digit? u8) + (and (<= 48 u8) + (<= u8 57))) + + (define (u8->integer u8) + (- u8 48)) + + (define (p5? u8-1 u8-2) + (and (= (char->integer #\P) u8-1) + (= (char->integer #\5) u8-2))) + + (define (read-whitespaces in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((whitespace? u8) + (read-u8 in) + (read-whitespaces in)) + ((comment? u8) + (read-u8 in) + (read-comment in)) + (else #t)))) + + (define (read-number in) + (call-with-current-continuation + (lambda (return) + (let ((u8 (peek-u8 in))) + (when (or (eof-object? u8) + (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 (image-write image out) + (define (write-string-u8 str) + (string-for-each (lambda (c) (write-u8 (char->integer c) out)) + str)) + (write-string-u8 "P5\n") + (write-string-u8 (number->string (image-width image))) + (write-string-u8 "\n") + (write-string-u8 (number->string (image-height image))) + (write-string-u8 "\n") + (write-string-u8 (number->string (image-maxval image))) + (write-string-u8 "\n") + (write-bytevector (image-data image) out)))) diff --git a/pnm/ppm.scm b/pnm/ppm.scm new file mode 100644 index 0000000..f936e4b --- /dev/null +++ b/pnm/ppm.scm @@ -0,0 +1,214 @@ +;;; 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-image + image-width + image-height + image-maxval + image-ref + image-set! + image-read + image-write) + (import (scheme base)) + (begin + (define-record-type + (%make-image width height maxval data getter setter) + image? + (width image-width) + (height image-height) + (maxval image-maxval) + (data image-data) + (getter image-getter) + (setter image-setter)) + + (define (make-image width height maxval) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(pnm ppm) make-image: maxval is out of range")) + (let ((data (make-bytevector (* width + height + (if (< maxval 256) + 3 + 6)) + 0))) + (make-image* width height maxval data))) + + (define (make-image* width height maxval data) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(pnm ppm) make-image: maxval is out of range")) + (if (< maxval 256) + (let* ((w*3 (* width 3))) + (define (xy->idx x y) (+ (* 3 x) (* y w*3))) + (define (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 (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))) + (%make-image width height maxval data getter setter)) + (let* ((w*6 (* width 6))) + (define (xy->idx x y) (+ (* 6 x) (* y w*6))) + (define (getter x y) + (let ((idx (xy->idx x y))) + (values (combine-values (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1))) + (combine-values (bytevector-u8-ref data (+ idx 2)) + (bytevector-u8-ref data (+ idx 3))) + (combine-values (bytevector-u8-ref data (+ idx 4)) + (bytevector-u8-ref data (+ idx 5)))))) + (define (setter x y r g b) + (let ((idx (xy->idx x y))) + (let-values (((r1 r2) (split-value r)) + ((g1 g2) (split-value g)) + ((b1 b2) (split-value 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)))) + (%make-image width height maxval data getter setter)))) + + (define (split-value v) + (values (modulo (quotient v 256) 256) + (modulo v 256))) + + (define (combine-values l r) + (+ (* 256 l) r)) + + (define (image-set! image x y r g b) + ((image-setter image) x y r g b)) + + (define (image-ref image x y) + ((image-getter image) x y)) + + (define (image-read in) + (define (unexpected-eof-error) + (error "(pnm ppm) image-read: Unexpected end of file")) + (define (unexpected-char-error) + (error "(pnm ppm) image-read: Unexpected character")) + (define (read-u8*) + (let ((u8 (read-u8 in))) + (when (eof-object? u8) + (unexpected-eof-error)) + u8)) + (define (read-number*) + (let ((n (read-number in))) + (when (eof-object? n) + (unexpected-eof-error)) + (unless n + (unexpected-char-error)) + n)) + (define (read-whitespaces*) + (when (eof-object? (read-whitespaces in)) + (unexpected-eof-error))) + (let ((u8-1 (read-u8*)) + (u8-2 (read-u8*))) + (unless (p6? u8-1 u8-2) + (error "(pnm ppm) image-read: No expected magic number (expected P6)")) + (read-whitespaces*) + (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)) + (make-image* width height maxval + (if (< maxval 256) + (read-bytevector (* 3 width height) in) + (read-bytevector (* 6 width height) in)))))))) + + (define (whitespace? u8) + (case (integer->char u8) + ((#\newline #\return #\tab #\space) #t) + (else #f))) + + (define (comment? u8) + (char=? #\# (integer->char u8))) + + (define (newline? u8) + (case (integer->char u8) + ((#\newline #\return) #t) + (else #f))) + + (define (read-comment in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((newline? u8) + (read-u8 in) + (read-whitespaces in)) + (else + (read-u8 in) + (read-comment in))))) + + (define (digit? u8) + (and (<= 48 u8) + (<= u8 57))) + + (define (u8->integer u8) + (- u8 48)) + + (define (p6? u8-1 u8-2) + (and (= (char->integer #\P) u8-1) + (= (char->integer #\6) u8-2))) + + (define (read-whitespaces in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((whitespace? u8) + (read-u8 in) + (read-whitespaces in)) + ((comment? u8) + (read-u8 in) + (read-comment in)) + (else #t)))) + + (define (read-number in) + (call-with-current-continuation + (lambda (return) + (let ((u8 (peek-u8 in))) + (when (or (eof-object? u8) + (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 (image-write image out) + (define (write-string-u8 str) + (string-for-each (lambda (c) (write-u8 (char->integer c) out)) + str)) + (write-string-u8 "P6\n") + (write-string-u8 (number->string (image-width image))) + (write-string-u8 "\n") + (write-string-u8 (number->string (image-height image))) + (write-string-u8 "\n") + (write-string-u8 (number->string (image-maxval image))) + (write-string-u8 "\n") + (write-bytevector (image-data image) out)))) -- cgit v1.2.3