view implementations/midi/midifile-import.lisp @ 220:de60993404c1

Move midifile-identifier class definition into classes.lisp

Ignore-this: 735724c00ddb97fc6b2d90398fae5b6d

darcs-hash:20090728190704-16a00-9787f577e9444e9a15e48a0f80098f28607c3c67.gz

committer: Jamie Forth <[e-mail]>

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

(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))
				    identifier))

(defun %initialise-midifile-composition (midifile identifier)
  ;; 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)
                   (progn 
                     (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) 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))
		   (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 'standard-time-signature-period
				  :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-period
				  :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 'standard-tempo-period
				  :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-standard-time-signature-period
								  4 4 0 (/ last-time division))))
				      :tempi (sort tempi #'time<)
				      :key-signatures (sort key-sigs #'time<)
				      :identifier identifier
				      :midi-timebase division)))
      (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-midi-percussive-event (midi:message-key note-on)
				 (midi:message-velocity note-on)
				 patch
				 (1+ (midi:message-channel note-on))
				 track
				 (/ (midi:message-time note-on) divisions)
				 (/ (- cut-off (midi:message-time note-on))
				    divisions)))
    (t
     ;; pitched
     (make-midi-pitched-event (midi:message-key note-on)
			      (midi:message-velocity note-on)
			      patch
			      (1+ (midi:message-channel note-on))
			      track
			      (/ (midi:message-time note-on) divisions)
			      (/ (- cut-off (midi:message-time note-on))
				 divisions)))))