d@64: ;; Make midifiles from basic amuse objects methods here can be d@64: ;; overridden for more specific types d@64: ;; d@64: d@64: ;; FIXME: Need to push some structures from geerdes to make this work. d@64: d@64: (in-package #:amuse-tools) d@64: d@64: (defgeneric play (music) d@134: (:method (m) (play-midifile (make-midi m))) d@134: (:documentation "Plays using timidity, unless mac os is d@134: present, in which case open (=QuickTime) is used. CoreAudio d@134: code exists, but is awkward to maintain.")) d@64: (defmethod play ((music composition)) d@64: (play-midifile (make-midi music))) d@64: d@134: (defun write-midi (music pathname) d@134: "Exports music as midi file." d@134: (midi:write-midi-file (make-midi music) pathname)) d@134: d@64: (defun play-midifile (midifile) d@64: ;; coremidi is easy as an alternative, but we'll probably want midi d@64: ;; file export anyway, so it makes some sense to focus our efforts d@64: ;; on this first. That said, is there a CoreAudio midi file player d@64: ;; routine? d@64: (midi:write-midi-file midifile "tmp.mid") j@188: #+darwin j@188: (sb-ext:run-program "open" '("tmp.mid") :search t) j@188: #+linux j@188: (sb-ext:run-program "xdg-open" '("tmp.mid") :search t)) d@64: d@64: (defgeneric make-midi (sequence)) d@64: (defmethod make-midi ((sequence sequence)) d@64: ;; Make a midifile object. Collects global midi messages (that d@64: ;; require a sequence) and event-based messages (that don't). d@64: ;; FIXME: Something about this strikes me as very stupid. Must d@64: ;; revisit d@64: ;; FIXME: Only making type 0. Is this a problem? d@64: (let* ((events (event-sequence-messages sequence)) d@64: (globals (global-messages sequence)) d@64: (patches (patch-messages sequence))) d@64: (make-midifile-from-messages (nconc events globals patches) d@64: :type 0))) d@64: d@64: (defun make-midifile-from-messages (events &key (type 0)) d@64: ;; FIXME: clearly broken if type 1 d@64: ;; First have to get rid of all fractional times and choose a d@64: ;; timebase d@64: (let* ((timebase (apply #'lcm (mapcar #'(lambda (x) d@64: (denominator d@64: (midi:message-time x))) d@64: events)))) d@64: (when (< timebase 4) d@64: (setf timebase (* 4 timebase))) d@64: (loop for e in events d@64: do (setf (midi:message-time e) (* timebase d@64: (midi:message-time e)))) d@64: (make-instance 'midi:midifile d@64: :format type d@64: :division timebase d@64: :tracks (list (sort-midi-messages-for-output events))))) d@64: d@64: (defun sort-midi-messages-for-output (messages) d@64: (sort messages #'(lambda (x y) (or (< (midi:message-time x) d@64: (midi:message-time y)) d@64: (and (= (midi:message-time x) d@64: (midi:message-time y)) d@64: (< (midi::message-status x) d@64: (midi::message-status y))))))) d@64: d@64: (defun event-sequence-messages (sequence) d@64: (let ((midinotes)) d@64: (sequence:dosequence (event sequence midinotes) d@64: (let ((messages (event-messages event))) d@64: (dolist (message messages) d@64: (push message midinotes)))))) d@64: d@64: (defun patch-messages (sequence) d@64: (let ((patches (make-array 16 :initial-element nil)) d@64: (patch-list) d@64: (channel 0) d@64: (patch 0)) d@64: (sequence:dosequence (event sequence patch-list) d@64: (setf channel (get-channel-for-midi event) d@64: patch (get-patch-for-midi event)) d@64: (when (or (not (aref patches channel)) d@64: (not (= (aref patches channel) d@64: patch))) d@64: (push (make-instance 'midi:program-change-message d@64: :program patch d@64: :time (timepoint event) d@64: :status (+ channel 192)) d@64: patch-list) d@64: (setf (aref patches channel) patch))))) j@189: j@189: (defparameter *default-tempo* 80) d@183: (defgeneric default-tempo-for-midi (anchored-period) d@183: (:method ((o standard-anchored-period)) d@183: (make-standard-tempo-period *default-tempo* (timepoint o) (duration o)))) d@64: d@64: (defgeneric global-messages (sequence) d@64: (:method (s) (declare (ignore s)) nil)) d@64: (defmethod global-messages ((sequence composition)) d@64: ;; FIXME: missing plenty of other messages d@64: ;; FIXME: messy d@64: (let ((tempi (tempi sequence)) d@64: (temp) d@64: (time-sigs (time-signatures sequence)) d@64: (events)) d@183: (if tempi d@183: (dolist (tempo tempi) d@183: (setf temp (tempo-message tempo)) d@183: (when temp d@183: (push temp events))) d@183: (push (tempo-message (default-tempo-for-midi sequence)) d@183: events)) d@64: (dolist (time-sig time-sigs events) d@64: (setf temp (time-sig-message time-sig)) d@64: (when temp d@64: (push temp events))))) d@64: d@64: (defgeneric tempo-message (tempo) d@64: (:method (tp) d@64: (progn d@64: (let ((speed (make-instance 'midi:tempo-message d@64: :time (timepoint tp) d@64: :status 255))) d@64: (setf (slot-value speed 'midi::tempo) (microseconds-per-crotchet tp)) d@64: speed)))) d@64: d@64: (defgeneric time-sig-message (time-sig) d@64: (:method (ts) (declare (ignore ts)) nil)) d@64: d@64: (defgeneric event-messages (event) d@64: (:method (e) (declare (ignore e)) nil)) d@136: (defmethod event-messages ((event standard-chromatic-pitched-event)) d@64: (list (make-instance 'midi:note-on-message d@64: :status (+ (get-channel-for-midi event) 144) d@64: :key (midi-pitch-number event) d@64: :velocity (get-velocity-for-midi event) d@64: :time (timepoint event)) d@64: (make-instance 'midi:note-off-message d@64: :status (+ (get-channel-for-midi event) 128) d@64: :key (midi-pitch-number event) d@64: :velocity (get-velocity-for-midi event) d@64: :time (timepoint (cut-off event))))) d@64: d@136: (defmethod event-messages ((event standard-percussive-event)) d@64: (list (make-instance 'midi:note-on-message d@64: :status 153 d@64: :key (get-pitch-for-midi event) d@64: :velocity (get-velocity-for-midi event) d@64: :time (timepoint event)) d@64: (make-instance 'midi:note-off-message d@64: :status 137 d@64: :key (get-pitch-for-midi event) d@64: :velocity (get-velocity-for-midi event) d@64: :time (timepoint (cut-off event))))) d@64: d@64: (defgeneric get-pitch-for-midi (event)) d@64: (defgeneric get-velocity-for-midi (event) d@64: (:method (e) (declare (ignore e)) 100)) d@64: (defgeneric get-patch-for-midi (event) d@64: (:method (e) (declare (ignore e)) 0)) d@64: (defgeneric get-channel-for-midi (event) d@64: (:method (e) (declare (ignore e)) 0))