From f7fed1949869f64c4f71936d12c8ae032e8f9005 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sat, 3 Aug 2024 17:09:05 +0900 Subject: Split pnm/pgm.scm and pnm/ppm.scm to organize interfaces --- pnm/pgm.scm | 219 ++++++++++++------------------------------------------------ 1 file changed, 44 insertions(+), 175 deletions(-) (limited to 'pnm/pgm.scm') diff --git a/pnm/pgm.scm b/pnm/pgm.scm index 7f1675c..5abbab2 100644 --- a/pnm/pgm.scm +++ b/pnm/pgm.scm @@ -15,186 +15,55 @@ ;;; ;;; 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)) + (export make-pgm-image) + (import (scheme base) + (scheme case-lambda) + (pnm image)) (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 make-pgm-image + (case-lambda + ((width height maxval) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(pnm pgm) make-pgm: maxval is out of range")) + (let ((data (make-bytevector (* width + height + (if (< maxval 256) + 1 + 2)) + 0))) + (make-pgm-image width height maxval data))) + ((width height maxval data) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(pnm pgm) make-pgm: 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 'pgm 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 'pgm 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)))) + (+ (* 256 l) r)))) -- cgit v1.2.3