From 5145dd3aa0c02c9fc496d1432fc4410674206e1d Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:31 -0800
Subject: Import Upstream version 3a2

---
 pnm.scm | 88 ++++++++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 65 insertions(+), 23 deletions(-)

(limited to 'pnm.scm')

diff --git a/pnm.scm b/pnm.scm
index 96961f7..2bfa4ae 100644
--- a/pnm.scm
+++ b/pnm.scm
@@ -40,6 +40,21 @@
            (loop (read-char port))
            (slib:error chr 'unexpected 'character))))))
 
+;; Comments beginning with "#" and ending with newline are permitted in
+;; the header of a pnm file.
+(define (pnm:read-value port)
+  (let loop ()
+    (let ((chr (peek-char port)))
+      (cond ((eof-object? chr)
+             (slib:error 'unexpected 'eof port))
+            ((char-whitespace? chr)
+             (read-char port)
+             (loop))
+            ((char=? chr #\#)
+             (read-line port)
+             (loop))
+            (else (read port))))))
+
 ;;@args path
 ;;The string @1 must name a @dfn{portable bitmap graphics} file.
 ;;@0 returns a list of 4 items:
@@ -84,22 +99,44 @@
 	       (char-numeric? c2)
 	       (char-whitespace? (peek-char port)))
 	  (let* ((format (string->symbol (string #\p c2)))
-		 (width (read port))
-		 (height (read port))
+		 (width (pnm:read-value port))
+		 (height (pnm:read-value port))
 		 (ret
 		  (case format
 		    ((p1) (list 'pbm     width height 1))
 		    ((p4) (list 'pbm-raw width height 1))
-		    ((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)))
+		    ((p2) (list 'pgm     width height (pnm:read-value port)))
+		    ((p5) (list 'pgm-raw width height (pnm:read-value port)))
+		    ((p3) (list 'ppm     width height (pnm:read-value port)))
+		    ((p6) (list 'ppm-raw width height (pnm:read-value port)))
 		    (else #f))))
 	    (and (char-whitespace? (read-char port)) ret)))
 	 (else #f)))
       (call-with-open-ports (open-file port 'rb) pnm:type-dimensions)))
 
-(define (pnm:read-bit-vector! array port)
+(define (pnm:write-bits 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)
+		 (do ((idx idx (+ 1 idx))
+		      (bdx 7 (+ -1 bdx))
+		      (bts 0 (+ bts (ash (if (array-ref row idx) 1 0) bdx))))
+		     ((>= idx width)
+		      (write-byte bts port)))))
+	  (do ((idx idx (+ 1 idx))
+	       (bdx 7 (+ -1 bdx))
+	       (bts 0 (+ bts bts (if (array-ref row idx) 1 0))))
+	      ((negative? bdx)
+	       (write-byte bts port))))))))
+
+(define (pnm:read-bits! array port)
   (define dims (array-dimensions array))
   (let* ((height (car (array-dimensions array)))
 	 (width (cadr (array-dimensions array)))
@@ -147,7 +184,11 @@
    (lambda (port)
      (apply (lambda (type width height max-pixel)
 	      (define (read-binary)
-		(array-map! array (lambda () (read-byte port)))
+		(array-map! array
+			    (if (<= max-pixel 256)
+				(lambda () (read-byte port))
+				(lambda () (define hib (read-byte port))
+					(+ (* 256 hib) (read-byte port)))))
 		(if (eof-object? (peek-char port)) array
 		    (slib:error type 'not 'at 'file 'end)))
 	      (define (read-text)
@@ -163,36 +204,34 @@
 	      (case type
 		((pbm)
 		 (or array
-		     (set! array (create-array (At1) height width)))
+		     (set! array (make-array (A:bool) height width)))
 		 (read-pbm))
 		((pgm)
 		 (or array
-		     (set! array (create-array
-				  ((if (<= max-pixel 256) Au8 Au16))
+		     (set! array (make-array
+				  ((if (<= max-pixel 256) A:fixN8b A:fixN16b))
 				  height width)))
 		 (read-text))
 		((ppm)
 		 (or array
-		     (set! array (create-array
-				  ((if (<= max-pixel 256) Au8 Au16))
+		     (set! array (make-array
+				  ((if (<= max-pixel 256) A:fixN8b A:fixN16b))
 				  height width 3)))
 		 (read-text))
 		((pbm-raw)
 		 (or array
-		     (set! array (create-array (At1) height width)))
-		 (pnm:read-bit-vector! array port))
+		     (set! array (make-array (A:bool) height width)))
+		 (pnm:read-bits! array port))
 		((pgm-raw)
 		 (or array
-		     (set! array (create-array (Au8) height width)))
+		     (set! array (make-array (A:fixN8b) height width)))
 		 (read-binary))
 		((ppm-raw)
 		 (or array
-		     (set! array (create-array (Au8) height width 3)))
+		     (set! array (make-array (A:fixN8b) height width 3)))
 		 (read-binary))))
 	    (pnm:type-dimensions port)))))
 
-;; ARRAY is required to be zero-based.
-
 ;;@args type array maxval path comment @dots{}
 ;;
 ;;Writes the contents of @2 to a @1 image file named @4.  The file
@@ -225,12 +264,15 @@
 	 (newline port)
 	 (if (not (boolean? (array-ref array 0 0)))
 	     (slib:error 'pnm:array-write "expected bit-array" array))
-	 (uniform-array-write array port))
+	 (pnm:write-bits array port))
 	((pgm-raw ppm-raw)
 	 (newline port)
-	 ;;(uniform-array-write array port)
-	 (array-for-each (lambda (byt) (write-byte byt port)) array)
-	 )
+	 (array-for-each (if (<= maxval 256)
+			     (lambda (byt) (write-byte byt port))
+			     (lambda (byt)
+			       (write-byte (quotient byt 256) port)
+			       (write-byte (modulo byt 256) port)))
+			 array))
 	((pbm)
 	 (do ((i 0 (+ i 1)))
 	     ((>= i height))
-- 
cgit v1.2.3