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

;;;
;;; This file contains code for reading IFF 8SVX sound files, and for playing them on the Explorer D/A.
;;;


;;;  ChangeLog:
;;;
;;; 30 Dec 88  Jamie Zawinski  Created.


(in-package "IFF")


;;; Sound structure definitions


(deftype fixed ()
  "A fixed-point value, 16 bits to the left of the point and 16 to the right.
  A Fixed is a number of 216ths, i.e. 65536ths."
  '(unsigned-byte 32))

(defconstant FIXED-UNITY #x10000 "Unity = Fixed 1.0 = maximum volume.")


(defstruct (8svx-vhdr (:conc-name "VHDR-"))
  (one-shot-hi-samples 0 :type ulong)	; Number of samples in the high octave 1-shot part
  (repeat-Hi-Samples 0 :type ulong)	; Number of samples in the high octave repeat part
  (samples-Per-Hi-Cycle 0 :type ulong)	; Number of samples/cycle in high octave, else 0
  (samples-Per-Sec 0 :type uword)	; data sampling rate
  (Octave 0 :type ubyte)		; Number of octaves of waveforms
  (Compression NIL :type (member NIL :CMP-FIB-DELTA))
  (volume 0 :type fixed)		; playback volume from 0 to Unity (full volume). 
                                        ;   Map this value into the output hardware's dynamic range.
  )

(defstruct 8svx-name
  "The name of this sample."
  (string "" :type string))

(defstruct 8svx-cright  ; really called "(c) "
  "Copyright notice of this sample."
  (string "" :type string))

(defstruct 8svx-auth
  "Sample author's name"
  (string "" :type string))

(defstruct 8svx-anno
  "Random comments about this sample."
  (string "" :type string))


(defstruct 8svx-egpoint
  (duration 0 :type uword)   ; duration in miliseconds
  (dest 0 :type fixed))      ; destination volume factor

(defstruct (8svx-atak (:include 8svx-EGpoint)))
(defstruct (8svx-rlse (:include 8svx-EGpoint)))

(defstruct 8svx-body
  (data nil :type (or null (vector fixed)))
  (max-sample nil :type (or null fixed))
  (min-sample nil :type (or null fixed))
  (avg-sample nil :type (or null fixed))
  )

(defstruct 8svx
  (vhdr nil :type (or null 8svx-vhdr))
  (name nil :type (or null 8svx-name))
  (cright nil :type (or null 8svx-cright))
  (auth nil :type (or null 8svx-auth))
  (anno nil :type (or null 8svx-anno))
  (atak nil :type (or null 8svx-atak))
  (rlse nil :type (or null 8svx-rlse))
  (body nil :type (or null 8svx-body))
  )



;;; Reading sound

(setf (get :8SVX 'FORM-READER) 'READ-8SVX)

(defun read-8svx (stream maxlength)
  "Read an interleaved bitmap from STREAM.  Returns two values: the ILBM and the number of bytes read."
  (declare (values 8svx nbytes))
  (reporting-form ("Reading an 8SVX, length ~D bytes" maxlength)
    (let* ((length 0)
	   id idname vhdr name cright auth anno atak rlse body ig)
      (catch 'IFF-EOF
	(do* ()
	     ((>= length maxlength))
	  (multiple-value-setq (id idname) (read-chunk-id stream))
	  (incf length 4)
	  (let* (thing-length)
	    (case id
	      (:VHDR (multiple-value-setq (vhdr thing-length) (read-8svx-vhdr stream)))
	      (:NAME (when body (error "The NAME of an 8SVX must preceed the BODY."))
		     (multiple-value-setq (name thing-length) (read-8svx-name stream)))
	      (:|(c)| (when body (error "The CRIGHT of an 8SVX must preceed the BODY."))
		       (multiple-value-setq (cright thing-length) (read-8svx-cright stream)))
	      (:AUTH (when body (error "The AUTH of an 8SVX must preceed the BODY."))
		     (multiple-value-setq (auth thing-length) (read-8svx-auth stream)))
	      (:ATAK (multiple-value-setq (atak thing-length) (read-8svx-atak stream)))
	      (:RLSE (multiple-value-setq (rlse thing-length) (read-8svx-rlse stream)))
	      (:BODY (unless vhdr (error "The VHDR of an 8SVX must preceed the BODY."))
		     (multiple-value-setq (body thing-length) (read-8svx-body vhdr stream)))
	      (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-8svx :VHDR vhdr :NAME name :CRIGHT cright :AUTH auth :ANNO anno :ATAK atak :RLSE rlse :BODY body)
	      length))))

(defun read-8svx-vhdr (stream)
  (declare (values vhdr nbytes))
  (let* ((length (read-ulong-word stream))
	 (vhdr (make-8svx-vhdr)))
    (reporting-form ("Reading a VHDR of length ~D bytes." length)
      (setf (vhdr-one-shot-hi-samples vhdr) (read-ulong-word stream))
      (setf (vhdr-repeat-hi-samples vhdr) (read-ulong-word stream))
      (setf (vhdr-samples-per-hi-cycle vhdr) (read-ulong-word stream))
      (setf (vhdr-samples-per-sec vhdr) (read-ushort-word stream))
      (setf (vhdr-octave vhdr) (read-ubyte stream))
      (let* ((n (read-ubyte stream)))
	(setf (vhdr-compression vhdr) (ecase n (0 nil) (1 :CMP-FIB-DELTA))))
      (setf (vhdr-volume vhdr) (read-ulong-word stream)))
    (values vhdr length)))


(defun read-8svx-text (name stream)
  (declare (values string nbytes))
  (let* ((length (read-ulong-word stream))
	 (string (make-string length))
	 (end-of-string nil))
    (reporting-form ("Reading a ~A of length ~D bytes." name length)
      (dotimes (i length)
	(let* ((code (read-ubyte stream)))
	  (unless end-of-string
	    (if (= code 0)
		(setq end-of-string i)
		(setf (char string i) (int-char code)))))))
    (values (subseq string 0 end-of-string) length)))


(defun read-8svx-name (stream)
  (multiple-value-bind (string nbytes) (read-8svx-text 'NAME stream)
    (values (make-8svx-name :string string)
	    nbytes)))

(defun read-8svx-cright (stream)
  (multiple-value-bind (string nbytes) (read-8svx-text 'CRIGHT stream)
    (values (make-8svx-cright :string string)
	    nbytes)))

(defun read-8svx-auth (stream)
  (multiple-value-bind (string nbytes) (read-8svx-text 'AUTH stream)
    (values (make-8svx-auth :string string)
	    nbytes)))

(defun read-8svx-anno (stream)
  (multiple-value-bind (string nbytes) (read-8svx-text 'AUTH stream)
    (values (make-8svx-anno :string string)
	    nbytes)))

(defun read-8svx-atak (stream)
  (declare (values atak nbytes))
  (let* ((length (read-ulong-word stream))
	 (atak (make-8svx-atak)))
    (reporting-form ("Reading an ATAK of length ~D bytes." length)
      (setf (8svx-atak-duration atak) (read-ulong-word stream))
      (setf (8svx-atak-dest atak) (read-ulong-word stream)))
    (values atak length)))

(defun read-8svx-rlse (stream)
  (declare (values rlse nbytes))
  (let* ((length (read-ulong-word stream))
	 (rlse (make-8svx-rlse)))
    (reporting-form ("Reading a RLSE of length ~D bytes." length)
      (setf (8svx-rlse-duration rlse) (read-ulong-word stream))
      (setf (8svx-rlse-dest rlse) (read-ulong-word stream)))
    (values rlse length)))


#+LISPM
(defun make-8svx-sample-array (length)
  (let* ((a (allocate-resource 'TV:SOUND-ARRAY length)))
    (setf (fill-pointer a) length)
    a))

#-EXPLORER
(defun make-8svx-sample-array (length)
  (make-array length :element-type 'ubyte))



;;; Code for quickly reversing the bit-order of a number.

(defun reverse-bit-order (number)
  "NUMBER is treated as an 8 bit quantity.  A number is returned which has the opposite bit-order."
  (dpb (ldb (lisp:byte 1 0) number) (lisp:byte 1 7)
       (dpb (ldb (lisp:byte 1 1) number) (lisp:byte 1 6)
	    (dpb (ldb (lisp:byte 1 2) number) (lisp:byte 1 5)
		 (dpb (ldb (lisp:byte 1 3) number) (lisp:byte 1 4)
		      (dpb (ldb (lisp:byte 1 4) number) (lisp:byte 1 3)
			   (dpb (ldb (lisp:byte 1 5) number) (lisp:byte 1 2)
				(dpb (ldb (lisp:byte 1 6) number) (lisp:byte 1 1)
				     (dpb (ldb (lisp:byte 1 7) number) (lisp:byte 1 0) 0)))))))))


(defun make-reverse-bit-order-table ()
  "Return an array mapping numbers to their bit-reverses."
  (let* ((a (make-array 256 :element-type '(unsigned-byte 8))))
    (dotimes (i 256)
      (setf (aref a i) (reverse-bit-order i)))
    a))

(defvar *reverse-bit-order-table* (make-reverse-bit-order-table)
  "An array mapping numbers to their bit-reverses.")

(proclaim '(inline twiddle))
(defun twiddle (n)
  "NUMBER is treated as an 8 bit quantity.  A number is returned which has the opposite bit-order."
  (the (unsigned-byte 8) (aref (the vector *reverse-bit-order-table*) n)))



(defun read-8svx-body (vhdr stream)
  (declare (values body nbytes))
  (let* ((length (read-ulong-word stream))
	 (body (make-8svx-body))
	 (hi nil)
	 (low nil)
	 (total 0))
    (when (vhdr-compression vhdr)
      (error "Don't know how to deal with ~A sound compression." (vhdr-compression vhdr)))
    (reporting-form ("Reading a BODY of length ~D bytes." length)
      (let* ((array (make-8svx-sample-array length)))
	(setf (8svx-body-data body) array)
	(dotimes (i length)
	  (let* ((presamp (read-byte stream))
		 (sample (+ 128 presamp))
		 (fixed sample)
		 )
	    (incf total fixed)
	    (if hi
		(setq hi (max hi fixed) low (min low fixed))
		(setq hi fixed low fixed))
	    (setf (aref array i) fixed)))
	))
    (setf (8svx-body-max-sample body) hi
	  (8svx-body-min-sample body) low
	  (8svx-body-avg-sample body) (round total length))
    (values body length)))




;;;This is Steve Hayes' Fibonacci Delta sound compression technique. 
;;;It's like the traditional delta encoding but encodes each delta in 
;;;a mere 4 bits. The compressed data is half the size of the original 
;;;data plus a 2-byte overhead for the initial value. This much compression 
;;;introduces some distortion, so try it out and use it with discretion.
;;;
;;;To achieve a reasonable slew rate, this algorithm looks up each stored 
;;;4-bit value in a table of Fibonacci numbers. So very small deltas 
;;;are encoded precisely while larger deltas are approximated. When it 
;;;has to make approximations, the compressor should adjust all the values 
;;;(forwards and backwards in time) for minimum overall distortion.
;;;
;;;Here is the decompressor written in the C programming language.
;;;
;;;/* Fibonacci delta encoding for sound data. */
;;;
;;;BYTE codeToDelta[16] = {-34,-21,-13,-8,-5,-3,-2,-1,0,1,2,3,5,8,13,21};
;;;
;;;/* Unpack Fibonacci-delta encoded data from n byte source buffer into 2*n byte
;;; * dest buffer, given initial data value x. It returns the last data value x
;;; * so you can call it several times to incrementally decompress the data. */
;;;
;;;short D1Unpack(source, n, dest, x)
;;;	BYTE source[], dest[];
;;;	LONG n;
;;;	BYTE x;
;;;	{
;;;	BYTE d;
;;;	LONG i, lim;
;;;
;;;	lim = n <<<< 1;
;;;	for (i = 0; i << lim; ++i)
;;;		{	
;;;		/* Decode a data nybble; high nybble then low nybble. */
;;;		d = source[i >> 1];	/* get a pair of nybbles */
;;;		if (i & 1)		/* select low or high nybble? */
;;;			d &= 0xf;	/* mask to get the low nybble */
;;;		else
;;;			d >>= 4;	/* shift to get the high nybble */
;;;		x += codeToDelta[d];	/* add in the decoded delta */
;;;		dest[i] = x;		/* store a 1-byte sample */
;;;		}
;;;	return(x);
;;;	}
;;;
;;;/* Unpack Fibonacci-delta encoded data from n byte source buffer into 2*(n-2)
;;; * byte dest buffer. Source buffer has a pad byte, an 8-bit initial value,
;;; * followed by n-2 bytes comprising 2*(n-2) 4-bit encoded samples. */
;;;
;;;void DUnpack(source, n, dest)
;;;	BYTE source[], dest[];
;;;	LONG n;
;;;	{
;;;		D1Unpack(source + 2, n - 2, dest, source[1]);
;;;	}


;;; Describing these structures.


(def-describer (8SVX thing)
  (dump "8SVX: A Sampled Sound.")
  (iff-describe (8svx-vhdr thing))
  (iff-describe (8svx-name thing))
  (iff-describe (8svx-cright thing))
  (iff-describe (8svx-auth thing))
  (iff-describe (8svx-anno thing))
  (iff-describe (8svx-atak thing))
  (iff-describe (8svx-rlse thing))
  (iff-describe (8svx-body thing)))

(def-describer (8SVX-VHDR thing)
  (dump "VHDR: Sampled Sound Header.")
  (dump "      One Shot Hi Samples:  ~S" (vhdr-one-shot-hi-samples thing))
  (dump "      Repeat Hi Samples:    ~S" (vhdr-repeat-Hi-Samples thing))
  (dump "      Samples Per Hi Cycle: ~S" (vhdr-samples-per-hi-cycle thing))
  (dump "      Samples Per Second:   ~S  (~,1F kHz)" (vhdr-samples-Per-Sec thing)
	(float (/ (vhdr-samples-Per-Sec thing) 1000)))
  (dump "      Octave:               ~S" (vhdr-octave thing))
  (dump "      Compression:          ~A" (or (vhdr-compression thing) "none"))
  (dump "      Volume:               ~S  (~S%)"
	(vhdr-volume thing) (* (round (vhdr-volume thing) 65536) 100)))

(def-describer (8SVX-NAME thing)   (dump "NAME: ~s" (8svx-name-string thing)))
(def-describer (8SVX-CRIGHT thing) (dump "CRIGHT: ~s" (8svx-cright-string thing)))
(def-describer (8SVX-AUTH thing)   (dump "AUTH: ~s" (8svx-auth-string thing)))
(def-describer (8SVX-ANNO thing)   (dump "ANNO: ~s" (8svx-anno-string thing)))

(def-describer (8SVX-ATAK thing)
  (dump "ATAK:")
  (dump "Duration in Milliseconds:  ~S" (8svx-atak-duration thing))
  (dump "Destination Volume Factor: ~S" (8svx-atak-dest thing)))

(def-describer (8SVX-RLSE thing)
  (dump "RLSE:")
  (dump "Duration in Milliseconds:  ~S" (8svx-rlse-duration thing))
  (dump "Destination Volume Factor: ~S" (8svx-rlse-dest thing)))

(def-describer (8SVX-BODY thing)
  (dump "BODY: ~D sample~:P." (length (8svx-body-data thing)))
  (dump "      Max Sample:  ~D" (8svx-body-max-sample thing))
  (dump "      Min Sample:  ~D" (8svx-body-min-sample thing))
  (dump "      Avg Sample:  ~D" (8svx-body-avg-sample thing)))



;;; Playing them.


#+LISPM
(defun play (8svx &optional (start 0))
  "Play the sampled sound in the 8SVX."
  (let* ((vhdr (8svx-vhdr 8svx))
	 (samples-per-sec (vhdr-samples-per-sec vhdr))
	 (pitch-mod (float (/ samples-per-sec 8000)))  ; Multiply by this to change sample rate to Explorer's 8 kHz.
	 (body (8svx-body 8svx))
	 (array (8svx-body-data body))
	 (length (1- (length array)))
;	 (hi (8svx-body-max-sample body))
;	 (low (8svx-body-max-sample body))
;	 (avg (8svx-body-avg-sample body))
;	 (volume-mod (float (/ avg 128)))
	 (volume-mod 1.8)
	 (name-chunk (8svx-name 8svx))
	 (name (if name-chunk (8svx-name-string name-chunk) (string (gensym))))
	 sym)
    ;;
    ;; Convert the "name" to a symbol - strip off common file entensions, upcase it, intern it in KEYWORD.
    ;;
    (when name
      (let* ((nl (length name)))
	(dolist (suffix '(".iff" ".8svx" ".sound" ".sample"))
	  (let* ((sl (length suffix)))
	    (when (and (> nl sl) (string-equal name suffix :start1 (- nl sl)))
	      (setq name (subseq name 0 (- nl sl)))
	      (return)))))
      (setq sym (intern (string-upcase name) "KEYWORD"))
      (setf (get sym 'TV:SOUND-ARRAY) array))
    ;;
    ;; Print banner.
    ;;
    (format t "~&;;; playing ~A - ~,1F kHz, ~,1F second~:P."
	    (if name sym "unnamed sample")
	    (float (/ samples-per-sec 1000))
	    (float (/ (length array) (* pitch-mod 8000))))
    ;;
    ;; Stuff it into the A/D.
    ;;
    (tv:with-real-time
      (tv:with-sound-enabled
	(dotimes (i (floor (- length start) pitch-mod))
	  (declare (fixnum i))
	  (let* ((index (the fixnum (+ start (floor (* pitch-mod i)))))
		 (sample (aref array (the fixnum index))))
	    (declare (fixnum index sample))
	    (tv:speech (min 255 (floor (* volume-mod sample))) nil)))))
    (values 8svx sym)))



;;; Let the Explorer FS know that files ending in .pic, .iff, .ilbm, or .8svx are 8-bit binary.
;;;
#+LISPM (fs::define-canonical-type :8SVX "8svx"
	  (:unix-ucb "8svx")
	  (:unix "8svx")
	  (:lispm "8svx"))
#+LISPM (push :8SVX fs::*copy-file-known-short-binary-types*)