From 3c1d24af6e0250839358b1c9cab8094ee975ea1a Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sat, 3 Aug 2024 20:57:38 +0900 Subject: Support PBM format --- pnm/pbm.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 pnm/pbm.scm (limited to 'pnm/pbm.scm') diff --git a/pnm/pbm.scm b/pnm/pbm.scm new file mode 100644 index 0000000..d711b82 --- /dev/null +++ b/pnm/pbm.scm @@ -0,0 +1,53 @@ +;;; 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 pbm) + (export make-pbm-image) + (import (scheme base) + (scheme case-lambda) + (pnm image)) + (cond-expand + ((library (scheme bitwise)) + (import (only (scheme bitwise) bit-set? copy-bit))) + ((library (srfi 60)) + (import (only (srfi 60) bit-set? copy-bit)))) + (begin + (define make-pbm-image + (case-lambda + ((width height) + (let* ((byte-width (ceiling (/ width 8))) + (byte-count (* byte-width height)) + (data (make-bytevector byte-count 0))) + (make-pbm-image width height data))) + ((width height data) + (let* ((byte-width (ceiling (/ width 8)))) + (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))))) + (make-image 'pbm width height 1 data pixel-getter pixel-setter))))))) -- cgit v1.2.3