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 --- image-format/pnm/ppm.scm | 111 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 111 insertions(+) create mode 100644 image-format/pnm/ppm.scm (limited to 'image-format/pnm/ppm.scm') diff --git a/image-format/pnm/ppm.scm b/image-format/pnm/ppm.scm new file mode 100644 index 0000000..2a644bf --- /dev/null +++ b/image-format/pnm/ppm.scm @@ -0,0 +1,111 @@ +;;; 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 (image-format pnm ppm) + (export make-ppm-image + %make-ppm-image) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image) + (image-format pnm private checker) + (image-format pnm private double-byte)) + (begin + (define make-ppm-image + (case-lambda + ((width height) + (make-ppm-image width height 255)) + ((width height maxval) + (make-ppm-image width height maxval #f)) + ((width height maxval unsafe?) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(image-format pnm ppm) make-ppm-image: Maxval is out of range")) + (let ((data (make-bytevector (* width + height + (if (< maxval 256) + 3 + 6)) + 0))) + (%make-ppm-image width height maxval data unsafe?))))) + + (define (%make-ppm-image width height maxval data unsafe?) + (define (make-safe-pixel-getter pixel-getter) + (let ((check-xy (make-xy-checker width height))) + (lambda (x y) + (check-xy x y) + (pixel-getter x y)))) + (define (make-safe-pixel-setter pixel-setter) + (let ((check-xy (make-xy-checker width height)) + (check-value-r (make-value-checker maxval 'r)) + (check-value-g (make-value-checker maxval 'g)) + (check-value-b (make-value-checker maxval 'b))) + (lambda (x y r g b) + (check-xy x y) + (check-value-r r) + (check-value-g g) + (check-value-b b) + (pixel-setter x y r g b)))) + (when (or (< maxval 0) + (< 65536 maxval)) + (error "(image-format pnm ppm) make-ppm-image: Maxval is out of range")) + (if (< maxval 256) + (let* ((w*3 (* width 3)) + (byte-count (* w*3 height))) + (define (xy->idx x y) (+ (* 3 x) (* y w*3))) + (define (pixel-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 (pixel-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))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (make-pnm-image 'ppm width height maxval data + (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter)) + (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter)))) + (let* ((w*6 (* width 6)) + (byte-count (* w*6 height))) + (define (xy->idx x y) (+ (* 6 x) (* y w*6))) + (define (pixel-getter x y) + (let ((idx (xy->idx x y))) + (values (combine-bytes (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1))) + (combine-bytes (bytevector-u8-ref data (+ idx 2)) + (bytevector-u8-ref data (+ idx 3))) + (combine-bytes (bytevector-u8-ref data (+ idx 4)) + (bytevector-u8-ref data (+ idx 5)))))) + (define (pixel-setter x y r g b) + (let ((idx (xy->idx x y))) + (let-values (((r1 r2) (split-double-byte r)) + ((g1 g2) (split-double-byte g)) + ((b1 b2) (split-double-byte 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)))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (make-pnm-image 'ppm width height maxval data + (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter)) + (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter)))))))) -- cgit v1.2.3