Mercurial > hg > amuse
changeset 35:1d757c33e00e
Changes for midi file import
darcs-hash:20070502153016-f76cc-89b748c36180ccaca77d2a70a65a6e7f77df8d43.gz
| author | David Lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Wed, 02 May 2007 16:30:16 +0100 |
| parents | 81b4228e26f5 |
| children | ad321ce17e3e |
| files | amuse.asd base/classes.lisp base/package.lisp implementations/midi/midifile-import.lisp utils/midi-output.lisp |
| diffstat | 5 files changed, 145 insertions(+), 2 deletions(-) [+] |
line wrap: on
line diff
--- a/amuse.asd Wed Apr 18 14:50:09 2007 +0100 +++ b/amuse.asd Wed May 02 16:30:16 2007 +0100 @@ -32,5 +32,7 @@ ((:file "package") (:file "classes" :depends-on ("package")) (:file "constructors" :depends-on ("package" "classes")) - (:file "methods" :depends-on ("package" "classes")))))))) + (:file "methods" :depends-on ("package" "classes")) + (:file "midifile-import" + :depends-on ("package" "classes" "constructors" "methods"))))))))
--- a/base/classes.lisp Wed Apr 18 14:50:09 2007 +0100 +++ b/base/classes.lisp Wed May 02 16:30:16 2007 +0100 @@ -12,6 +12,7 @@ ;; types of information-specifiers +(defclass identifier () ()) ;; for composition specification (defclass moment-designator () ()) (defclass period-designator () ()) (defclass anchored-period-designator (moment-designator period-designator) ())
--- a/base/package.lisp Wed Apr 18 14:50:09 2007 +0100 +++ b/base/package.lisp Wed May 02 16:30:16 2007 +0100 @@ -3,6 +3,7 @@ (:export #:constituent #:composition #:monody + #:identifier #:moment-designator #:period-designator #:anchored-period-designator
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/implementations/midi/midifile-import.lisp Wed May 02 16:30:16 2007 +0100 @@ -0,0 +1,139 @@ +(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))))) \ No newline at end of file
--- a/utils/midi-output.lisp Wed Apr 18 14:50:09 2007 +0100 +++ b/utils/midi-output.lisp Wed May 02 16:30:16 2007 +0100 @@ -61,7 +61,7 @@ (midi:message-time y)) (and (= (midi:message-time x) (midi:message-time y)) - (> (midi::message-status x) + (< (midi::message-status x) (midi::message-status y))))))) (defun event-sequence-messages (sequence)