diff options
Diffstat (limited to 'pnm/pbm.scm')
| -rw-r--r-- | pnm/pbm.scm | 56 |
1 files changed, 28 insertions, 28 deletions
diff --git a/pnm/pbm.scm b/pnm/pbm.scm index 7e7bc78..b8e3178 100644 --- a/pnm/pbm.scm +++ b/pnm/pbm.scm @@ -17,7 +17,8 @@ ;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>. (define-library (pnm pbm) - (export make-pbm-image) + (export make-pbm-image + %make-pbm-image) (import (scheme base) (scheme case-lambda) (pnm image)) @@ -29,30 +30,29 @@ ((library (srfi 151)) (import (only (srfi 151) 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))) - (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 "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) - (make-image 'pbm width height 1 data pixel-getter pixel-setter))))))) + (define (make-pbm-image 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))) + + (define (%make-pbm-image width height data) + (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 "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) + (make-image 'pbm width height 1 data pixel-getter pixel-setter))))) |