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