;;; -*- Mode:Common-Lisp; Package:USER; Fonts:(CPTFONT HL12B HL12I CPTFONT CPTFONTB); Base:10 -*-


Ï4(DEFUN READ-MACPAINT-DOCUMENT (filename &key (height 720) (width 576)Ï*
				Ï4  (rotate 90) (show-bitmap-p t)Ï*
				Ï4  (arrow-key-displacement 50) (verbose t))Ï*
   "Ï2   Read a MacPaint document (Macintosh file type 'PNTG') from FILENAME, convert
it into an Explorer bitmap, rotate the bitmap ROTATE degrees (0, 90, 180, or 270),
show the bitmap if SHOW-BITMAP-P is true, and finally return the rotated bitmap.
   HEIGHT and WIDTH default to the standard MacPaint document size (i.e., a full
ImageWriter printed page).
   If SHOW-BITMAP-P is true, then ARROW-KEY-DISPLACEMENT specifies the number 
of pixels the bitmap being shown will be moved each time an arrow (i.e., cursor)
key is pressed.
   If VERBOSE is true, then progress messages are printed out during processing.Ï*" 
  (declare (values rotated-bitmap))
 
  (let* ((bitmap            nil)
	 (rotated-bitmap    nil)  ;Ï1 BITMAP rotated ROTATE degreesÏ*
	 (byte-vector       nil)  ;Ï1 expanded contents of STREAM-DATA as 8-bit bytesÏ*
	 (swapped-array     (let ((array (make-array 256 :element-type '(mod 256)))
				  (byte-r 0))
			      (dotimes (i 256 array)
				(dotimes (bit 8)
				  (setf byte-r (dpb (ldb (byte 1 bit) i)
						    (byte 1 (- 7 bit)) byte-r)))
				(setf (aref array i) byte-r))) )
	 (stream-length     0)
	 (stream-data       nil)  ;Ï1 holds entire file as and array of (unsigned-byte 8)Ï*
	 (version           0)    ;Ï1 MacPaint file version numberÏ*
	 (PatArray          nil)  ;Ï1 38 x 8 array of (unsigned-byte 8) patternsÏ*
	 (Future            nil)  ;Ï1 204 byte vector of (signed-byte 8)Ï*
	 (stream-index      0)
	 (byte-index        0)
	 (count-byte        0)
	Ï1  Ï*);Ï1;let bindingsÏ*
    (labels (Ï4(LEGAL-WIDTH-P (value)Ï*
	      "Ï2Returns true of value is >0 and a multiple of 32Ï*"
	      (and (plusp value) (zerop (mod value 32))))
           
	     Ï4(REPEAT-COUNT-P(count-byte)Ï*
	      "Ï2Returns true of COUNT-BYTE is a repeat countÏ*"
	      (logtest #x80 count-byte))

	     Ï4(COUNTÏ* Ï4(count-byte)Ï*
	      "Ï2Returns the count encoded in COUNT-BYTEÏ*"
	      (if (repeat-count-p count-byte)
		  ;Ï1; then this is a repeat count for next byteÏ*
		  (1+ (- #x100 count-byte))
		  ;Ï1; else this is a length count of unique bytes to followÏ*
		  (1+ count-byte)))
	    
	     Ï4(READ-STREAM-DATA-BYTE ()Ï*
	      "Ï2Increment STREAM-INDEX.  Returns STREAM-DATA byte at STREAM-INDEX
Ï3               Ï*before it was incremented.Ï*"
	      (prog1 (aref stream-data stream-index)
	 	     (incf stream-index)))

	     Ï4(WRITE-BYTE-VECTOR-BYTE (byte)Ï*
	      "Ï2Write BYTE to BYTE-VECTOR at BYTE-INDEX then increment BYTE-INDEX.Ï*"
	      (setf (aref byte-vector byte-index) byte)
	      (incf byte-index))

	     Ï4(BIT-SWAP (8-bit-value)Ï*
	      "Ï2Reverse an 8 bit thingÏ*"
	      (aref swapped-array 8-bit-value))
	Ï1       Ï*);Ï1;labels bindingsÏ*

      ;Ï1; validate argumentsÏ*
      (check-type filename (or string pathname))
      (check-type height   (integer 0 *))
      (check-type width    (satisfies legal-width-p) "Ï3a positive multiple of 32Ï*")
      (check-type rotate   (member 0 90 180 270))

      ;Ï1; read MacPaint file into memoryÏ*
      (setf filename (merge-pathnames filename (make-pathname :host sys:local-host 
							      :type :UNSPECIFIC)))
      (when verbose
	(format t "Ï3~%Reading MacPaint document \"~A\"...Ï*" filename))
      (with-open-file (stream filename :direction :input
			      :element-type '(unsigned-byte 8))
	 (setf stream-length (file-length stream :element-type '(unsigned-byte 8)))
	 (when (<= stream-length 512)
	   ;Ï1; then there is nothing to process, so returnÏ*
	   (warn "Ï3~%~A stream length is only ~D bytes long.  Nothing to process.Ï*"
		 (namestring stream) stream-length)
	   (return-from read-macpaint-document nil 0 0))
	 
	 ;Ï1; read version (LONGINT)Ï*
	 (dotimes ( i 4)
	   (setf version (+ (* version 8) (read-byte stream))))
	 (when (/= version 0)
	   (warn "Ï3~%NOTE:  This is a version ~D MacPaint file.~
                  ~%       It will be converted as a version 0 file.Ï*" version))

	 ;Ï1; read PatArray (Array [1..38] of Pattern (unsigned-byte 64))Ï*
	 (setf PatArray (make-array (list 38 8) :element-type '(unsigned-byte 8)))
	 (dotimes (i 38)
	   (dotimes (j 8)			       ;Ï1 byte-reverse 8-byte patternsÏ*
	     (setf (aref PatArray i (- 7 j)) (read-byte stream))))

	 ;Ï1; read Future (Array [1..204] of (signed-byte 8)) then byte swap each byteÏ*
	 (setf Future (make-array 204 :element-type '(signed-byte 8)))
	 (send stream :string-in t Future)
	 (dotimes (i 204)
	   (setf (aref Future i) (aref Future i)))

	 ;;Ï1 read the entire remaining file in one gulpÏ*
	 (setf stream-data (make-array (- stream-length (file-position stream))
					:element-type '(unsigned-byte 8)))
	 (send stream :string-in t stream-data)
	 );Ï1;with-open-fileÏ*
      (when verbose (Ï3format t Ï*"done."Ï3)Ï*)

      ;Ï1;create bitmap and byte-vectorÏ*
      (when verbose (format t "Ï3~%Expanding compressed MacPaint format...Ï*"))
      (setf bitmap      (make-array (list height width) :element-type 'bit))
      (setf byte-vector (make-array (ceiling (* height width) 8)
				    :element-type '(unsigned-byte 8)
				    :displaced-to bitmap))
      ;Ï1; From this point, there should be exactly enough bytes in STREAM-ARRAY suchÏ*
      ;Ï1; that, when expanded, they will exactly fill BYTE-VECTOR.Ï*

      ;Ï1; Expand compressed MacPaint formatÏ*
      (loop
	(when (>= byte-index (length byte-vector))
	  (return stream-index))
	(setf count-byte (read-stream-data-byte))
	(if (repeat-count-p count-byte)
	    ;Ï1; then this count byte is a repeat count for the next STREAM-DATA byteÏ*
	    (let ((data-byte (bit-swap (read-stream-data-byte))))
	      (dotimes (i (count count-byte))
		(write-byte-vector-byte data-byte)))
	    ;Ï1; else this count byte is a field length for the next STREAM-DATA fieldÏ*
	    (dotimes (i (count count-byte))
	      (write-byte-vector-byte (bit-swap (read-stream-data-byte)))))
	);Ï1;loopÏ*
      (when verbose (format t "Ï3done.Ï*"))
      
      ;Ï1; Create ROTATED-BITMAPÏ*
      (when (and verbose (not (zerop rotate)))
	(format t "Ï3~%Rotating bitmap ~D degrees...Ï*" rotate))
      (case rotate
	((90 270)
	Ï1  Ï*;Ï1; case of ROTATED-BITMAP = BITMAP with dimensions exchangedÏ*
	 (setf rotated-bitmap			       ;Ï12nd dimension must by x32Ï*
	       (make-array
		 (list (array-dimension bitmap 1)
		       (* (truncate (+ (array-dimension bitmap 0) 31) 32) 32))
		 :element-type 'bit)))
	(180
	 ;Ï1; case of ROTATED-BITMAP = BITMAPÏ*
	 (setf rotated-bitmap
	       (make-array (array-dimensions bitmap) :element-type 'bit)))
	);Ï1;caseÏ*

      ;Ï1; Rotate BITMAPÏ*
      (case rotate
	(0   (setf rotated-bitmap bitmap))
	(90  (tv:rotate-90 bitmap  rotated-bitmap))
	(180 (tv:rotate-180 bitmap rotated-bitmap))
	(270 (tv:rotate-270 bitmap rotated-bitmap)))
      (when (and verbose (not (zerop rotate))) (format t "Ï3doneÏ*"))
	      
      ;Ï1; Show bitmap, if requestedÏ*
      (when show-bitmap-p
	(when verbose (format t "Ï3~%Showing bitmap (use arrow keys to move it)...Ï*"))
	(unwind-protect
	    (tv:show-bit-array rotated-bitmap :window *terminal-io*
			       :increment arrow-key-displacement)
	  (send *terminal-io* :refresh)
	  (when verbose (format t "Ï3~&done.Ï*"))))
      );Ï1;labelsÏ*

    (when (and verbose *print-array*)
      (format t "Ï3~%Forcing *PRINT-ARRAY* to NIL to suppress printing ~
                   bitmap contents.Ï*"))
    (setf *print-array* nil)
    rotated-bitmap
    );Ï1;let*Ï*
  );Ï1;read-macpaint-document
