view implementations/midi/midifile-import.lisp @ 204:10d47e78a53d

Added support for most significant midi messages (some remain missing,
but these do not occur in a 1000-file test sample)

(cl:in-package #:amuse-midi) 

(defparameter *default-tempo* 120)

(defclass midifile-identifier (composition-identifier midi-object)
  ((pathname :initarg :path
	     :reader midifile-identifier-pathname
	     :initform 'nil))
  (:documentation "Identifier for MIDI files, containing pathname
  information"))

(defun midifile-id (pathname)
  "Creates an identifier for MIDI files, based on a pathname"
  (make-instance 'midifile-identifier :path pathname))

(defmethod get-composition ((identifier midifile-identifier))
  (%initialise-midifile-composition (midi:read-midi-file
				     (midifile-identifier-pathname identifier))))

(defun %initialise-midifile-composition (midifile)
  ;; Takes a midifile object (from the "MIDI" package)
  ;; and returns an amuse midi object
  ;; FIXME: gets it wrong if patch changes in mid-note
  ;; FIXME: assumes controllers are global in scope and location
  (let ((tracks (midi:midifile-tracks midifile))
	(division (midi:midifile-division midifile))
	(notes) (time-sigs) (key-sigs) (tempi)
        (pitch-bends) (texts) (lyrics) 
        (rpn-lsb) (rpn-msb) 
        (nrpn-msb) (nrpn-lsb)
        (misc-controllers)
	(track-no -1) (last-time 0))
    (when *default-tempo*
      (push (make-instance 'standard-tempo-period 
			   :time 0
			   :bpm *default-tempo*) tempi))
    (dolist (track tracks)
      (incf track-no)
      (setf track (sort (copy-seq track)
			#'(lambda (x y)
			    (or (< (midi:message-time x)
				   (midi:message-time y))
				(and (= (midi:message-time x)
					(midi:message-time y))
				     (typep x 'midi:note-off-message))))))
      (let ((ons (make-array '(16 128) :initial-element nil))
	    (offs) 
	    (patches (make-array 16 :initial-element 0)))
	(dolist (event track)
      (let* ((midi-time (midi:message-time event))
             (event-time (/ midi-time division)))
        (when (> midi-time last-time)
          (setf last-time midi-time))
        (cond
          ((or (typep event 'midi:note-off-message)
               (and (typep event 'midi:note-on-message)
                    (= (midi:message-velocity event) 0)))
           (let ((pitch (midi:message-key event))
                 (channel (midi:message-channel event)))
	       (if (aref ons channel pitch)
                   (progn 
                     (push (make-event-from-on-off-pair (aref ons channel pitch)
                                                        midi-time
                                                        division
                                                        track-no
                                                        (aref patches channel))
                           notes)
                     (setf (aref ons channel pitch) nil))
		   ;; if there's no matching on, wait until the beat
		   ;; is done.
		   (push event offs))))
	    ((typep event 'midi:note-on-message)
	     (let ((pitch (midi:message-key event))
		   (channel (midi:message-channel event)))
	       (when (aref ons channel pitch)
		 ;; there's a note already sounding. End it.
		 (push (make-event-from-on-off-pair (aref ons channel pitch)
						    midi-time
						    division
						    track-no
						    (aref patches channel))
		       notes))
	       (setf (aref ons channel pitch) event)))
	    ((typep event 'midi:time-signature-message)
	     ;; FIXME: Should I make a midi version of this object,
	     ;; with track/channel?
	     (when time-sigs
	       (setf (duration (car time-sigs))
		     (- event-time
			(timepoint (car time-sigs)))))
	     (push (make-instance 'standard-time-signature-period
				  :time event-time
				  :numerator (midi:message-numerator event)
				  :denominator (expt 2 (midi:message-denominator event)))
		   time-sigs))
	    ((typep event 'midi:key-signature-message)
	     ;; FIXME: Should I make a midi version of this object,
	     ;; with track/channel? [probably, yes]
	     (when key-sigs
	       (setf (duration (car time-sigs))
		     (- event-time
			(timepoint (car time-sigs)))))
	     (push (make-instance 'midi-key-signature-period
				  :time event-time
				  :sharp-count (midi:message-sf event)
				  :mode (midi:message-mi event))
		   key-sigs))
	    ((typep event 'midi:tempo-message)
	     (when tempi
	       (if (= midi-time 0)
		   ;; to allow for default tempo kludge. Nightingale
		   ;; seems to happily export midi with no initial
		   ;; tempo, but tempo changes later. Making this
		   ;; uncertainty last beyond import could prove
		   ;; confusing (though is probably the `right'
		   ;; answer)
		   (setf tempi nil)
		   (setf (duration (car tempi))
			 (- event-time
			    (timepoint (car tempi))))))
	     (push (make-instance 'standard-tempo-period
				  :time event-time
				  :bpm (microsecond-per-crotchet-to-bpm (midi:message-tempo event)))
		   tempi))
	    ((typep event 'midi:program-change-message)
	     (setf (aref patches (midi:message-channel event))
		   (midi:message-program event)))
        ((typep event 'midi:pitch-bend-message)
         (when pitch-bends
           (setf (duration (car pitch-bends))
                 (- event-time
                    (timepoint (car pitch-bends)))))
         (push (make-controller-moment event track-no event-time)
               pitch-bends))
        ((typep event 'midi::lyric-message)
         (push (make-controller-moment event track-no event-time)
               lyrics))
        ((typep event 'midi::text-message)
         (push (make-controller-moment event track-no event-time)
               texts))
        ((and (typep event 'midi::control-change-message)
              (< 97 (slot-value event 'midi::controller) 102)
              (= (slot-value event 'midi::controller) 127))
         ;; this can only be part of an end-of-this-rpn/nrpn message,
         ;; and these don't really nest because of shared controllers.
         (setf rpn-lsb nil 
               rpn-msb nil
               nrpn-lsb nil
               nrpn-msb nil))
        ((and (typep event 'midi::control-change-message)
              (< 99 (slot-value event 'midi::controller) 102))
         ;; setting rpn, not nrpn
         (setf nrpn-lsb nil
               nrpn-msb nil)
         (if (= (slot-value event 'midi::controller) 100)
             (setf rpn-lsb (slot-value event 'midi::value))
             (setf rpn-msb (slot-value event 'midi::value))))
        ((and (typep event 'midi::control-change-message)
              (< 97 (slot-value event 'midi::controller) 100))
         ;; setting nrpn, not rpn
         (setf rpn-lsb nil
               rpn-msb nil)
         (if (= (slot-value event 'midi::controller) 98)
             (setf nrpn-lsb (slot-value event 'midi::value))
             (setf nrpn-msb (slot-value event 'midi::value))))
        ((and (typep event 'midi::control-change-message)
              (= (slot-value event 'midi::controller) 38))
         (push (make-parameter-moment (slot-value event 'midi::value) nil
                                      event-time track-no
                                      rpn-lsb rpn-msb nrpn-lsb nrpn-msb)
               misc-controllers))
        ((and (typep event 'midi::control-change-message)
              (= (slot-value event 'midi::controller) 6))
         (push (make-parameter-moment nil (slot-value event 'midi::value)
                                      event-time track-no
                                      rpn-lsb rpn-msb nrpn-lsb nrpn-msb)
               misc-controllers))
        ((typep event 'midi::channel-prefix-message)
         ;; I think this is basically a channel specifying hack for a
         ;; preceding instrument name. If I'm wrong, I'll need to
         ;; FIXME
         (when texts
           (setf (%midi-message-channel (car texts))
                 (slot-value event 'midi::channel))))
        (t 
         (push (make-controller-moment event event-time track-no)
               misc-controllers)))))))
    (when tempi
      (setf (duration (car tempi)) (- (/ last-time division) (timepoint (car tempi)))))
    (when pitch-bends
      (setf (duration (car pitch-bends)) (- (/ last-time division) (timepoint (car pitch-bends)))))
    (when time-sigs
      (setf (duration (car time-sigs)) (- (/ last-time division) (timepoint (car time-sigs)))))
    (when key-sigs
      (setf (duration (car key-sigs)) (- (/ last-time division) (timepoint (car key-sigs)))))
    ;; make a midi object from notes, etc.
    (let ((composition (make-instance 'midi-composition
				      :time 0
				      :interval (/ last-time division)
				      :time-signatures (if time-sigs
							   (sort time-sigs #'time<)
							   (list (make-standard-time-signature-period
								  4 4 0 (/ last-time division))))
				      :tempi (sort tempi #'time<)
				      :key-signatures (sort key-sigs #'time<)
                      :pitch-bends (sort pitch-bends #'time<)
                      :texts (sort texts #'time<)
                      :lyrics (sort lyrics #'time<)
                      :controllers (sort misc-controllers #'time<))))
      (sequence:adjust-sequence composition
				(length notes)
				:initial-contents (sort notes #'time<)))))

(defun make-event-from-on-off-pair (note-on cut-off divisions track patch)
  (cond
    ((or (= (midi:message-channel note-on) 9)
	 (> patch 111))
     ;; percussive
     (make-instance 'midi-percussive-event
		    :channel (1+ (midi:message-channel note-on))
		    :track track
		    :time (/ (midi:message-time note-on) divisions)
		    :interval (/ (- cut-off (midi:message-time note-on))
				 divisions)
		    :velocity (midi:message-velocity note-on)
		    :patch patch
		    :sound (midi:message-key note-on)))
    (t
     ;; pitched
     (make-instance 'midi-pitched-event
		    :channel (1+ (midi:message-channel note-on))
		    :track track
		    :time (/ (midi:message-time note-on) divisions)
		    :interval (/ (- cut-off (midi:message-time note-on))
				 divisions)
		    :velocity (midi:message-velocity note-on)
		    :patch patch
		    :number (midi:message-key note-on)))))


(macrolet ((rpn (m-type) `(make-instance ,m-type :lsb value-lsb :msb value-msb 
                                         :time time :track track-no)))
  (defun make-parameter-moment (value-lsb value-msb time track-no rpn-lsb rpn-msb nrpn-lsb nrpn-msb)
    (cond
      ((and nrpn-lsb nrpn-msb)
       (make-instance 'non-registered-parameter-moment
                      :lsb value-lsb     :msb value-msb
                      :nrpn-lsb nrpn-lsb :nrpn-msb nrpn-msb
                      :time time         :track track-no))
      ((or (not rpn-lsb) (not rpn-msb) (= rpn-lsb 0))
       ;; default behaviour
       (rpn 'pitch-bend-sensitivity-moment))
      ((= rpn-lsb 1)
       (rpn 'channel-fine-tuning-moment))
      ((= rpn-lsb 2)
       (rpn 'channel-course-tuning-moment))
      ((= rpn-lsb 3)
       (rpn 'tuning-program-moment))
      ((= rpn-lsb 4)
       (rpn 'tuning-bank-moment))
      ((= rpn-lsb 5)
       (rpn 'modulation-depth-moment))
      (t
       (make-instance 'unknown-registered-parameter-moment
                      :lsb value-lsb   :msb value-msb
                      :reg-lsb rpn-lsb :reg-msb rpn-msb
                      :time time       :track track-no)))))
    
(defgeneric control-number (message)
  (:method ((m midi::reset-all-controllers-message)) 121)
  (:method ((m midi::local-control-message)) 122)
  (:method ((m midi::all-notes-off-message)) 123)
  (:method ((m midi::omni-mode-off-message)) 123)
  (:method ((m midi::omni-mode-on-message)) 124)
  (:method ((m midi::mono-mode-on-message)) 125)
  (:method ((m midi::mono-mode-off-message)) 126)
  (:method ((m midi::poly-mode-on-message)) 127))

(defgeneric control-value (message)
  (:method ((m midi::reset-all-controllers-message)) 0)
  (:method ((m midi::local-control-message)) 
    (slot-value m 'midi::mode))
  (:method ((m midi::all-notes-off-message)) 0)
  (:method ((m midi::omni-mode-off-message)) 0)
  (:method ((m midi::omni-mode-on-message)) 0)
  (:method ((m midi::mono-mode-on-message)) 
    (slot-value m 'midi::nb-channels))
  (:method ((m midi::mono-mode-off-message)) 0)
  (:method ((m midi::poly-mode-on-message)) 0))


(defgeneric make-controller-moment (event track time))
(defgeneric channel-messagep (event)
  (:method ((e channel-message)) t)
  (:method (e) nil)) 
;; There's a lot in common between controller making instances, so
;; let's automate a bit
(macrolet ((controller-maker (midi-class amuse-class &rest slots-and-options)
             `(defmethod make-controller-moment ((event ,midi-class) track time)
                (if (channel-messagep event)
                    (make-instance ,amuse-class :time time
                                   :track track :channel (midi::message-channel event)
                                   ,@slots-and-options)
                    (make-instance ,amuse-class :time time
                                   :track track ,@slots-and-options)))))
  ;; Both of these are control change messages. The latter set are more
  ;; specifically defined ones in the MIDI library (omni off, for
  ;; example). We may want to separate these, but I see no reason to
  ;; yet. We may also want to consider having more types made explicit
  ;; in the library, but again, there's no obvious functionality gain.
  (controller-maker midi::control-change-message 'control-change-moment 
                    :value (slot-value event 'midi::value)
                    :control (slot-value event 'midi::controller))
  (controller-maker midi::mode-message 'control-change-moment
                    :value (control-value event)
                    :control (control-number event))
  ;; I think that MIDI.LISP treats sysexs as two very distinct
;; things. I'm not sure that's true, so I'm treating them as the same
  ;; thing for now.
  (controller-maker midi::system-exclusive-message 'system-exclusive-moment
                    :status 240 :value (slot-value event 'midi::data))
  (controller-maker midi::authorization-system-exclusive-message 'system-exclusive-moment
                    :status 247 :value (slot-value event 'midi::data))
  (controller-maker midi::polyphonic-key-pressure-message 'aftertouch-moment
                    :key (slot-value event 'midi::key)
                    :pressure (slot-value event 'midi::pressure))
  (controller-maker midi::channel-pressure-message 'channel-aftertouch-moment
                    :pressure (slot-value event 'midi::pressure))
  ;; This is a period, but we add duration later anyway
  (controller-maker midi:pitch-bend-message 'pitch-bend-period :value (midi::message-value event))
  ;; Text messages
  (controller-maker midi::lyric-message 'lyric-moment :text (slot-value event 'midi::text))
  (controller-maker midi::general-text-message 'text-moment :text (slot-value event 'midi::text))
  (controller-maker midi::copyright-message 'copyright-moment :text (slot-value event 'midi::text))
  (controller-maker midi::sequence/track-name-message 'sequence-or-track-moment :text (slot-value event 'midi::text))
  (controller-maker midi::instrument-message 'instrument-name-moment :text (slot-value event 'midi::text))
  (controller-maker midi::marker-message 'marker-moment :text (slot-value event 'midi::text))
  (controller-maker midi::cue-point-message 'cue-moment :text (slot-value event 'midi::text))
  (controller-maker midi::program-name-message 'program-name-moment :text (slot-value event 'midi::text))
  (controller-maker midi::device-name-message 'device-name-moment :text (slot-value event 'midi::text))

  ;; Not used:
  (controller-maker midi::program-change-message 'program-change-moment
                    :program (midi::message-program event)))