;;; dat/midi.lisp --- MIDI data

 ;;;  (c) copyright 2003 by Mathieu Chabanne, Camille Constant,

 ;;;                        Emmanuel Necibar and Stephanie Recco

 ;;;

 ;;;  (c) copyright 2003 by Robert Strandh (strandh@labri.fr)

 ;;;

 ;;;  (c) copyright 2007 by David Lewis, Marcus Pearce, Christophe

 ;;;                        Rhodes and contributors

 ;;;

 ;;; This library is free software; you can redistribute it and/or

 ;;; modify it under the terms of version 2 of the GNU Lesser General

 ;;; Public License as published by the Free Software Foundation.

 ;;;

 ;;; This library is distributed in the hope that it will be useful,

 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

 ;;; Lesser General Public License for more details.

 ;;;

 ;;; You should have received a copy of the GNU Lesser General Public

 ;;; License along with this library; if not, write to the

 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,

 ;;; Boston, MA  02111-1307  USA.

 ;;;

 ;;; This file contains library for MIDI and Midifiles. Messages are

 ;;; represented as CLOS class instances in a class hierarchy that

 ;;; reflects interesting aspects of the messages themselves.

 (in-package :dat/midi)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;

 ;;; Midifile protocol

 (defgeneric midifile-format (midifile))

 (defgeneric (setf midifile-format) (format midifile))

 (defgeneric midifile-division (midifile))

 (defgeneric midifile-tracks (midifile))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;

 ;;; Message protocol

 (defgeneric message-time (message))

 (defgeneric (setf message-time) (time message))

 (defgeneric message-status (message))

 (defgeneric message-channel (message))

 (defgeneric message-key (message))

 (defgeneric message-velocity (message))

 (defgeneric message-tempo (message))

 (defgeneric message-numerator (message))

 (defgeneric message-denominator (message))

 (defgeneric message-sf (message))

 (defgeneric message-mi (message))

 ;; added 03-05-07

 (defgeneric message-program (message))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;

 ;;; File support

 (eval-when (:compile-toplevel :load-toplevel)

   (defun string-code (s)

     "compute the ASCII-based numerical value of the string [warning:

 works only if the chars are coded in ASCII]"

     (let ((v 0))

       (loop for i from 0 to (1- (length s))

 	    do (setf v (+ (* v 256) (char-code (aref s i)))))

       v)))

 (defconstant +header-mthd+ #.(string-code "MThd"))

 (defconstant +header-mtrk+ #.(string-code "MTrk"))

 (defconstant +header-mthd-length+ 6 "value of the header MThd data's length")

 (defparameter *midi-input* nil "stream for reading a Midifile")

 (defparameter *input-buffer* '() "used for unreading bytes from *midi-input")

 (defparameter *midi-output* nil "stream for writing a Midifile")

 (define-condition unknown-event ()

   ((status :initarg :status :reader status)

    (data-byte :initform "" :initarg :data-byte :reader data-byte))

   (:documentation "condition when the event does not exist in the library"))

 (define-condition header ()

   ((header-type :initarg :header :reader header-type))

   (:documentation "condition when the header is not correct"))

 (defun read-next-byte ()

   "read an unsigned 8-bit byte from *midi-input* checking for unread bytes"

   (if *input-buffer*

       (pop *input-buffer*)

       (read-byte *midi-input*)))

 (defun unread-byte (byte)

   "unread a byte from *midi-input*"

   (push byte *input-buffer*))

 (defun write-bytes (&rest bytes)

   "write an arbitrary number of bytes to *midi-output*"

   (mapc #'(lambda (byte) (write-byte byte *midi-output*)) bytes))

 (defun read-fixed-length-quantity (nb-bytes)

   "read an unsigned integer of nb-bytes bytes from *midi-input*"

   (loop with result = 0

 	for i from 1 to nb-bytes

 	do (setf result (logior (ash result 8) (read-next-byte)))

 	finally (return result)))

 (defun write-fixed-length-quantity (quantity nb-bytes)

   "write an unsigned integer of nb-bytes bytes to *midi-output*"

   (unless (zerop nb-bytes)

     (write-fixed-length-quantity (ash quantity -8) (1- nb-bytes))

     (write-bytes (logand quantity #xff))))

 (defmacro with-midi-input ((pathname &rest open-args &key &allow-other-keys) &body body)

   "execute body with *midi-input* assigned to a stream from pathname"

   `(with-open-file (*midi-input* ,pathname

 		                 :direction :input :element-type '(unsigned-byte 8)

 		                 ,@open-args)

      ,@body))

 (defmacro with-midi-output ((pathname &rest open-args &key &allow-other-keys) &body body)

   "execute body with *midi-output* assigned to a stream from pathname"

   `(with-open-file (*midi-output* ,pathname

 		                  :direction :output :element-type '(unsigned-byte 8)

 		                  ,@open-args)

      ,@body))

 (defun read-variable-length-quantity ()

   "read a MIDI variable length quantity from *midi-input*"

   (loop with result = 0

 	with byte

 	do (setf byte (read-next-byte)

 		 result (logior (ash result 7) (logand byte #x7f)))

 	until (< byte #x80)

 	finally (return result)))

 (defun write-variable-length-quantity (quantity &optional (termination 0))

   (when (> quantity 127)

     (write-variable-length-quantity (ash quantity -7) #x80))

   (write-bytes (logior (logand quantity #x7f) termination)))

 (defun length-of-variables-length-quantity (quantity)

   (1+ (if (< quantity 128)

 	  0

 	  (length-of-variables-length-quantity (ash quantity -7)))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;

 ;;; MIDI file representation

 (defclass midifile ()

   ((format :initarg :format :reader midifile-format)

    (division :initarg :division :reader midifile-division)

    (tracks :initarg :tracks :reader midifile-tracks))

   (:documentation "the class that represents a Midifile in core"))

 (defparameter *status* nil "the status while reading an event")

 (defparameter *running-status* nil "the running status while reading an event")

 (defparameter *dispatch-table* (make-array 256 :initial-element nil)

   "given values of status (and perhaps data1), find a class to create")

 (defun read-message ()

   "read a message without time indication from *midi-input*"

   (let ((classname-or-subtype (aref *dispatch-table* *status*)))

     (unless classname-or-subtype

       (error (make-condition 'unknown-event

 			     :status *status*)))

     (if (symbolp classname-or-subtype)

 	(make-instance classname-or-subtype)

 	(let* ((data-byte (read-next-byte))

 	       (classname (aref classname-or-subtype data-byte)))

 	  (unless classname

 	    (error (make-condition 'unknown-event

 				   :status *status*

 				   :data-byte data-byte)))

 	  (unread-byte data-byte)

 	  (make-instance classname)))))

 (defparameter *time* 0 "accumulated time from the start of the track")

 (defun read-timed-message ()

   "read a message preceded with a delta-time indication"

   (let ((delta-time (read-variable-length-quantity))

 	(status-or-data (read-next-byte)))

     (if (>= status-or-data #x80)

 	(progn (setf *status* status-or-data)

 	       (when (<= *status* #xef)

 		 (setf *running-status* *status*)))

 	(progn (unread-byte status-or-data)

 	       (setf *status* *running-status*)))

     (let ((message (read-message)))

       (fill-message message)

       (setf (message-time message) (incf *time* delta-time))

       message)))

 (defun write-timed-message (message)

   "write a message preceded with a delta-time indication"

   (write-variable-length-quantity (- (message-time message) *time*))

   (setf *time* (message-time message))

   (write-message message))

 (defun read-track ()

   "read a track as a list of timed messages, excluding the end-of-track message"

   (let ((type (read-fixed-length-quantity 4))

 	(length (read-fixed-length-quantity 4)))

     (declare (ignore length))

     (unless (= type +header-mtrk+)

       (error (make-condition 'header :header "MTrk")))

     (loop with message = nil

 	  do (setf message (read-timed-message))

 	  until (typep message 'end-of-track-message)

 	  collect message)))

 (defun write-track (track)

   "write a track (which does not contain the end-of-track message"

   (write-fixed-length-quantity  +header-mtrk+ 4)

   (let ((end-of-track-message (make-instance 'end-of-track-message)))

     ;; write the length of the track

     (write-fixed-length-quantity

      (+ (reduce #'+ track :key #'length-message)

 	(length-message end-of-track-message)

 	(loop with time = *time*

 	      for message in track

 	      sum (prog1 (length-of-variables-length-quantity

 			  (- (message-time message) time))

 		    (setf time (message-time message))))

 	1) ; the delta time of the end-of-track message

      4)

     (dolist (message track)

       (write-timed-message message))

     (setf (message-time end-of-track-message) *time*)

     (write-timed-message end-of-track-message)))

 (defun read-midi-file (filename)

   "read an entire Midifile from the file with name given as argument"

   (setf *time* 0)

   (with-midi-input (filename)

     (let ((type (read-fixed-length-quantity 4))

 	  (length (read-fixed-length-quantity 4))

 	  (format (read-fixed-length-quantity 2))

 	  (nb-tracks (read-fixed-length-quantity 2))

 	  (division (read-fixed-length-quantity 2)))

       (unless (and (= length +header-mthd-length+) (= type +header-mthd+))

 	(error (make-condition 'header :header "MThd")))

       (make-instance 'midifile

 	:format format

 	:division division

 	:tracks (loop repeat nb-tracks

 		      do (when (= format 1) (setf *time* 0))

 		      collect (read-track))))))

 (defun write-midi-file (midifile filename)

   (with-midi-output (filename :if-exists :supersede)

     (write-fixed-length-quantity +header-mthd+ 4)

     (write-fixed-length-quantity +header-mthd-length+ 4)

     (with-slots (format division tracks) midifile

       (write-fixed-length-quantity format 2)

       (write-fixed-length-quantity (length tracks) 2)

       (write-fixed-length-quantity division 2)

       (setf *time* 0)

       (loop for track in tracks do

 	(write-track track)

 	(when (= (slot-value midifile 'format) 1)

 	  (setf *time* 0))))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;

 ;;; Conversion routines

 (defun format1-tracks-to-format0-tracks (tracks)

   (list (reduce (lambda (t1 t2) (merge 'list t1 t2 #'< :key #'message-time))

 		(copy-tree tracks))))

 (defun format0-tracks-to-format1-tracks (tracks)

   (assert (null (cdr tracks)))

   (let (tempo-map track)

     (dolist (message (car tracks) (list (nreverse tempo-map) (nreverse track)))

       (if (typep message 'tempo-map-message)

 	  (push message tempo-map)

 	  (push message track)))))

 (defun change-to-format-0 (midifile)

   (assert (= (midifile-format midifile) 1))

   (setf (slot-value midifile 'format) 0

 	(slot-value midifile 'tracks) (format1-tracks-to-format0-tracks (midifile-tracks midifile))))

 (defun change-to-format-1 (midifile)

   (assert (= (midifile-format midifile) 0))

   (setf (slot-value midifile 'format) 1

 	(slot-value midifile 'tracks) (format0-tracks-to-format1-tracks (midifile-tracks midifile))))

 (defmethod (setf midifile-format) (new-value midifile)

   (cond

     ((= (midifile-format midifile) new-value) new-value)

     ((and (= new-value 0) (= (midifile-format midifile) 1))

      (change-to-format-0 midifile)

      new-value)

     ((and (= new-value 1) (= (midifile-format midifile) 0))

      (change-to-format-1 midifile)

      new-value)

     (t (error "Unsupported conversion from format ~S to format ~S"

 	      (midifile-format midifile) new-value))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;

 ;;; Macro for defining midi messages

 (defparameter *status-min* (make-hash-table :test #'eq)

   "given a class name, find the minimum status value for the type of message")

 (defparameter *status-max* (make-hash-table :test #'eq)

   "given a class name, find the maximum status value for the type of message")

 (defparameter *data-min* (make-hash-table :test #'eq)

   "given a class name, find the minimum data1 value for the type of message")

 (defparameter *data-max* (make-hash-table :test #'eq)

   "given a class name, find the maximum data1 value for the type of message")

 (defun register-class (class superclass status-min status-max data-min data-max)

   (unless status-min

     (setf status-min (gethash superclass *status-min*)))

   (unless status-max

     (setf status-max (gethash superclass *status-max*)))

   (unless data-min

     (setf data-min (gethash superclass *data-min*)))

   (unless data-max

     (setf data-max (gethash superclass *data-max*)))

   ;; set status values for this class

   (setf (gethash class *status-min*) status-min)

   (setf (gethash class *status-max*) status-max)

   (setf (gethash class *data-min*) data-min)

   (setf (gethash class *data-max*) data-max)

   ;; update the dispatch table

   (when status-min

     (if data-min

 	(progn (unless (arrayp (aref *dispatch-table* status-min))

 		 (let ((secondary-dispatch (make-array 256

 						       :initial-element nil)))

 		   (loop for i from status-min to status-max do

 		     (setf (aref *dispatch-table* i) secondary-dispatch))))

 	       (loop for i from data-min to data-max do

 		 (setf (aref (aref *dispatch-table* status-min) i)

 		       class)))

 	(loop for i from status-min to status-max do

 	  (setf (aref *dispatch-table* i)

 		class)))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;

 ;;; main filler, length, and writer methods

 (defgeneric fill-message (message))

 (defgeneric write-message (message))

 (defgeneric length-message (message)

   (:method-combination +))

 (defmethod fill-message (message)

   (declare (ignore message))

   nil)

 (defmethod length-message + (message)

   (declare (ignore message))

   0)

 (defmethod write-message (message)

   (declare (ignore message))

   nil)

 (defparameter *midi-channel* 0

   "Default MIDI channel for midi-messages for which status-min and status-max

 have a difference of 15.  When bound to an \(<= 0 integer 15\), the :status

 default value will automatically combine the message's status-min and

 *midi-channel*.")

 (defmacro define-midi-message (name superclasses

 			       &key slots filler (length 0) writer

 			         status-min status-max data-min data-max)

   `(progn

      (register-class ',name ',(car superclasses)

                      ,status-min ,status-max ,data-min ,data-max)

      (defclass ,name ,superclasses