play.lisp

   1 (in-package :gsharp-play)
   2
   3 (defparameter *midi-temp-file* "/tmp/timidity.mid")
   4 (defparameter *midi-player* "timidity")
   5 (defparameter *midi-player-arguments* '())
   6
   7 (defvar *tuning*)
   8 (defvar *tempo*)
   9
  10 (defun midi-pitch (note)
  11   (round (+ (+ 6900 ; a above middle c, 440 Hz
  12                (* 1200 (log (/ (master-pitch-freq *tuning*) 440) 2)))
  13             (- (note-cents note *tuning*)
  14                (note-cents (master-pitch-note *tuning*) *tuning*)))
  15          100))
  16
  17 (defun cents-adjustment (note)
  18   (nth-value 1 (midi-pitch note)))
  19
  20 (defun measure-durations (slices)
  21   (let ((durations (mapcar (lambda (slice)
  22                              (mapcar #'duration
  23                                      (bars slice)))
  24                            slices)))
  25     (loop while durations
  26        collect (reduce #'max durations :key #'car)
  27        do (setf durations (remove nil (mapcar #'cdr durations))))))
  28
  29 (defun average (list &key (key #'identity))
  30   (let ((sum 0)
  31         (count 0))
  32     (dolist (elem list)
  33       (incf count)
  34       (incf sum (funcall key elem)))
  35     (/ sum count)))
  36
  37 (defun events-from-element (element time channel)
  38   (when (typep element 'cluster)
  39     (append (list
  40              (make-instance 'pitch-bend-message
  41                             :time time
  42                             :status (+ #xE0 channel)
  43                             :value (+ 8192 ;; middle of pitch-bend controller
  44                                       (round
  45                                        (* 4096/100 ;; 4096 points per 100 cents
  46                                           ;; midi can only do per-channel pitch bend,
  47                                           ;; not per-note pitch bend, so as a sad
  48                                           ;; compromise we average the pitch bends
  49                                           ;; of all notes in the cluster
  50                                           (average (notes element)
  51                                            :key #'cents-adjustment))))))
  52             (mapcar (lambda (note)
  53                       (make-instance 'note-on-message
  54                                      :time time
  55                                      :status (+ #x90 channel)
  56                                      :key (midi-pitch note) :velocity 100))
  57                     (remove-if #'tie-left (notes element)))
  58             (mapcar (lambda (note)
  59                       (make-instance 'note-off-message
  60                                      :time (+ time (* *tempo* (duration element)))
  61                                      :status (+ #x80 channel)
  62                                      :key (midi-pitch note) :velocity 100))
  63                     (remove-if #'tie-right (notes element))))))
  64
  65 (defun events-from-bar (bar time channel)
  66   (mapcan (lambda (element)
  67             (prog1 (events-from-element element time channel)
  68               (incf time (* *tempo* (duration element)))))
  69           (elements bar)))
  70
  71 (defun track-from-slice (slice channel durations &key (start-time 0))
  72         (let ((time start-time))
  73     (cons (make-instance 'program-change-message
  74                          :time time :status  (+ #xc0 channel) :program 0)
  75           (mapcan (lambda (bar duration)
  76                     (prog1 (events-from-bar bar time channel)
  77                       (incf time (* *tempo* duration))))
  78                   (bars slice) durations))))
  79
  80 (define-condition midi-player-failed (gsharp-condition)
  81   ((midi-player :initarg :midi-player)
  82    (exit-code :initarg :exit-code))
  83   (:report
  84    (lambda (condition stream)
  85      (with-slots (midi-player exit-code) condition
  86      (format stream
  87              "Midi player ~S returned exit code ~S, indicating that an error occurred."
  88              midi-player exit-code)))))
  89
  90 (defun play-tracks (tracks)
  91   (let ((midifile (make-instance 'midifile
  92                      :format 1
  93                      :division 25
  94                      :tracks tracks)))
  95     (write-midi-file midifile *midi-temp-file*)
  96     #+cmu
  97     (ext:run-program *midi-player*
  98                      (append *midi-player-arguments*
  99                              (list *midi-temp-file*)))
 100     #+sbcl
 101     (let ((process
 102            (sb-ext:run-program *midi-player*
 103                                (append *midi-player-arguments*
 104                                        (list *midi-temp-file*))
 105                                :search t)))
 106       (sb-ext:process-wait process)
 107       (when (not (zerop (sb-ext:process-exit-code process)))
 108         (error 'midi-player-failed
 109                :midi-player *midi-player*
 110                :exit-code (sb-ext:process-exit-code process))))
 111     #+clisp
 112     (ext:run-program *midi-player*
 113                      :arguments (append *midi-player-arguments*
 114                                         (list *midi-temp-file*)))
 115     #-(or cmu sbcl clisp)
 116     (error "write compatibility layer for RUN-PROGRAM")))
 117
 118 (defun play-layer (layer)
 119   (let* ((slice (body layer))
 120          (durations (measure-durations (list slice)))
 121          (*tempo* (tempo (segment layer)))
 122          (*tuning* (gsharp-buffer:tuning (segment layer)))
 123          (tracks (list (track-from-slice slice 0 durations))))
 124     (play-tracks tracks)))
 125
 126 (defun segment-tracks (segment &key (start-time 0))
 127   (let* ((slices (mapcar #'body (layers segment)))
 128          (durations (measure-durations slices))
 129          (*tempo* (tempo segment))
 130          (*tuning* (gsharp-buffer:tuning segment)))
 131     (values (loop
 132                for slice in slices
 133                for i from 0
 134                collect (track-from-slice slice i durations :start-time start-time))
 135             (reduce #'+ durations))))
 136
 137 (defun play-segment (segment)
 138   (play-tracks (segment-tracks segment)))
 139
 140 ; TODO: There is a short pause between segments?
 141 (defun play-buffer (buffer)
 142   (let* ((time 0)
 143          (num-tracks (loop :for segment :in (segments buffer)
 144                            :maximize (length (layers segment))))
 145          (tracks (loop :for i :from 0 :below num-tracks :collect nil)))
 146
 147     ; Collect snippets from each segment that should go to different tracks
 148     (dolist (segment (segments buffer))
 149       (let ((*tempo* (tempo segment))
 150             (*tuning* (tuning segment)))
 151         (multiple-value-bind (track-addendums segment-duration)
 152             (segment-tracks segment :start-time time)
 153           (format t "~S" segment-duration)
 154
 155           (incf time segment-duration)
 156
 157           (loop :for track-addendum :in track-addendums
 158                 :for tracks-tail :on tracks
 159                 :do (push track-addendum (car tracks-tail))))))
 160
 161     ; Concatenate each track's snippets
 162     (loop :for tracks-tail :on tracks
 163        :do (setf (car tracks-tail)
 164                  (reduce (lambda (result snippet)
 165                            (nconc snippet result))
 166                          (car tracks-tail)
 167                          :from-end t)))
 168
 169     (play-tracks tracks)))
 170
 171