From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:29 -0800
Subject: Import Upstream version 3a1

---
 pnm.scm | 277 +++++++++++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 179 insertions(+), 98 deletions(-)

(limited to 'pnm.scm')

diff --git a/pnm.scm b/pnm.scm
index c4a0e66..96961f7 100644
--- a/pnm.scm
+++ b/pnm.scm
@@ -1,5 +1,5 @@
-;;; "pnm.scm" Read PNM image files.
-; Copyright 2000 Aubrey Jaffer
+;;; "pnm.scm" Read and write PNM image files.
+; Copyright 2000, 2003 Aubrey Jaffer
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
 ;
-;2.  I have made no warrantee or representation that the operation of
+;2.  I have made no warranty or representation that the operation of
 ;this software will be error-free, and I am under no obligation to
 ;provide any services, by way of maintenance, update, or otherwise.
 ;
@@ -17,24 +17,63 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
-(require 'scanf)
-(require 'printf)
 (require 'array)
+(require 'subarray)
 (require 'array-for-each)
-(require 'byte)
 (require 'line-i/o)
+(require 'logical)
+(require 'byte)
 
-(define (pnm:read+integer port)
-  (define uint #f)
-  (do ((chr (peek-char port) (peek-char port)))
-      ((not (and (char? chr) (or (char-whitespace? chr) (eqv? #\# chr)))))
-    (if (eqv? #\# chr)
-	(read-line port)
-	(read-char port)))
-  (if (eof-object? (peek-char port))
-      (peek-char port)
-      (and (eqv? 1 (fscanf port " %u" uint)) uint)))
+;;@code{(require 'pnm)}
+;;@ftindex pnm
 
+(define (pnm:read-pbm-char port)
+  (let loop ((chr (read-char port)))
+    (case chr
+      ((#\0) #f)
+      ((#\1) #t)
+      ((#\#)
+       (read-line port)
+       (loop (read-char port)))
+      (else
+       (if (char-whitespace? chr)
+           (loop (read-char port))
+           (slib:error chr 'unexpected 'character))))))
+
+;;@args path
+;;The string @1 must name a @dfn{portable bitmap graphics} file.
+;;@0 returns a list of 4 items:
+;;@enumerate
+;;@item
+;;A symbol describing the type of the file named by @1.
+;;@item
+;;The image width in pixels.
+;;@item
+;;The image height in pixels.
+;;@item
+;;The maximum value of pixels assume in the file.
+;;@end enumerate
+;;
+;;The current set of file-type symbols is:
+;;@table @asis
+;;@item pbm
+;;@itemx pbm-raw
+;;@cindex pbm
+;;@cindex pbm-raw
+;;Black-and-White image; pixel values are 0 or 1.
+;;@item pgm
+;;@itemx pgm-raw
+;;@cindex pgm
+;;@cindex pgm-raw
+;;Gray (monochrome) image; pixel values are from 0 to @var{maxval}
+;;specified in file header.
+;;@item ppm
+;;@itemx ppm-raw
+;;@cindex ppm
+;;@cindex ppm-raw
+;;RGB (full color) image; red, green, and blue interleaved pixel values
+;;are from 0 to @var{maxval}
+;;@end table
 (define (pnm:type-dimensions port)
   (if (input-port? port)
       (let* ((c1 (read-char port))
@@ -45,83 +84,122 @@
 	       (char-numeric? c2)
 	       (char-whitespace? (peek-char port)))
 	  (let* ((format (string->symbol (string #\p c2)))
-		 (width (pnm:read+integer port))
-		 (height (pnm:read+integer port))
+		 (width (read port))
+		 (height (read port))
 		 (ret
 		  (case format
 		    ((p1) (list 'pbm     width height 1))
 		    ((p4) (list 'pbm-raw width height 1))
-		    ((p2) (list 'pgm     width height (pnm:read+integer port)))
-		    ((p5) (list 'pgm-raw width height (pnm:read+integer port)))
-		    ((p3) (list 'ppm     width height (pnm:read+integer port)))
-		    ((p6) (list 'ppm-raw width height (pnm:read+integer port)))
+		    ((p2) (list 'pgm     width height (read port)))
+		    ((p5) (list 'pgm-raw width height (read port)))
+		    ((p3) (list 'ppm     width height (read port)))
+		    ((p6) (list 'ppm-raw width height (read port)))
 		    (else #f))))
 	    (and (char-whitespace? (read-char port)) ret)))
 	 (else #f)))
-      (call-with-input-file port pnm:type-dimensions)))
+      (call-with-open-ports (open-file port 'rb) pnm:type-dimensions)))
 
-(define (pnm:read-binary! array port)
-  (array-map! array (lambda () (read-byte port))))
+(define (pnm:read-bit-vector! array port)
+  (define dims (array-dimensions array))
+  (let* ((height (car (array-dimensions array)))
+	 (width (cadr (array-dimensions array)))
+	 (wid8 (logand -8 width)))
+    (do ((jdx 0 (+ 1 jdx)))
+	((>= jdx height))
+      (let ((row (subarray array jdx)))
+	(do ((idx 0 (+ 8 idx)))
+	    ((>= idx wid8)
+	     (if (< idx width)
+		 (let ((byt (read-byte port)))
+		   (do ((idx idx (+ 1 idx))
+			(bdx 7 (+ -1 bdx)))
+		       ((>= idx width))
+		     (array-set! row (logbit? bdx byt) idx)))))
+	  (let ((byt (read-byte port)))
+	    (array-set! row (logbit? 7 byt) (+ 0 idx))
+	    (array-set! row (logbit? 6 byt) (+ 1 idx))
+	    (array-set! row (logbit? 5 byt) (+ 2 idx))
+	    (array-set! row (logbit? 4 byt) (+ 3 idx))
+	    (array-set! row (logbit? 3 byt) (+ 4 idx))
+	    (array-set! row (logbit? 2 byt) (+ 5 idx))
+	    (array-set! row (logbit? 1 byt) (+ 6 idx))
+	    (array-set! row (logbit? 0 byt) (+ 7 idx)))))))
+  (if (eof-object? (peek-char port))
+      array
+      (do ((chr (read-char port) (read-char port))
+	   (cnt 0 (+ 1 cnt)))
+	  ((eof-object? chr) (slib:error cnt 'bytes 'remain 'in port)))))
 
+;;@args path array
+;;
+;;Reads the @dfn{portable bitmap graphics} file named by @var{path} into
+;;@var{array}.  @var{array} must be the correct size and type for
+;;@var{path}.  @var{array} is returned.
+;;
+;;@args path
+;;
+;;@code{pnm:image-file->array} creates and returns an array with the
+;;@dfn{portable bitmap graphics} file named by @var{path} read into it.
 (define (pnm:image-file->array path . array)
   (set! array (and (not (null? array)) (car array)))
-  (call-with-input-file path
-    (lambda (port)
-      (apply (lambda (type width height max-pixel)
-	       (define (read-binary)
-		 (pnm:read-binary! array port)
-		 (if (eof-object? (peek-char port)) array
-		     (slib:error type 'not 'at 'file 'end)))
-	       (define (read-text)
-		 (array-map! array (lambda () (pnm:read+integer port)))
-		 (if (eof-object? (pnm:read+integer port)) array
-		     (slib:error type 'not 'at 'file 'end)))
-	       (define (read-pbm)
-		 (array-map! array (lambda () (eqv? 1 (pnm:read+integer port))))
-		 (if (eof-object? (pnm:read+integer port)) array
-		     (slib:error type 'not 'at 'file 'end)))
-	       (case type
-		 ((pbm)
-		  (or array
-		      (set! array (make-array #t height width)))
-		  (read-pbm))
-		 ((pgm)
-		  (or array
-		      (set! array (make-array max-pixel height width)))
-		  (read-text))
-		 ((ppm)
-		  (or array
-		      (set! array (make-array max-pixel height width 3)))
-		  (read-text))
-		 ((pbm-raw)
-		  (or array
-		      (set! array (make-array #t height (quotient width 8))))
-		  (read-binary))
-		 ((pgm-raw)
-		  (or array
-		      (set! array (make-array max-pixel height width)))
-		  (read-binary))
-		 ((ppm-raw)
-		  (or array
-		      (set! array (make-array max-pixel height width 3)))
-		  (read-binary))))
-	     (pnm:type-dimensions port)))))
-
-(define (pnm:image-file->uniform-array path . array)
-  (fluid-let ((make-array make-uniform-array)
-	      (pnm:read-binary!
-	       (lambda (ra port)
-		 (if (array? ra #t)
-		     (error 'pnm:image-file->array
-			    "pbm-raw support unimplemented")
-		     (let ((bytes (apply make-uniform-array #\a
-					 (array-dimensions ra))))
-		       (uniform-array-read! bytes port)
-		       (array-map! ra char->integer bytes))))))
-    (apply pnm:image-file->array path array)))
+  (call-with-open-ports
+   (open-file path 'rb)
+   (lambda (port)
+     (apply (lambda (type width height max-pixel)
+	      (define (read-binary)
+		(array-map! array (lambda () (read-byte port)))
+		(if (eof-object? (peek-char port)) array
+		    (slib:error type 'not 'at 'file 'end)))
+	      (define (read-text)
+		(array-map! array (lambda () (read port)))
+		(if (not (eof-object? (read port)))
+		    (slib:warn type 'not 'at 'file 'end))
+		array)
+	      (define (read-pbm)
+		(array-map! array (lambda () (pnm:read-pbm-char port)))
+		(if (not (eof-object? (read port)))
+		    (slib:warn type 'not 'at 'file 'end))
+		array)
+	      (case type
+		((pbm)
+		 (or array
+		     (set! array (create-array (At1) height width)))
+		 (read-pbm))
+		((pgm)
+		 (or array
+		     (set! array (create-array
+				  ((if (<= max-pixel 256) Au8 Au16))
+				  height width)))
+		 (read-text))
+		((ppm)
+		 (or array
+		     (set! array (create-array
+				  ((if (<= max-pixel 256) Au8 Au16))
+				  height width 3)))
+		 (read-text))
+		((pbm-raw)
+		 (or array
+		     (set! array (create-array (At1) height width)))
+		 (pnm:read-bit-vector! array port))
+		((pgm-raw)
+		 (or array
+		     (set! array (create-array (Au8) height width)))
+		 (read-binary))
+		((ppm-raw)
+		 (or array
+		     (set! array (create-array (Au8) height width 3)))
+		 (read-binary))))
+	    (pnm:type-dimensions port)))))
 
 ;; ARRAY is required to be zero-based.
-(define (pnm:array-write type array maxval port)
+
+;;@args type array maxval path comment @dots{}
+;;
+;;Writes the contents of @2 to a @1 image file named @4.  The file
+;;will have pixel values between 0 and @3, which must be compatible
+;;with @1.  For @samp{pbm} files, @3 must be @samp{1}.
+;;@var{comment}s are included in the file header.
+(define (pnm:array-write type array maxval port . comments)
   (define (write-header type height width maxval)
     (let ((magic
 	   (case type
@@ -131,9 +209,13 @@
 	     ((pbm-raw) "P4")
 	     ((pgm-raw) "P5")
 	     ((ppm-raw) "P6")
-	     (else (error 'pnm:array-write "bad type" type)))))
-      (fprintf port "%s\n%d %d" magic width height)
-      (if maxval (fprintf port "\n%d" maxval))))
+	     (else (slib:error 'pnm:array-write "bad type" type)))))
+      (display magic port) (newline port)
+      (for-each (lambda (str)
+		  (display "#" port) (display str port) (newline port))
+		comments)
+      (display width port) (display " " port) (display height port)
+      (cond (maxval (newline port) (display maxval port)))))
   (define (write-pixels type array maxval)
     (let* ((shp (array-dimensions array))
 	   (height (car shp))
@@ -141,15 +223,14 @@
       (case type
 	((pbm-raw)
 	 (newline port)
-	 (if (array? array #t)
-	     (uniform-array-write array port)
-	     (error 'pnm:array-write "expected bit-array" array)))
+	 (if (not (boolean? (array-ref array 0 0)))
+	     (slib:error 'pnm:array-write "expected bit-array" array))
+	 (uniform-array-write array port))
 	((pgm-raw ppm-raw)
 	 (newline port)
-;;;	 (let ((bytes (apply make-uniform-array #\a shp)))
-;;;	   (array-map! bytes integer->char array)
-;;;	   (uniform-array-write bytes port))
-	 (uniform-array-write array port))
+	 ;;(uniform-array-write array port)
+	 (array-for-each (lambda (byt) (write-byte byt port)) array)
+	 )
 	((pbm)
 	 (do ((i 0 (+ i 1)))
 	     ((>= i height))
@@ -187,16 +268,16 @@
 	   (or (and (eqv? 2 rnk)
 		    (integer? (car shp))
 		    (integer? (cadr shp)))
-	       (error 'pnm:array-write "bad shape" type array))
+	       (slib:error 'pnm:array-write "bad shape" type array))
 	   (or (eqv? 1 maxval)
-	       (error 'pnm:array-write "maxval supplied not 1" type))
+	       (slib:error 'pnm:array-write "maxval supplied not 1" type))
 	   (write-header type (car shp) (cadr shp) #f)
 	   (write-pixels type array 1))
 	  ((pgm pgm-raw)
 	   (or (and (eqv? 2 rnk)
 		    (integer? (car shp))
 		    (integer? (cadr shp)))
-	       (error 'pnm:array-write "bad shape" type array))
+	       (slib:error 'pnm:array-write "bad shape" type array))
 	   (write-header type (car shp) (cadr shp) maxval)
 	   (write-pixels type array maxval))
 	  ((ppm ppm-raw)
@@ -204,10 +285,10 @@
 		    (integer? (car shp))
 		    (integer? (cadr shp))
 		    (eqv? 3 (caddr shp)))
-	       (error 'pnm:array-write "bad shape" type array))
+	       (slib:error 'pnm:array-write "bad shape" type array))
 	   (write-header type (car shp) (cadr shp) maxval)
 	   (write-pixels type array maxval))
-	  (else (error 'pnm:array-write type 'unrecognized 'type))))
-      (call-with-output-file port
-	(lambda (port)
-	  (pnm:array-write type array maxval port)))))
+	  (else (slib:error 'pnm:array-write type 'unrecognized 'type))))
+      (call-with-open-ports
+       (open-file port 'wb)
+       (lambda (port) (pnm:array-write type array maxval port)))))
-- 
cgit v1.2.3