;;; -*- Mode:LISP; Syntax:Common-Lisp; Package:IFF -*-

;;;
;;; This file contains code for reading IFF ILBM picture files, and for displaying them on Explorer screens.
;;;


;;;  ChangeLog:
;;;
;;; 30 Dec 88  Jamie Zawinski  Created from file IFF.LISP
;;;  3 Feb 89  Jamie Zawinski  Worked on HAM decoding some.
;;;  6 Feb 89  Jamie Zawinski  Constrained color maps to be less than 128 slots, since the TI seems to do that (silently).
;;; 20 Feb 89  Jamie Zawinski  Made SHOW+ accept 1 for BPP.  Made SHOW take X and Y offsets, for really big images.


(in-package "IFF")



(deftype body-bitmap ()
  "A two dimensional array with from 1 to 8 bits per pixel."
  '(or (array bit 2)
       (array (unsigned-byte 2) 2)
       (array (unsigned-byte 3) 2)
       (array (unsigned-byte 4) 2)
       (array (unsigned-byte 5) 2)
       (array (unsigned-byte 6) 2)
       (array (unsigned-byte 7) 2)
       (array (unsigned-byte 8) 2)
       ))


;;; Structures

;;; A BMHD is a Bitmap Header; it specifies the attributes of the bitmap which follows in the file.
;;;
(defstruct (ILBM-BMHD (:print-function %print-bmhd) (:conc-name "BMHD-"))
  ;; Size of the image in pixels.
  (w 0 :type uword)
  (h 0 :type uword)
  ;; Where the image begins.
  (x 0 :type word)
  (y 0 :type word)
  ;; Number of bitplanes (bits per pixel).
  (nplanes 0 :type uword)
  (masking :MSK-NONE   :type (member :MSK-NONE			; opaque image.
				     :HAS-MASK			; Mask is interleaved with BODY.
				     :MSK-HAS-TRANSPARENT-COLOR	; The TRANSPARENT-COLOR is active.
				     :MSK-LASSO			; Image has a MacPaint type lasso.
				     ))
  ;; What compression is used on scanlines; none or Byte Run 1.
  (compression :CMP-NONE :type (member :CMP-NONE :CMP-BYTE-RUN-1))
  (pad1 0 :type (member 0))		; This is unused; it's "reserved for future expansion," or so they say...
  (transparent-color 0 :type uword)	; Which color is to be treated as transparent, if any.
  ;; The horizontal and vertical aspect ratio of the image.
  (xaspect 0 :type ubyte)
  (yaspect 0 :type ubyte)
  ;; The page size that this image was saved with, in case we want to scale it.
  (page-width 0 :type word)
  (page-height 0 :type word))


(defun %print-bmhd (struct stream depth)
  (declare (ignore depth))
  (format stream "#<ILBM-BMHD ~Dx~Dx~D>" (bmhd-w struct) (bmhd-h struct) (bmhd-nplanes struct)))



;;; A CREG is a Color Register; it holds the RGB value of one color of the color map of an ILBM.
;;; Though these range from 0 to 255, they are always multiples of 4 since the Amiga can only display 4096 colors.
;;;
(defstruct (ILBM-CREG (:print-function %print-creg) (:conc-name "CREG-"))
  (red   0 :type ubyte)
  (green 0 :type ubyte)
  (blue  0 :type ubyte))

(defun %print-creg (struct stream depth)
  (declare (ignore depth))
  (format stream "#<ILBM-CREG ~2,'0X ~2,'0X ~2,'0X>" (creg-red struct) (creg-green struct) (creg-blue struct)))



;;; A CMAP is a color map; it is a set of CREGs.
;;;
(defstruct (ilbm-cmap (:print-function %print-cmap) (:conc-name "CMAP-"))
  (cregs #() :type vector)   ; of CREGs.
  #+TI (color-map nil :type (or null tv:color-map))  ; Used to cache this once calculated.
  )

(defun %print-cmap (struct stream depth)
  (declare (ignore depth))
  (format stream "#<ILBM-CMAP, ~D colors>" (length (cmap-cregs struct))))



;;; A GRAB is an important point associated with an ILBM; for cursors or sprites it is the XY position of the hotspot.
;;;
(defstruct (ilbm-grab (:conc-name "GRAB-"))
  (x 0 :type word)
  (y 0 :type word))


;;; A SPRT indicates that this ILBM is intended to be used as a sprite.
;;;
(defstruct (ilbm-sprt (:conc-name "SPRT-"))
  (precedence 0 :type uword)     ; The position in the list of sprites that this one should go.
  )

;;; A CAMG is a code specifying what Amiga viewport mode this image is to use.
;;;
(defstruct (ilbm-camg (:conc-name "CAMG-"))
  (mode 0 :type long)
  )


;;; A CRNG represents a color cycle range.
;;;
(defstruct (ilbm-crng (:conc-name "CRNG-"))
  (pad    0 :type (member 0)) ; this is unused
  (rate   0 :type word)       ; color cycle rate
  (active 0 :type word)       ; non-zero means cycling is on
  (low    0 :type ubyte)      ; lower and upper color registers
  (high   0 :type ubyte)      ; selected.
  )


;;; A BODY is the actual image data.  It is the image bitmap, which is N planes deep, and the mask bitmap, which is
;;; one plane deep, and doesn't usually exist.
;;;
(defstruct (ILBM-BODY (:conc-name "BODY-"))
  (body-bitmap nil :type (or null body-bitmap))
  (mask-bitmap nil :type (or null body-bitmap))
  )


;;; An ILBM is an interleaved bitmap; it holds information about the color map, size, and origin of the bitmap as
;;; well as the actual bits.
;;;
(defstruct ILBM
  (bmhd  nil :type (or null ilbm-bmhd))	; bitmap header.
  (cmap  nil :type (or null ilbm-cmap))	; color map.
  (grab  nil :type (or null ilbm-grab))	; An important XY, like a hotspot.
  (dest  nil :type null ) ;    (or null ilbm-dest))	; (?)
  (sprt  nil :type (or null ilbm-sprt))	; If T, this is a sprite.
  (camg  nil :type (or null ilbm-camg))	; Amiga-specific attribute: HAM, Dual Playfield, etc.
  (crngs nil :type list)                ; A list of color register ranges (CRNGs).
  (body  nil :type (or null ilbm-body)) ; the actual bitplanes.
  )




