) (10/20/89)
;;; -*- Mode:Common-Lisp; Fonts:(MEDFNT MEDFNB HL12BI HL12B cptfontb); Base:10 -*-
(DEFUN 4read-macpaint-document* (filename &key (height 720) (width 576)
(rotate 90) (show-bitmap-p t)
(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;let bindings*
(LABELS ((legal-width-p (value)
"3Returns true of value is >0 and a multiple of 32*"
(AND (PLUSP value) (ZEROP (MOD value 32))))
(repeat-count-p(count-byte)
"3Returns true of COUNT-BYTE is a repeat count*"
(LOGTEST #x80 count-byte))
(COUNT (count-byte)
"3Returns 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)))
(read-stream-data-byte ()
"3Increment STREAM-INDEX. Returns STREAM-DATA byte at STREAM-INDEX
before it was incremented.*"
(PROG1 (AREF stream-data stream-index)
(INCF stream-index)))
(write-byte-vector-byte (BYTE)
"3Write BYTE to BYTE-VECTOR at BYTE-INDEX then increment BYTE-INDEX.*"
(SETF (AREF byte-vector byte-index) byte)
(INCF byte-index))
(bit-swap (8-bit-value)
"3Reverse an 8 bit thing*"
(AREF swapped-array 8-bit-value))
);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 (FORMAT t "3done.*"))
;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; 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