comparison implementations/midi/midifile-import.lisp @ 35:1d757c33e00e

Changes for midi file import

darcs-hash:20070502153016-f76cc-89b748c36180ccaca77d2a70a65a6e7f77df8d43.gz

+(cl:in-package #:amuse-midi) 
+
+(defclass midifile-identifier (identifier)
+  ((pathname :initarg :path
+	     :reader midifile-identifier-pathname
+	     :initform 'nil)))
+
+(defun midifile-id (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) (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 '(17 128) :initial-element nil))
+	    (offs) 
+	    (patches (make-array 17 :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 (1+ (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 (1+ (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 (midi:message-denominator event))
+		   time-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 (1+ (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)))))
+    ;; make a midi object from notes, etc.
+    (let ((composition (make-instance 'midi-composition
+				      :time 0
+				      :interval (/ last-time division)
+				      :time-signatures (sort time-sigs #'time<)
+				      :tempi (sort tempi #'time<))))
+      (sequence:adjust-sequence composition
+				(length notes)
+				:initial-contents (sort notes #'time<)))))
+
+(defparameter *short* nil)
+
+(defun make-event-from-on-off-pair (note-on cut-off divisions track patch)
+  (when (< (/ (- cut-off (midi:message-time note-on)) divisions) 1/8)
+    (push (cons note-on cut-off) *short*))
+  (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)))))