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/pbm.scm | 70 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 image-format/pnm/pbm.scm (limited to 'image-format/pnm/pbm.scm') diff --git a/image-format/pnm/pbm.scm b/image-format/pnm/pbm.scm new file mode 100644 index 0000000..eda2677 --- /dev/null +++ b/image-format/pnm/pbm.scm @@ -0,0 +1,70 @@ +;;; 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 pbm) + (export make-pbm-image + %make-pbm-image) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image) + (image-format pnm private checker) + (image-format pnm private bitwise)) + (begin + (define make-pbm-image + (case-lambda + ((width height) + (make-pbm-image width height #f)) + ((width height unsafe?) + (let* ((byte-width (ceiling (/ width 8))) + (byte-count (* byte-width height)) + (data (make-bytevector byte-count 0))) + (%make-pbm-image width height data unsafe?))))) + + (define (%make-pbm-image width height data unsafe?) + (let* ((byte-width (ceiling (/ width 8))) + (byte-count (* byte-width height))) + (define (xy->byte-idx+bit-idx x y) + (let-values (((byte-x bit-x) (floor/ x 8))) + (values (+ (* y byte-width) + byte-x) + bit-x))) + (define (pixel-getter x y) + (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y))) + (let ((byte (bytevector-u8-ref data byte-idx))) + (bit-set? (- 7 bit-idx) byte)))) + (define (pixel-setter x y b) + (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y))) + (let ((byte (bytevector-u8-ref data byte-idx))) + (bytevector-u8-set! data byte-idx + (copy-bit (- 7 bit-idx) byte b))))) + (unless (= byte-count (bytevector-length data)) + (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (let ((check-xy (make-xy-checker width height)) + (check-boolean-value (make-boolean-value-checker))) + (make-pnm-image 'pbm width height #t data + (if unsafe? + pixel-getter + (lambda (x y) + (check-xy x y) + (pixel-getter x y))) + (if unsafe? + pixel-setter + (lambda (x y v) + (check-xy x y) + (check-boolean-value v) + (pixel-setter x y v))))))))) -- cgit v1.2.3