;;; Reading them.



(defun read-bmhd (stream)
  "Read a bitmap header from STREAM.  Returns two values: the BMHD and the number of bytes read."
  (declare (values bmhd nbytes))
  (let* ((length (read-ulong-word stream))
	 (bmhd (make-ilbm-bmhd)))
    (reporting-form ("Reading a BMHD of length ~D bytes." length)
      (unless (= 20 length)
	(error "Read a BMHD whose length was ~D instead of 20." length))
      (setf (bmhd-w bmhd) (read-ushort-word stream))
      (setf (bmhd-h bmhd) (read-ushort-word stream))
      (setf (bmhd-x bmhd) (read-short-word stream))
      (setf (bmhd-y bmhd) (read-short-word stream))
      (setf (bmhd-nplanes bmhd) (read-ubyte stream))
      (let ((masking (read-ubyte stream)))
	(setf (bmhd-masking bmhd)
	      (case masking
		(1 :HAS-MASK)
		(2 :MSK-HAS-TRANSPARENT-COLOR)
		(3 :MSK-LASSO)
		(t :MSK-NONE))))
      (let ((compression (read-ubyte stream)))
	(setf (bmhd-compression bmhd)
	      (if (= compression 1)
		  :CMP-BYTE-RUN-1
		  :CMP-NONE)))
      (setf (bmhd-pad1 bmhd) (read-ubyte stream))
      (setf (bmhd-transparent-color bmhd) (read-ushort-word stream))
      (setf (bmhd-xaspect bmhd) (read-ubyte stream))
      (setf (bmhd-yaspect bmhd) (read-ubyte stream))
      (setf (bmhd-page-width bmhd)  (read-ushort-word stream))
      (setf (bmhd-page-height bmhd) (read-ushort-word stream))
      
      (values bmhd 20))))   ; All BMHDs are 20 bytes long.



