;;; -*- Mode:LISP; Syntax:Common-Lisp; Package:(IFF) -*- ;;; ;;; This file contains the backbone of the code to read Amiga IFF files. ;;; Other files include code for reading pictures, sounds, and scenes. ;;; ;;; For a description of the IFF file format, see the Amiga ROM Kernel Manual vol 2, appendix H. ;;; ;;; ChangeLog: ;;; ;;; 6 Dec 87 Jamie Zawinski Created. ;;; 8 Dec 87 Jamie Zawinski Cleaned up, successfully reading file. Still no way to display, though... ;;; 3 Sep 88 Jamie Zawinski Made Lispm bitmaps be in col-major order to facilitate blitting. ;;; Got reading the file again, after breaking it some months ago. ;;; 7 Sep 88 Jamie Zawinski Added *READ-IFF-VERBOSE* and more consistent messages. ;;; Defined IFF-DESCRIBE to recursively describe a thing read of of an IFF file. ;;; 9 Sep 88 Jamie Zawinski Added code for correcting aspect ratios to to be 1:1. ;;; Added a special case so that if aspect ratio is 10/11 but size is 320x400, it will ask you ;;; if you want to change it to be 20/11, since Digi-View generates this bogus aspect ratio. ;;; 14 Sep 88 Jamie Zawinski Made the bitmaps always be 2d - if more than one bitplane, then multiple bits-per-pixel ;;; instead of 3d array. ;;; Made BODY be a structure holding the bodymap and the maskmap, since we were ignoring the mask. ;;; Defined SHOW16 for viewing multi-plane images. ;;; Added more aspect-ratio checking. ;;; 31 Oct 88 Jamie Zawinski Added color support, vis CSHOW. ;;; 21 Nov 88 Jamie Zawinski Debugged color code, now that I actually have a color machine. ;;; 26 Nov 88 Jamie Zawinski Made it able to read non-compacted sampled sound files, but not correctly... ;;; 7 Dec 88 Jamie Zawinski Got the sound stuff playing. ;;; 12 Dec 88 Jamie Zawinski Made SHOW not muck about with the color map if it is a single-plane image. (in-package "IFF" :use '("LISP" "USER" #+explorer "TICL" #+lucid "LUCID")) (shadow '(byte read-byte) "IFF") (export '(iff-describe iff-read . #+LISPM (show show+ play))) #-LISPM (proclaim '(declaration values arglist)) ;;; Type Definitions. ;;; These are used to make dealing with the C world that much easier. (deftype byte () "An 8 bit signed integer" '(signed-byte 8)) (deftype word () "A 16 bit signed integer" '(signed-byte 16)) (deftype long () "A 32 bit signed integer" '(signed-byte 32)) (deftype ubyte () "An 8 bit unsigned integer" '(unsigned-byte 8)) (deftype uword () "A 16 bit unsigned integer" '(unsigned-byte 16)) (deftype ulong () "A 32 bit unsigned integer" '(unsigned-byte 32)) ;;; LISTs, CATs, and PROPs are similar in shape, so we use the NAMED-LIST structure to represent all of them. ;;; A CAT is a grouping of objects in the file. ;;; A LIST is a grouping of objects which share some common characteristics. The first element of a LIST is a PROP. ;;; A PROP is a grouping of the common characteristics of the LIST to which it belongs. ;;; (defstruct named-list (type :LIST :type (member :LIST :CAT :PROP)) (name nil :type (or null keyword)) (contents nil :type list)) (defun cat-p (thing) (and (named-list-p thing) (eq :CAT (named-list-type thing)))) (defun list-p (thing) (and (named-list-p thing) (eq :LIST (named-list-type thing)))) (defun prop-p (thing) (and (named-list-p thing) (eq :PROP (named-list-type thing)))) ;;; Describing a thing read from a file. ;;; (defvar *describers* () "This is an alist used by IFF-DESCRIBE to find the describer of an IFF thing.") (defun iff-describe (thing &optional type) (declare (arglist thing)) (let* ((describe-depth (if (boundp 'describe-depth) (+ describe-depth 6) 0))) (declare (special describe-depth)) (let* ((f (cdr (find-if #'(lambda (x) (or (eq (car x) type) (typep thing (car x)))) *describers*)))) (if f (funcall f thing type) (format t "~& unknown ***** ~S *****~%" thing)))) (values)) (defmacro def-describer ((structure-type &optional (var structure-type)) &body body) "Define a way for IFF-DESCRIBE to describe things of TYPE. The BODY should do output with the local function (DUMP format-string &rest format-args). This function indents things properly. Calls to DUMP should *not* begin with ~&. The variable passed in VAR will be bound to the thing we are describing. The variable TYPE will be bound to whatever was passed in during a recursive call to IFF-DESCRIBE." `(push (cons ',structure-type #'(lambda (,var type) (declare (special describe-depth)) ,var type (flet ((dump (format-string &rest args) (fresh-line) (dotimes (i describe-depth) (princ #\Space *standard-output*)) (apply #'format t format-string args))) ,@body))) *describers*)) (def-describer (NAMED-LIST thing) (ecase (named-list-type thing) (:CAT (dump "LIST ~A: Group of Forms." (named-list-name thing))) (:LIST (dump "LIST ~A: A group of objects sharing the characteristics in the first element, the PROP." (named-list-name thing))) (:PROP (dump "PROP ~A: A group of common characteristics shared by all elements in a LIST." (named-list-name thing)))) (dolist (form (named-list-contents thing) (iff-describe form)))) (def-describer (NULL thing) (when type (dump "~A: none." type))) ;;; Reading bytes (integers) of various sizes. (eval-when (load eval compile) (proclaim '(inline read-byte read-ubyte read-short-word read-ushort-word read-long-word read-ulong-word)) (defvar *bytes-read* 0 "Count of bytes read. Don't touch this.") (defun read-ubyte (stream) "Read an 8 bit unsigned integer from STREAM." (let* ((v (or (lisp:read-byte stream nil nil) (throw 'IFF-EOF :eof)))) (incf *bytes-read*) v)) (defun read-byte (stream) "Read an 8 bit signed integer from STREAM." (let ((ubyte (read-ubyte stream))) (if (> ubyte #x7F) (- ubyte #x100) ubyte))) (defun read-ushort-word (stream) "Read a 16 bit unsigned integer from STREAM." (+ (* #x100 (read-ubyte stream)) (read-ubyte stream))) (defun read-short-word (stream) "Read a 16 bit signed integer from STREAM." (let ((ushort (read-ushort-word stream))) (if (> ushort #x7FFF) ; (2^16)/2 - 1 (- ushort #x10000) ; (2^16) ushort))) (defun read-ulong-word (stream) "Read a 32 bit unsigned integer from STREAM." (+ (* #x10000 (read-ushort-word stream)) (read-ushort-word stream))) (defun read-long-word (stream) "Read a 32 bit signed integer from STREAM." (let* ((ulong (read-ulong-word stream))) (if (> ulong #x7FFFFFFF) ; (2^32)/2 - 1 (- ulong #x100000000) ; (2^32) ulong))) (defmacro round-up-to (limit number) "Returns the next multiple of LIMIT greater than or equal to NUMBER." `(+ ,limit (* ,limit (floor (1- ,number) ,limit)))) ) ; closes EVAL-WHEN. (defvar *all-forms-known* '(:FORM :LIST :CAT :PROP :PLBM :ILBM :ANBM :FTXT :PICS :USCR :GSCR :UVOX :GVOX :SFX :FNTR :FNTV :VDEO :PDEV :TEXT :PICT :OPGM :OCPU :OCMP :UNAM :BMHD :CMAP :GRAB :DEST :SPRT :CAMG :CRNG :CREG :BODY :8SVX :NAME :CRIGHT :AUTH :ANNO :ATAK :RLSE :|(c)| :VHDR ) "This is a list of all of the standard forms in the IFF format. We do not, of course, handle all of them.") (defun read-chunk-id (stream) "Read a four-character identifier from STREAM as a keyword. If the identifier begins or ends with whitespace, it will be trimmed from the keyword. This function does not INTERN; it looks up the appropriate keyword on the list *ALL-FORMS-KNOWN*. This eliminates the overhead of INTERN, and causes a bad file to not clutter symbol-space with garbage." (let ((string (make-string 4))) (setf (schar string 0) (int-char (read-ubyte stream))) (setf (schar string 1) (int-char (read-ubyte stream))) (setf (schar string 2) (int-char (read-ubyte stream))) (setf (schar string 3) (int-char (read-ubyte stream))) (when (find #\Space string :test #'char=) (setq string (string-trim " " string))) (let* ((sym (find string (the list *all-forms-known*) :test #'string= :key #'symbol-name))) (values sym string)))) (defvar *read-iff-verbose* t "If non-NIL, print info about what's being read.") (defvar *iff-report-indent* 1 "How many spaces recursive calls to REPORTING-FORM indent.") (defmacro reporting-form ((format-string &rest format-args) &body body) "Used for reporting recursive IFF reads. If *READ-IFF-VERBOSE* is non-NIL, then FORMAT-STRING will be applied to FORMAT-ARGS, after outputting some amount of whitespace. The amount of preceeding whitespace is based on how deeply nested within REPORTING-FORM this invocation is; so any potentially recursice reads should be within the BODY of this macro." `(let* ((read-iff-level (if (boundp 'read-iff-level) (+ read-iff-level *iff-report-indent*) 0))) (declare (special read-iff-level)) (when *read-iff-verbose* (fresh-line *error-output*) (dotimes (i read-iff-level) (princ #\space *error-output*)) (format *error-output* ,format-string ,@format-args)) ,@body)) (defun read-toplevel-form (stream) "Read the top-level form from the IFF file on STREAM. Returns two values, the thing read, and the number of bytes it occupied." (declare (values thing nbytes)) (multiple-value-bind (id id-as-string) (read-chunk-id stream) (reporting-form ("Reading a top-level ~A." id-as-string) (case id (:FORM (read-form stream)) (:LIST (read-list stream)) (:CAT (read-cat stream)) (t (read-and-ignore-chunk stream id-as-string)))))) ;;; ;;; This is used only by READ-LIST and READ-CAT - ;;; It may be unnecessary if it is true that a LIST/CAT can contain only FORMs. ;;; (defun read-one-chunk (stream) "Read the next form from the IFF file on stream. Returns two values, the thing read, and the number of bytes it occupied." (declare (values thing nbytes)) (multiple-value-bind (id id-as-string) (read-chunk-id stream) (case id (:FORM (read-form stream)) (:LIST (read-list stream)) (:CAT (read-cat stream)) ;(:BMHD (read-bmhd stream)) ;(:CMAP (read-cmap stream)) (t (read-and-ignore-chunk stream id-as-string))))) (defun read-and-ignore-chunk (stream &optional id) "Read the next chunk from STREAM and ignore it; do this for any chunk you don't want to handle. ID is not necessary; if you supply it, it will be printed in the debugging output." (declare (values nil nbytes)) (let* ((len (read-ulong-word stream))) (when *read-iff-verbose* (reporting-form ("") (if id (format t "Ignoring a ~A of length ~D: " id len) (format t "Ignoring ~D bytes: " len)))) (when (oddp len) (incf len)) ; word-align. (catch 'IFF-EOF (dotimes (i len) (read-ubyte stream))) (values nil len))) ;;; A "CAT " is simply a list of objects. ;;; (defun read-cat (stream &optional prop-p) "Read a list of chunks from STREAM. Returns two values: the CAT and the number of bytes read. If PROP-P is non-NIL, then we are really reading a PROP, not a CAT. This is used only in diagnostic messages." (declare (values named-list nbytes)) (let* ((name (read-chunk-id stream)) (maxlength (read-ulong-word stream)) (contents nil) (length 0)) (reporting-form ("Reading a ~A ~A, length ~D bytes." (if prop-p :PROP :CAT) name maxlength) (catch 'IFF-EOF (do* () ((>= length maxlength)) (multiple-value-bind (thing thing-length) (read-one-chunk stream) (push thing contents) (incf length thing-length))) (when (oddp length) (read-ubyte stream))) (values (make-named-list :type :CAT :name name :contents (nreverse contents)) length)))) ;;; A "LIST" is a list of objects which share some characteristics. ;;; These shared characteristics are in the "PROP" form. ;;; (defun read-list (stream) "Read a list of chunks with common properties from STREAM. Returns two values: the LIST and the number of bytes read." (declare (values named-list nbytes)) (let* ((name (read-chunk-id stream)) (maxlength (read-ulong-word stream)) (length 0) (prop nil) (contents nil)) (reporting-form ("Reading a LIST ~A, length ~D bytes." name maxlength) (catch 'IFF-EOF (do* () ((>= length maxlength)) (multiple-value-bind (thing thing-length) (read-one-chunk stream) (cond ((prop-p thing) (cond (prop (error "More than one PROP encountered in a LIST.")) (contents (error "PROP encountered after first element of a LIST.")) (t (setq prop thing)))) (t (push thing contents))) (incf length thing-length))) (when (oddp length) (read-ubyte stream))) (values (make-named-list :type :LIST :name name :contents (cons prop (nreverse contents))) length)))) ;;; A "PROP" is a list which occurs as the first element of a "LIST". ;;; (defun read-prop (stream) "Read a list of common-property chunks from STREAM. Returns two values: the PROP and the number of bytes read." (declare (values named-list nbytes)) (multiple-value-bind (cat length) (read-cat stream t) (setf (named-list-type cat) :PROP) (values cat length))) ;;; A "FORM" is essentially a "CAT " of one element. ;;; (defun read-form (stream) "Read a form-chunk from STREAM. Returns two values: the chunk and the number of bytes read." (declare (values object nbytes)) (let* ((length (read-ulong-word stream))) (multiple-value-bind (name name-string) (read-chunk-id stream) (let* ((reader (and name (get name 'FORM-READER)))) (reporting-form ("~A a FORM ~A, length ~D bytes." (if reader "Reading" "Ignoring") name-string length) (if reader (funcall reader stream length) (catch 'IFF-EOF (dotimes (i length) (read-ubyte stream)) (when (oddp length) (read-ubyte stream))) (values nil length))))))) ;;; IFF-READ, the top level of the whole thing... (defun iff-read (file &optional (verbose t) (ilbm-correct-aspect-ratio-p t)) "Read and return some IFF object from the FILE. If VERBOSE is NIL, then nothing will be printed; else each CHUNK read will be announced. If CORRECT-ASPECT-RATIO-P is non-NIL, then the aspect ratio of the picture will be adjusted to 1:1. Some Amiga programs are bad at aspect ratios - they write obviously incorrect ones out. If we detect a silly aspect ratio, and CORRECT-ASPECT-RATIO-P is T, then the user will be prompted as to whether the given aspect ratio should be used, or the probably-right one. If it is :ALWAYS, then the user is never asked, and we assume ``yes''; if it is :NEVER, then we assume ``no.'' " (check-type ilbm-correct-aspect-ratio-p (member T NIL :ALWAYS :NEVER)) (let* ((form nil)) (with-open-file (stream file :direction :input :characters nil :byte-size 8) (setq *bytes-read* 0) (let* ((*read-iff-verbose* verbose)) (setq form (read-toplevel-form stream)))) (when (and ilbm-correct-aspect-ratio-p (typep form 'ILBM)) (correct-for-aspect-ratio form (eq ilbm-correct-aspect-ratio-p t) (eq ilbm-correct-aspect-ratio-p :always))) form))