diff utils/midi-output.lisp @ 33:d1010755f507

Large upload of local changes. Many additions, such as harmony and piece-level objects

darcs-hash:20070413100909-f76cc-a8aa8dfc07f438dc0c1a7c45cee7ace2ecc1e6a5.gz

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