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/read.scm | 253 ----------------------------------------------------------- 1 file changed, 253 deletions(-) delete mode 100644 pnm/read.scm (limited to 'pnm/read.scm') 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))))))) -- cgit v1.2.3