annotate tools/midi-output.lisp @ 183:5b2d0e5a99f1

More tabcode, plus fixes for gsharp key-sigs and some new restart symbols in amuse

darcs-hash:20080721130227-40ec0-858017ddbc42513731d0119e704926768906dbc6.gz

;; 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-tools)

(defgeneric play (music)
  (:method (m) (play-midifile (make-midi m)))
  (:documentation "Plays using timidity, unless mac os is
  present, in which case open (=QuickTime) is used. CoreAudio
  code exists, but is awkward to maintain."))
(defmethod play ((music composition))
  (play-midifile (make-midi music)))

(defun write-midi (music pathname)
  "Exports music as midi file."
  (midi:write-midi-file (make-midi music) pathname))

(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 default-tempo-for-midi (anchored-period)
  (:method ((o standard-anchored-period))
    (make-standard-tempo-period *default-tempo* (timepoint o) (duration o))))
(defparameter *default-tempo* 80)

(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))
    (if tempi
	(dolist (tempo tempi)
	  (setf temp (tempo-message tempo))
	  (when temp
	    (push temp events)))
	(push (tempo-message (default-tempo-for-midi sequence))
	      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 standard-chromatic-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 standard-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))