(defun read-cmap (stream)
  "Read a color map from STREAM.  Returns two values: the CMAP and the number of bytes read."
  (declare (values cmap nbytes))
  (let* ((length (read-ulong-word stream))
	 (cmap (make-ilbm-cmap))
	 (cregs '()))
    (catch 'IFF-EOF
      (reporting-form ("Reading a CMAP of length ~D bytes (~D colors)." length (/ length 3))
	(do* ((length-to-go length (- length-to-go 3)))
	     ((<= length-to-go 0))
	  (let ((creg (make-ilbm-creg)))
	    (setf (creg-red creg) (read-ubyte stream))
	    (setf (creg-green creg) (read-ubyte stream))
	    (setf (creg-blue creg) (read-ubyte stream))
	    (push creg cregs)))
	(setf (cmap-cregs cmap) (make-array (length cregs) :initial-contents (nreverse cregs)))
	(when (oddp length) (read-ubyte stream)))  ; stay word-aligned.
      (values cmap length))))


(defun read-grab (stream)
  "Read a hotspot from STREAM.  Returns two values: the GRAB and the number of bytes read."
  (declare (values grab nbytes))
  (let ((length (read-ulong-word stream)))
    (reporting-form ("Reading a GRAB of length ~D bytes." length)
      (values (make-ilbm-grab :x (read-short-word stream) :y (read-short-word stream))
	      length))))


(defun read-sprt (stream)
  "Read a sprite flag.  Returns two values: the SPRT and the number of bytes read."
  (declare (values sprt nbytes))
  (let ((length (read-ulong-word stream)))
    (reporting-form ("Reading a SPRT of length ~D bytes." length)
      (values (make-ilbm-sprt :precedence (read-ulong-word stream))
	      length))))


(defun read-camg (stream)
  "Read an Amiga viewport mode.  Returns two values: the CAMG and the number of bytes read."
  (declare (values camg nbytes))
  (let ((length (read-ulong-word stream)))
    (reporting-form ("Reading a CAMG of length ~D bytes." length)
      (values (make-ilbm-camg :mode (read-long-word stream))
	      length))))



(defun read-crng (stream)
  "Read a color range.  Returns two values: the CRNG and the number of bytes read."
  (declare (values cnrg nbytes))
  (let ((length (read-ulong-word stream)))
    (reporting-form ("Reading a CRNG of length ~D bytes." length)
      (read-short-word stream) ; ignore pad word.
      (let* ((rate (read-short-word stream))
	     (active (read-short-word stream))
	     (low (read-ubyte stream))
	     (high (read-ubyte stream)))
	(values (make-ilbm-crng :rate rate :active active :low low :high high)
		length)))))



(setf (get :ILBM 'FORM-READER) 'READ-ILBM)

(defun read-ilbm (stream maxlength)
  "Read an interleaved bitmap from STREAM.  Returns two values: the ILBM and the number of bytes read."
  (declare (values ilbm nbytes))
  (reporting-form ("Reading an ILBM, length ~D bytes" maxlength)
    (let* ((length 0)
	   id idname bmhd cmap grab sprt camg crngs body ig)
      (setq id (read-chunk-id stream))
      (incf length 4)
      (if (eq id :BMHD)
	  (multiple-value-bind (thing thing-length) (read-bmhd stream)
	    (setq bmhd thing)
	    (incf length thing-length))
	  (error "The first form in an ILBM must be a BMHD."))
      (catch 'IFF-EOF
	(do* ()
	     ((>= length maxlength))
	  (multiple-value-setq (id idname) (read-chunk-id stream))
	  (incf length 4)
	  (let* (thing-length)
	    (case id
	      (:CMAP (multiple-value-setq (cmap thing-length) (read-cmap stream)))
	      (:GRAB (multiple-value-setq (grab thing-length) (read-grab stream)))
	      (:SPRT (multiple-value-setq (sprt thing-length) (read-sprt stream)))
	      (:CAMG (multiple-value-setq (camg thing-length) (read-camg stream)))
	      (:CRNG (multiple-value-bind (crng crng-length) (read-crng stream)
		       (setq thing-length crng-length)
		       (push crng crngs)))
	      (:BODY (multiple-value-setq (body thing-length) (read-body stream bmhd)))
	      (t (multiple-value-setq (ig thing-length) (read-and-ignore-chunk stream idname))))
	    (incf length thing-length)))
	(when (oddp length) (read-ubyte stream) (incf length)))
      (values (make-ilbm :bmhd bmhd
			 :cmap cmap
			 :grab grab
			 :sprt sprt
			 :camg camg
			 :crngs (nreverse crngs)
			 :body body)
	      length))))


;;
;; On Lisp Machines, bit arrays are indexed in column-major order, and must be multiples of 32 wide.
;; For the TI BITBLT function to work properly, the bitmap should be either 1 plane or 8 planes deep.
;;
#+LISPM
(defun make-body-bitmap (w h nplanes)
  (let* ((pad-w (round-up-to 32 w))
	 (one-plane-p (or (null nplanes) (= nplanes 1))))
    (make-array (list h pad-w) :element-type (if one-plane-p 'bit '(unsigned-byte 8)))))

;;
;; The IFF format says that bitmaps must be multiples of 16 wide.
;;
#-LISPM
(defun make-body-bitmap (w h nplanes)
  (let* ((pad-w (round-up-to 16 w)))
    (make-array (list pad-w h) :element-type `(unsigned-byte ,(or nplanes 1)))))


(defun read-body (stream bmhd)
  "Read a BODY from STREAM.  Returns two values: the BODY and the number of bytes read."
  (declare (values bit-array nbytes))
  (let* ((w (bmhd-w bmhd))
	 (h (bmhd-h bmhd))
	 (nplanes (bmhd-nplanes bmhd))
	 (has-mask (eq :HAS-MASK (bmhd-masking bmhd)))
	 (brun1 (eq :CMP-BYTE-RUN-1 (bmhd-compression bmhd)))
	 (maxlength (read-ulong-word stream))
	 (dest-bitmap (make-body-bitmap w h nplanes))
	 (mask-map (and has-mask (make-body-bitmap w h 1)))
	 (body (make-ilbm-body :body-bitmap dest-bitmap :mask-bitmap mask-map))
	 )
    (reporting-form ("Reading a BODY of ~D bytes (~Dx~Dx~D), ~A compression, ~Amask."
		     maxlength w h nplanes (if brun1 "ByteRun1" "no") (if has-mask "" "no "))
      (catch 'IFF-EOF
	(cond (brun1
	       (read-brun1-bitmap stream body w h nplanes))
	      (t
	       (read-simple-bitmap stream body w h nplanes)))))
    (values body maxlength)))




(eval-when (load eval compile)
(proclaim '(inline setmap setmap-byte))

#-LISPM
(defun setmap (value bitmap x y &optional z)
  "Set the appropriate cell of the bitmap to VALUE.  Z may be NIL if the bitmap is one plane."
  (declare (type body-bitmap bitmap)
	   (fixnum x y)
	   (optimize speed))
  (if z
      (setf (aref bitmap x y) (dpb value (lisp:byte 1 z) (aref bitmap x y)))
      (setf (aref bitmap x y) value)
      ))


#+LISPM
(defun setmap (value bitmap x y z)
  "Set the appropriate cell of the bitmap to VALUE.  Z may be NIL if the bitmap is one plane."
  (declare (type body-bitmap bitmap)
	   (fixnum x y)
	   (optimize speed))
  (if z
      (setf (aref bitmap y x) (dpb value (lisp:byte 1 z) (aref bitmap y x)))             ; LISPM bitmaps are col-major.
      (setf (aref bitmap y x) value)
      ))


(defun setmap-byte (ubyte bitmap byte-x bit-y z)
  "UBYTE is an 8-bit quantity to place in the Z plane of the BITMAP.
  BYTE-X is the position in 8-bit bytes at which the ubyte should begin.
  BIT-Y is the Y position (the row) in which this byte goes.
  BITMAP is two-dimensional; Z is the position in the word in each array index in which the bits are dropped."
  (declare (type ubyte ubyte)
	   (type body-bitmap bitmap)
	   (fixnum byte-x bit-y z)
	   (optimize speed))
  (let* ((x (* byte-x 8)))
    (declare (fixnum x))
    (dotimes (i 8)
      (setmap (ldb (lisp:byte 1 (- 7 i)) ubyte)
	      bitmap x bit-y z)
      (incf x))))


 ) ; closes EVAL-WHEN.


(defun read-simple-bitmap (stream body w h nplanes)
  "Read a single- or multi-plane bitmap from STREAM into the bitmaps of BODY, size WxH.  W must be a multiple of 16.
  Returns BODY."
  (let* ((bitmap (body-body-bitmap body))
	 (mask (body-mask-bitmap body)))
    (dotimes (y h)
      (dotimes (z nplanes)
	(dotimes (x (ceiling w 16))
	  (let* ((uword (read-ushort-word stream)))
	    (dotimes (i 16)
	      (setmap (logbitp i uword) bitmap (+ x i) y z)
	      ))))
      ;; If there is a MASK, it is a parallel bitmap, 1 plane deep, interlaced vertically.
      (when mask
	(dotimes (x (ceiling w 16))
	  (let* ((uword (read-ushort-word stream)))
	    (dotimes (i 16)
	      (setmap (logbitp i uword) mask (+ x i) y nplanes)
	      ))))
      ))
  body)


(defun brun1-one-scan (stream bitmap w y z)
  "Read one scanline with ByteRun1 compression into BITMAP.
 W is how wide the scanline is (multiple of 16).
 Y is which scanline we are reading.
 Z is which plane of BITMAP we are reading, or NIL if BITMAP has only one plane."
  (do* ((bytes-to-be-read (/ w 8))
	(real-bytes-read 0)
	(virtual-bytes-read 0))
       ((>= virtual-bytes-read bytes-to-be-read)
	)
    (let* ((control (read-byte stream)))
      (incf real-bytes-read)
      (cond ((= control -128) nil)             ; -128 is a No-Op.
	    
	    ((>= control 0)                    ; Copy next CONTROL+1 bytes literally.
	     (dotimes (i (1+ control))
	       ;; trap an error condition:
	       (when (= virtual-bytes-read bytes-to-be-read)
		 (format t "~%MUNCHED DATA:  scanline ~D too long during literal run of ~D bytes."
			 y (1+ control))
		 (return))
	       (let* ((ubyte (read-ubyte stream)))
		 (setmap-byte ubyte bitmap virtual-bytes-read y z)
		 (incf real-bytes-read)
		 (incf virtual-bytes-read)))
	     )
	    
	    ((< control 0)                     ; Replicate next byte -N+1 times.
	     (let* ((times (1+ (- control)))
		    (repl (read-ubyte stream)))
	       (incf real-bytes-read)
	       (dotimes (i times)
		 (when (>= virtual-bytes-read bytes-to-be-read)
		   (format t "~%MUNCHED DATA:  scanline ~D too long during repeat of ~D bytes."
			   y (1+ (- control)))
		   (return))
		 (setmap-byte repl bitmap virtual-bytes-read y z)
		 (incf virtual-bytes-read))))
	    ))))


(defun read-brun1-bitmap (stream body w h nplanes)
  "Read a single- or multi-plane bitmap from STREAM into the bitmaps of BODY, size WxH, using ByteRun1 compression.
  W must be a multiple of 16.  Returns nothing meaningful."
  (let* ((bitmap (body-body-bitmap body))
	 (mask (body-mask-bitmap body)))
    (setq w (round-up-to 16 w))
    (when (= nplanes 1) (setq nplanes nil))
    (dotimes (y h)
      (dotimes (z (or nplanes 1))
	(brun1-one-scan stream bitmap w y z))
      ;; If there is a MASK, it is a parallel bitmap, 1 plane deep, interlaced vertically.
      (when mask
	(brun1-one-scan stream mask w y nil))
      )))


;;; Correcting Aspect Ratios.


(defmacro blit-row (w from from-y to to-y)
  "Copy a row of pixels W wide and 1 bit tall from the bitmap FROM to the bitmap TO,
  at Y positions FROM-Y and TO-Y."
  #+LISPM `(bitblt tv:alu-seta ,w 1 ,from 0 ,from-y ,to 0 ,to-y)
  #-LISPM (let* ((i (gensym)))
	    `(dotimes (,i ,w)
	       (setf (aref ,to ,i ,to-y) (aref ,from ,i ,from-y))))
  )

(defmacro blit-col (h from from-x to to-x)
  "Copy a column of pixels 1 bit wide and H tall from the bitmap FROM to the bitmap TO,
  at X positions FROM-X and TO-X."
  #+LISPM `(bitblt tv:alu-seta 1 ,h ,from ,from-x 0 ,to ,to-x 0)
  #-LISPM (let* ((i (gensym)))
	    `(dotimes (,i ,h)
	       (setf (aref ,to ,to-x ,i) (aref ,from ,from-x ,i))))
  )


(defun copy-bitmap-correct-for-aspect-ratio (bitmap width height ratio)
  "Returns a new bitmap, which is BITMAP scaled by ASPECT-RATIO.
  WIDTH and HEIGHT are the height that the bitmap is supposed to be,
  since bitmap sizes are scaled up to the next multiple of 32."
  (declare (values new-bitmap new-width new-height))
  (let* ((horizontal (numerator ratio))
	 (vertical (denominator ratio))
	 (make-taller-p (> vertical horizontal))
	 (real-width #+LISPM (array-dimension bitmap 1)   ; Lispm bitmaps are col-major.
		     #-LISPM (array-dimension bitmap 0))
	 (real-height #+LISPM (array-dimension bitmap 0)
		      #-LISPM (array-dimension bitmap 1))
	 (new-width (if make-taller-p
			width
			(ceiling (* width ratio))))
	 (new-height (if make-taller-p
			 (ceiling (* height (/ ratio)))
			 height))
	 (real-new-width (round-up-to 32 new-width))
	 (real-new-height (round-up-to 32 new-height))
	 (new-bitmap (make-array (list real-new-height real-new-width) :element-type (array-element-type bitmap))))
    (when *read-iff-verbose*
      (fresh-line)
      (dotimes (i *iff-report-indent*) (princ #\Space))
      (format t "Adjusting BODY aspect ratio from ~D:~D to 1:1 (~Dx~D to ~Dx~D)~%"
	      horizontal vertical width height new-width new-height))
    (cond (make-taller-p
	   (dotimes (i new-height)
	     (blit-row real-width bitmap (floor (* i ratio)) new-bitmap i)))
	  (t
	   (dotimes (i new-width)
	     (blit-col real-height bitmap (floor (/ i ratio)) new-bitmap i))))
    (values new-bitmap new-width new-height)))


(defun correct-for-aspect-ratio (ilbm &optional (prompt-if-questionable-p t) (default nil))
  "Munch the ILBM to have an aspect ratio of 1:1.  This will make the width or height of the BODY be larger."
  (let* ((bmhd (ilbm-bmhd ilbm))
	 (w (bmhd-w bmhd))
	 (h (bmhd-h bmhd))
	 (xa (bmhd-xaspect bmhd))
	 (ya (bmhd-yaspect bmhd))
	 (body (ilbm-body ilbm))
	 (body-b (body-body-bitmap body))
	 (body-m (body-mask-bitmap body))
	 (query-string (string-append "~&~%This ILBM has a stated aspect ratio of ~D:~D, but it's size is ~Dx~D.~%"
				      "This is probably incorrect.  Do you want to change the aspect ratio to ~D:~D? ")))
    ;;
    ;; Some Amiga programs, Digi-View for example, are pretty lax in the aspect ratio they assign.
    ;; This COND is a hack to pick out common errors in ILBMs written incorrectly.
    ;;
    (flet ((query (guess-x guess-y)
	     (when (if prompt-if-questionable-p
		       (yes-or-no-p query-string xa ya w h guess-x guess-y)
		       default)
	       (setq xa guess-x ya guess-y))))
      (cond ((and (= w 320) (= h 400)
		  (not (and (= xa 20) (= ya 11))))
	     (query 20 11))
	    
	    ((and (or (and (= w 640) (= h 400))
		      (and (= w 320) (= h 200)))
		  (not (and (= xa 10) (= ya 11))))
	     (query 10 11))
	    
	    ((and (= w 640) (= h 200)
		  (not (and (= xa 5) (= ya 11))))
	     (query 5 11))))
    
    (multiple-value-bind (new-body-b new-w new-h) (copy-bitmap-correct-for-aspect-ratio body-b w h (/ xa ya))
      (let* ((new-body-m (and body-m (copy-bitmap-correct-for-aspect-ratio body-m w h (/ xa ya)))))
	(setf (body-body-bitmap body) new-body-b
	      (body-mask-bitmap body) new-body-m
	      (bmhd-xaspect bmhd) 1
	      (bmhd-yaspect bmhd) 1
	      (bmhd-w bmhd) new-w
	      (bmhd-h bmhd) new-h
	      ))))
  ilbm)



;;; Describing these structures.


(def-describer (ilbm-bmhd thing)
  (dump "BMHD: Bitmap Header.")
  (dump "      Size:               ~Dx~D" (bmhd-w thing) (bmhd-h thing))
  (dump "      Origin:             ~D,~D" (bmhd-x thing) (bmhd-y thing))
  (dump "      Original Page Size: ~Dx~D" (bmhd-page-width thing) (bmhd-page-height thing))
  (dump "      Aspect Ratio:       ~D:~D" (bmhd-xaspect thing) (bmhd-yaspect thing))
  (dump "      Masking:            ~A" (bmhd-masking thing))
  (dump "      Compression:        ~A" (bmhd-compression thing))
  (dump "      Transparent Color:  ~A" (bmhd-transparent-color thing))
  (dump "      Bits per pixel:     ~D" (bmhd-nplanes thing))
  )
	
(def-describer (ILBM-SPRT thing) (dump "SPRT: Sprite flag, precedence = ~D." (sprt-precedence thing)))
(def-describer (ILBM-CAMG thing) (dump "CAMG: Amiga ViewPort mode = ~D." (camg-mode thing)))
(def-describer (ILBM-CRNG thing)
  (dump "CRNG: Color Register Range.")
  (dump "      Rate:       ~S" (crng-rate thing))
  (dump "      Active:     ~S" (crng-active thing))
  (dump "      Low Color:  ~S" (crng-low thing))
  (dump "      High Color: ~S" (crng-high thing)))

(def-describer (ILBM-CREG thing)
  (dump "CREG: Color Register.  RGB values: ~2,'0X ~2,'0X ~2,'0X" (creg-red thing) (creg-green thing) (creg-blue thing)))
	
(def-describer (ILBM-CMAP thing)
  (dump "CMAP: Color Map of ~D color~:P." (length (cmap-cregs thing)))
  (dolist (creg (coerce (cmap-cregs thing) 'list)) (iff-describe creg)))
	
(def-describer (ILBM-GRAB thing) (dump "GRAB: Hotspot at ~D, ~D." (grab-x thing) (grab-y thing)))

(def-describer (ILBM thing)
  (dump "ILBM: Interleaved Bitmap.")
  (iff-describe (ilbm-bmhd thing))
  (iff-describe (ilbm-cmap thing))
  (iff-describe (ilbm-grab thing))
; (iff-describe (ilbm-dest thing))
  (iff-describe (ilbm-sprt thing))
  (iff-describe (ilbm-camg thing))
  (dolist (crng (ilbm-crngs thing))
    (iff-describe crng))
  (iff-describe (ilbm-body thing))
  )

(def-describer (ILBM-BODY thing)
  (dump "BODY: the bits of the ILBM.")
  (iff-describe (body-body-bitmap thing) 'BODYMAP)
  (iff-describe (body-mask-bitmap thing) 'MASKMAP)
  )
(def-describer (BODY-BITMAP thing)
  (let* ((el-type (array-element-type thing)))
    (dump "~A: An array of dimensions ~Dx~D, ~D bit~:P per pixel."
	  (or type 'BITMAP)
	  (array-dimension thing 0) (array-dimension thing 1)
	  (cond ((eq el-type 'BIT) 1)
		((eq el-type 'UBYTE) 8)
		((eq el-type 'UWORD) 16)
		((eq el-type 'ULONG) 32)
		((and (consp el-type) (eq (car el-type) 'MOD))
		 (1- (integer-length (second el-type))))
		((and (consp el-type) (eq (car el-type) 'INTEGER))
		 (integer-length (second el-type)))
		((and (consp el-type) (eq (car el-type) 'UNSIGNED-BYTE))
		 (second el-type))
		(t "???")))))



;;; Let the Explorer FS know that files ending in .pic, .iff, .ilbm, or .8svx are 8-bit binary.
;;;

#+LISPM (fs::define-canonical-type :PIC "PIC"
	  (:unix-ucb "pic" "iff" "ilbm")
	  (:unix "pic" "iff" "ilbm")
	  (:lispm "pic" "iff" "ilbm"))
#+LISPM (push :PIC fs::*copy-file-known-short-binary-types*)



;;; Explorer-specific code for tossing these images onto the screen.


;#+TI
;(defun show (ilbm)
;  (send tv:selected-window :clear-screen)
;  (let* ((body-p (typep ilbm 'body))
;	 (bitmap-p (typep ilbm 'body-bitmap))
;	 (body (cond (body-p ilbm)
;		     (bitmap-p nil)
;		     (t (ilbm-body ilbm))))
;	 (bitmap (if bitmap-p ilbm (body-body-bitmap body)))
;	 (bmhd (unless (or body-p bitmap-p) (ilbm-bmhd ilbm)))
;	 (x 10) (y 10)
;	 (w (if (or bitmap-p body-p) (array-dimension bitmap 1) (bmhd-w bmhd)))
;	 (h (if (or bitmap-p body-p) (array-dimension bitmap 0) (bmhd-h bmhd))))
;    (if (typep tv:selected-window 'w:window)
;	(send tv:selected-window :draw-filled-rectangle (- x 3) (- y 3) (+ w 6) (+ h 6))
;	(send tv:selected-window :draw-rectangle (+ w 6) (+ h 6) (- x 3) (- y 3)))
;    (send tv:selected-window :bitblt tv:alu-seta w h bitmap 0 0 x y)
;    (send tv:selected-window :set-cursorpos 0 (+ h 20) :pixel)
;    (format t "~&~D x ~D~%" w h)
;    ))


#+TI
(defun cmap-to-color-map (cmap &optional (name "IFF CMAP") recompute)
  "Converts an IFF CMAP structure to a W:COLOR-MAP structure.  Uses the cached color map in the CMAP if it exists."
  (cond ((and (not recompute) (cmap-color-map cmap))
	 (cmap-color-map cmap))
	(t
	 (let* ((cregs (cmap-cregs cmap))
		(color-map (w:make-color-map :name name)))
	   (when (> (length cregs) 127)
	     (error "Can't make a CMAP with more than 127 slots."))
	   (dotimes (i (length cregs))
	     (let* ((creg (aref cregs i))
		    (r (creg-red creg))
		    (g (creg-green creg))
		    (b (creg-blue creg)))
	       (w:write-color-map color-map i r g b)
	       (w:write-color-map color-map (+ 128 i) r g b)
	       ))
	   (setf (cmap-color-map cmap)
		 color-map)))))


#+TI
(defun show (ilbm &optional (window tv:selected-window) (x-off 0) (y-off 0))
  "Dumps the bitmap in the ILBM onto the given window.
  ILBM may really be an ILBM, an ILBM-BODY, or an array of type BODY-BITMAP.
  If we are on a color system, the arg is an ILBM, and the image is multi-planed,
  then we use the correct color map when displaying it."
  (send window :select)
  (send window :clear-screen)
  (let* ((body-p (typep ilbm 'ILBM-BODY))
	 (bitmap-p (typep ilbm 'BODY-BITMAP))
	 (body (cond (body-p ilbm)
		     (bitmap-p nil)
		     (t (ilbm-body ilbm))))
	 (bitmap (if bitmap-p ilbm (body-body-bitmap body)))
	 (bmhd (unless (or body-p bitmap-p) (ilbm-bmhd ilbm)))
	 (cmap (unless (or body-p bitmap-p) (ilbm-cmap ilbm)))
	 (x 10) (y 10)
	 (w (if (or bitmap-p body-p) (array-dimension bitmap 1) (bmhd-w bmhd)))
	 (h (if (or bitmap-p body-p) (array-dimension bitmap 0) (bmhd-h bmhd)))
	 ;;
	 ;; We only deal with color maps if we are on a color system AND this is a multi-plane image.
	 ;;
	 (color-system-p (w:color-system-p window))
	 (color-image-p (not (subtypep (array-element-type bitmap) 'BIT)))
	 (color-p (and color-system-p color-image-p))
	 (old-colormap (and color-p (send window :color-map)))
	 (new-colormap (and color-p (when cmap (cmap-to-color-map cmap)))))
    
    (when (and color-image-p (not color-system-p))
      (beep)
      (warn "This is a color image!  It will probably not display correctly.  You should probably use SHOW+ instead.")
      (incf y (tv:sheet-line-height window)))
    
    (if (typep window 'W:WINDOW)
	(send window :draw-filled-rectangle (- x 3) (- y 3) (+ w 6) (+ h 6))
	(send window :draw-rectangle (+ w 6) (+ h 6) (- x 3) (- y 3)))
    (unwind-protect
	(progn
	  (when new-colormap
	    (send window :set-color-map new-colormap)
	    (send window :select))
	  (send window :bitblt TV:ALU-SETA w h bitmap x-off y-off x y)
	  (send window :set-cursorpos (- x 3) (+ y h 6) :pixel)
	  (format window "~D x ~D~%" w h)
	  ;; If we are using a color map, then we wait for the user to type a character before returning.
	  ;; otherwise, we don't wait.
	  (when new-colormap (read-char)))
      (when new-colormap
	(send window :set-color-map old-colormap)
	(send window :select))))
  (values))


;;; Showing images that have multiple bits per pixel on a monochrome display.
;;; We do this by mapping colors into grey stipple patterns.

#+TI
(defun make-greylevel-mapping-array (dim arrays)
  "Construct and return a 256-element array mapping CREG values to BLITable texture-arrays."
  (let* ((length #x100)
	 (table (make-array length))
	 (granularity (round length (length arrays))))
    (let* ((pos (1- length)))
      (dolist (array arrays)
	(let* ((new-array (make-array (list dim 32) :element-type 'bit)))
	  (dotimes (i dim)
	    (dotimes (j dim)
	      (setf (aref new-array i j) (aref array i j))))
	  (dotimes (i granularity)
	    (unless (minusp (- pos i))
	      (setf (aref table (- pos i)) new-array)))
	  (decf pos granularity))))
    (setf (aref table 0) (make-array (list dim 32) :element-type 'bit :initial-element 0))
    table))

#+TI
(defvar *cmap-to-greyscale-16*
	(make-greylevel-mapping-array 4 '(#2a(#*1111 #*1111 #*1111 #*1111)
					  #2a(#*1111 #*1101 #*1111 #*1111)
					  #2a(#*1111 #*1110 #*0111 #*1111)
					  #2a(#*1101 #*0111 #*1101 #*1111)
					  #2a(#*1101 #*1011 #*1101 #*1011)
					  #2a(#*1011 #*0101 #*1011 #*1011)
					  #2a(#*1101 #*1010 #*0101 #*1011)
					  #2a(#*0101 #*1010 #*0101 #*1011)
					  #2a(#*0101 #*1010 #*0101 #*1010)
					  #2a(#*0100 #*1010 #*0101 #*1010)
					  #2a(#*0100 #*1010 #*0101 #*0010)
					  #2a(#*0100 #*1010 #*0101 #*0000)
					  #2a(#*0000 #*1010 #*0101 #*0000)
					  #2a(#*0000 #*0010 #*0101 #*0000)
					  #2a(#*0000 #*1000 #*0001 #*0000)
					  #2a(#*0000 #*0000 #*0001 #*0000)
					  )))

#+TI
(defvar *cmap-to-greyscale-9*
	(make-greylevel-mapping-array 3 '(#2a(#*111 #*111 #*111)
					  #2a(#*111 #*101 #*111)
					  #2a(#*011 #*101 #*111)
					  #2a(#*011 #*101 #*110)
					  #2a(#*101 #*010 #*101)
					  #2a(#*101 #*000 #*101)
					  #2a(#*001 #*010 #*100)
					  #2a(#*001 #*000 #*100)
					  #2a(#*000 #*010 #*000))))

#+TI
(defvar *cmap-to-greyscale-4*
	(make-greylevel-mapping-array 2 '(#2a(#*11 #*11)
					  #2a(#*11 #*10)
					  #2a(#*10 #*01)
					  #2a(#*00 #*10))))

(defvar *cmap-to-greyscale-1*
	(make-greylevel-mapping-array 1 '(#2a((1))
					  #2a((0)))))

#+TI
(eval-when (load eval compile)

(proclaim '(inline dump-as))

(defun dump-as (n x y cmap mapping-table dest-array)
  (let* ((creg (aref (cmap-cregs cmap) n))
	 (gray (round (+ (creg-red creg) (creg-green creg) (creg-blue creg)) 3))
	 (array (aref mapping-table gray))
	 (size (array-dimension array 0)))
    (bitblt tv:alu-seta size size array 0 0 dest-array x y)
    ))

 ) ; closes EVAL-WHEN


#+TI
(defun show+ (ilbm &optional (bpp 4) (xoff 0) (yoff 0) (array (tv:sheet-screen-array tv:default-screen)))
  "Like SHOW, but displays multi-plane images using greytone stipple patterns.
  This doesn't do dithering - it just pretends the pixels are bigger (can you say 10-minute hack?).
  BPP is bits per pixel, which must be 2, 3, or 4.  This is BPP displayed, it has no relation to the BPP actually in
  the ILBM image.
  XOFF and YOFF are where in the image to start displaying, since the whole thing might not fit on the screen.
  This isn't necessary on color systems - use SHOW instead."
  (check-type bpp (member 1 2 3 4))
  (send tv:selected-window :clear-screen)
  (let* ((body (ilbm-body ilbm))
	 (bitmap (body-body-bitmap body))
	 (bmhd (ilbm-bmhd ilbm))
	 (cmap (ilbm-cmap ilbm))
	 (x 0) (y 0)
	 (w (- (bmhd-w bmhd) xoff))
	 (h (- (bmhd-h bmhd) yoff)))
    (dotimes (xx (min w (floor (- (tv:sheet-inside-width tv:main-screen) 16) bpp)))
      (dotimes (yy (min h (floor (- (tv:sheet-inside-height tv:main-screen) 16) bpp)))
	(dump-as (aref bitmap (+ yy yoff) (+ xx xoff)) (+ x (* xx bpp)) (+ y (* yy bpp))
		 cmap
		 (ecase bpp (4 *cmap-to-greyscale-16*) (3 *cmap-to-greyscale-9*)
			(2 *cmap-to-greyscale-4*) (1 *cmap-to-greyscale-1*))
		 array)
	))
    ))

;;;
;;; When W:SET-BACKGROUND is defined, modify it so that it will conveniently accept an ILBM.
#+TI
(when (fboundp 'w:set-background)
  (compiler-let ((sys:compile-encapsulations-flag t))
    (sys:advise w:set-background :before extract-ilbm-bitmap nil
      (when (typep (car sys:arglist) 'ILBM)
	(setq sys:arglist (copy-list sys:arglist))
	(setf (car sys:arglist) (body-body-bitmap (ilbm-body (car sys:arglist)))))
      )))


;;; HAM decoding - taking a HAM image and converting it to a non-HAM image with an arbitrarily sized color map.
;;;


(defmacro pack-rgb (r g b)
  "Returns an integer in which R, G, and B occupy successive 8-bit sequences."
  `(dpb ,r (lisp:byte 8 16)
	(dpb ,g (lisp:byte 8 8)
	     (dpb ,b (lisp:byte 8 0)
		  0))))

(defmacro unpack-r (n) `(ldb (lisp:byte 8 16) ,n))
(defmacro unpack-g (n) `(ldb (lisp:byte 8 8) ,n))
(defmacro unpack-b (n) `(ldb (lisp:byte 8 0) ,n))


(defmacro deHAMming ((array cmap &optional tick-p)
		     (x y r g b)
		     &body body)
  "Execute BODY, binding X and Y to every element in ARRAY, and
  binding R, G, and B to the value there, taking into account HAM encoding.
  If TICK-P is true, then a dot will be printed every 10 scanlines."
  (let* ((cregs (make-symbol "CREGS"))
	 (n-colors (make-symbol "N-COLORS"))
	 (color-map-array (make-symbol "CMA"))
	 (last-r (make-symbol "LR"))
	 (last-g (make-symbol "LG"))
	 (last-b (make-symbol "LB"))
	 (a (gensym))
	 (byte (make-symbol "BYTE"))
	 (code (make-symbol "CODE"))
	 (value (make-symbol "VALUE"))
	 (tick (make-symbol "TICK"))
	 )
    `(let* ((,cregs (cmap-cregs ,cmap))
	    (,n-colors (length ,cregs))
	    (,color-map-array (make-array (list ,n-colors 3)))
	    )
       (dotimes (i ,n-colors)
	 (let* ((creg (aref ,cregs i))
		(cr (creg-red creg))
		(cg (creg-green creg))
		(cb (creg-blue creg)))
	   (setf (aref ,color-map-array i 0) cr
		 (aref ,color-map-array i 1) cg
		 (aref ,color-map-array i 2) cb)))
       (let* ((,a ,array)
	      ,@(when tick-p `((,tick 0)))
	      (,last-r (aref ,color-map-array 0 0))
	      (,last-g (aref ,color-map-array 0 1))
	      (,last-b (aref ,color-map-array 0 2)))
	 
	 (dotimes (,y (array-dimension ,a 0))
	   (dotimes (,x (array-dimension ,a 1))
	     
	     (let* ((,byte (aref ,a ,y ,x))
		    (,code (ldb (lisp:byte 2 4) ,byte))
		    (,value (ldb (lisp:byte 4 0) ,byte))
		    ,r ,g ,b)
	       (ecase ,code
		 (#b00  (setq ,r (aref ,color-map-array ,value 0)
			      ,g (aref ,color-map-array ,value 1)
			      ,b (aref ,color-map-array ,value 2)))
		 (#b10  (setq ,r ,last-r  ,g ,last-g  ,b ,value ))
		 (#b01  (setq ,r ,value   ,g ,last-g  ,b ,last-b))
		 (#b11  (setq ,r ,last-r  ,g ,value   ,b ,last-b))
		 )
	       (setq ,last-r ,r ,last-g ,g ,last-b ,b)
	       
	       ,@body))
	   ,@(when tick-p
	       `((cond ((> ,tick 10)
			(princ #\.)
			(setq ,tick 0))
		       (t (incf ,tick)))))
	   )))))



(defstruct (bnode (:constructor make-bnode (value &optional less more)))
  "A structure used for fast sorted inserts."
  (value nil)
  (less nil)
  (more nil)
  )


(defun insert-into-bnode (value bnode)
  "BNODE is a BNODE or NIL.  
  The contents of the BNODE tree are of the form ( <value> . <number-of-occurrances>).
  If VALUE is in the tree already, then its <number-of-occurrances> will be incremented.
  If it is not in the tree, a BNODE is created for it, and it is inserted.
  The top of the tree is returned."
  (declare (type (or null bnode) bnode)
	   (fixnum value)
	   (optimize speed))
  (cond ((null bnode)
	 (setq bnode (make-bnode (cons value 1))))
	(t
	 (let* ((top bnode))
	   (block NIL
	     (loop
	       (let* ((middle (car (bnode-value bnode))))
		 (declare (fixnum middle))
		 (cond ((< value middle)
			(cond ((null (bnode-less bnode))
			       (setf (bnode-less bnode) (make-bnode (cons value 1)))
			       (return))
			      (t
			       (setq bnode (bnode-less bnode)))))
		       ((> value middle)
			(cond ((null (bnode-more bnode))
			       (setf (bnode-more bnode) (make-bnode (cons value 1)))
			       (return))
			      (t
			       (setq bnode (bnode-more bnode)))))
		       (t
			(incf (cdr (bnode-value bnode)))
			(return))))))
	   top))))


(defun bnode-to-list (bnode)
  "Given a BNODE, returns an increasing-sorted list of the contents of the tree."
  (let* ((list '()))
    (labels ((descend (b)
	      (when (bnode-more b) (descend (bnode-more b)))
	      (push (bnode-value b) list)
	      (when (bnode-less b) (descend (bnode-less b)))))
      (descend bnode))
    list))

(defun bnode-to-array (bnode)
  "Given a BNODE, returns an increasing-sorted array of the contents of the tree.
  This array is adjustable and has a fill-pointer."
  (let* ((array (make-array 1000 :fill-pointer 0 :element-type 'CONS :adjustable t)))
    (labels ((descend (b)
	      (when (bnode-more b) (descend (bnode-more b)))
	      (vector-push-extend (bnode-value b) array)
	      (when (bnode-less b) (descend (bnode-less b)))))
      (descend bnode))
    array))


(defun build-color-histogram (array cmap)
  "Returns a sorted array describing the color usage in the HAM image in ARRAY.  CMAP is used for decoding HAM.
  Elements of the array are of the form ( <packed-rgb> . <number-of-occurrances> ).
  The array is sorted so that the most frequent colors are toward the front."
  (declare (inline insert-into-bnode)
	   (optimize speed))
  (let* ((hist nil))
    (deHAMming (array cmap t)
	       (x y r g b)
      (setq hist (insert-into-bnode (pack-rgb r g b) hist))
      )
    (setq hist (sort (bnode-to-array hist) #'> :key #'cdr))
    hist))


(defun make-cmap-from-histogram (histogram ncolors)
  "Creates and returns an ILBM-CMAP consisting of the top NCOLORS of the HISTOGRAM."
  (let* ((cmap (make-ilbm-cmap))
	 (cregs (make-array ncolors)))
    (dotimes (i ncolors)
      (let* ((value (car (aref histogram i)))
	     (r (unpack-r value))
	     (g (unpack-g value))
	     (b (unpack-b value)))
	(setf (aref cregs i) (make-ilbm-creg :red r :green g :blue b))))
    (setf (cmap-cregs cmap) cregs)
    cmap))


;;;
;;; ## This is slow as all hell.
;;;
(defun find-color-in-map (cregs ncolors r g b)
  "Returns the index into the CREGS which most closely approximates RGB."
  (block EXACT
    (let* ((min-delta MOST-POSITIVE-FIXNUM)
	   (min-delta-pos nil))
      (dotimes (i ncolors)
	(let* ((creg (aref cregs i))
	       (rr (creg-red creg))
	       (gg (creg-green creg))
	       (bb (creg-blue creg)))
	  (let* ((delta (+ (abs (- r rr))
			   (abs (- g gg))
			   (abs (- b bb)))))
	    (cond ((zerop delta)
		   (return-from EXACT i))
		  (t
		   (when (< delta min-delta)
		     (setq min-delta delta
			   min-delta-pos i)))))))
      min-delta-pos)))


(defun de-ham-image (ilbm ncolors &optional verbose)
  "Destructively modify ILBM to no longer be HAM-encoded, but rather to use a color map of NCOLORS."
  (let* ((body (ilbm-body ilbm))
	 (camg (ilbm-camg ilbm))
	 (array (body-body-bitmap body))
	 (initial-cmap (ilbm-cmap ilbm))
	 histogram new-cmap)
    (when (or (null camg) (zerop (camg-mode camg)))
      (warn "This image might not be a HAM image."))
    
    (when verbose (format t "~&Computing Color Histogram..."))
    (setq histogram (build-color-histogram array initial-cmap))
    
    (when verbose (format t "~&Computing ~D color CMAP..." ncolors))
    (setq new-cmap (make-cmap-from-histogram histogram ncolors))
    
    (when verbose (format t "~&Adjusting image..."))
    (let* ((cregs (cmap-cregs new-cmap)))
      (deHAMming (array initial-cmap t)
		 (x y r g b)
	(setf (aref array y x)
	      (find-color-in-map cregs ncolors r g b))))
    (setf (ilbm-cmap ilbm) new-cmap)
    (when camg (setf (camg-mode camg) 0)))
  ilbm)