annotate implementations/midi/midifile-import.lisp @ 134:5e362d998f29

More documentation

darcs-hash:20070828101524-f76cc-6add2c3c254befc3cf767ac69706865b7830bc6a.gz

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

(defclass midifile-identifier (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) (misses 0)
	(track-no -1) (last-time 0))
    (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)
	  (when (> (midi:message-time event) last-time)
	    (setf last-time (midi:message-time event)))
	  (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))
		   (t-off (midi:message-time event)))
	       (if (aref ons channel pitch)
		   (push (make-event-from-on-off-pair (aref ons channel pitch)
						      t-off
						      division
						      track-no
						      (aref patches channel))
			 notes)
		   ;; 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))
		   (t-off (midi:message-time 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)
						    t-off
						    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))
		     (- (/ (midi:message-time event)
			   division)
			(timepoint (car time-sigs)))))
	     (push (make-instance 'basic-time-signature
				  :time (/ (midi:message-time event)
					   division)
				  :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))
		     (- (/ (midi:message-time event)
			   division)
			(timepoint (car time-sigs)))))
	     (push (make-instance 'midi-key-signature
				  :time (/ (midi:message-time event)
					   division)
				  :sharp-count (midi:message-sf event)
				  :mode (midi:message-mi event))
		   key-sigs))
	    ((typep event 'midi:tempo-message)
	     (when tempi
	       (setf (duration (car tempi))
		     (- (/ (midi:message-time event)
			   division)
			(timepoint (car tempi)))))
	     (push (make-instance 'tempo
				  :time (/ (midi:message-time event)
					   division)
				  :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)))
	    (t (incf misses))))))
    (when tempi
      (setf (duration (car tempi)) (- (/ last-time division) (timepoint (car tempi)))))
    (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-instance 'basic-time-signature
										:time 0
										:interval (/ last-time division)
										:numerator 4
										:denominator 4)))
				      :tempi (sort tempi #'time<)
				      :key-signatures (sort key-sigs #'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)))))