Coverage report: /home/ellis/comp/core/lib/dat/midi.lisp

KindCoveredAll%
expression391007 3.9
branch288 2.3
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; dat/midi.lisp --- MIDI data
2
 
3
 ;;;  (c) copyright 2003 by Mathieu Chabanne, Camille Constant,
4
 ;;;                        Emmanuel Necibar and Stephanie Recco
5
 ;;;
6
 ;;;  (c) copyright 2003 by Robert Strandh (strandh@labri.fr)
7
 ;;;
8
 ;;;  (c) copyright 2007 by David Lewis, Marcus Pearce, Christophe
9
 ;;;                        Rhodes and contributors
10
 ;;;
11
 ;;; This library is free software; you can redistribute it and/or
12
 ;;; modify it under the terms of version 2 of the GNU Lesser General
13
 ;;; Public License as published by the Free Software Foundation.
14
 ;;;
15
 ;;; This library is distributed in the hope that it will be useful,
16
 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18
 ;;; Lesser General Public License for more details.
19
 ;;;
20
 ;;; You should have received a copy of the GNU Lesser General Public
21
 ;;; License along with this library; if not, write to the
22
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23
 ;;; Boston, MA  02111-1307  USA.
24
 ;;;
25
 ;;; This file contains library for MIDI and Midifiles. Messages are
26
 ;;; represented as CLOS class instances in a class hierarchy that
27
 ;;; reflects interesting aspects of the messages themselves.
28
 (in-package :dat/midi)
29
 
30
 ;;; Midifile protocol
31
 (defgeneric midifile-format (midifile))
32
 (defgeneric (setf midifile-format) (format midifile))
33
 (defgeneric midifile-division (midifile))
34
 (defgeneric midifile-tracks (midifile))
35
 
36
 ;;; Message protocol
37
 (defgeneric message-time (message))
38
 (defgeneric (setf message-time) (time message))
39
 (defgeneric message-status (message))
40
 (defgeneric message-channel (message))
41
 (defgeneric message-key (message))
42
 (defgeneric message-velocity (message))
43
 (defgeneric message-tempo (message))
44
 (defgeneric message-numerator (message))
45
 (defgeneric message-denominator (message))
46
 (defgeneric message-sf (message))
47
 (defgeneric message-mi (message))
48
 ;; added 03-05-07
49
 (defgeneric message-program (message))
50
 
51
 ;;; File support
52
 (eval-when (:compile-toplevel :load-toplevel)
53
   (defun string-code (s)
54
     "compute the ASCII-based numerical value of the string [warning:
55
 works only if the chars are coded in ASCII]"
56
     (let ((v 0))
57
       (loop for i from 0 to (1- (length s))
58
             do (setf v (+ (* v 256) (char-code (aref s i)))))
59
       v)))
60
 
61
 (defconstant +header-mthd+ #.(string-code "MThd"))
62
 (defconstant +header-mtrk+ #.(string-code "MTrk"))
63
 (defconstant +header-mthd-length+ 6 "value of the header MThd data's length")
64
 
65
 (defparameter *midi-input* nil "stream for reading a Midifile")
66
 (defparameter *input-buffer* '() "used for unreading bytes from *midi-input")
67
 (defparameter *midi-output* nil "stream for writing a Midifile")
68
 
69
 (define-condition unknown-event ()
70
   ((status :initarg :status :reader error-status)
71
    (data-byte :initform "" :initarg :data-byte :reader data-byte))
72
   (:documentation "condition when the event does not exist in the library"))
73
 
74
 (define-condition header ()
75
   ((header-type :initarg :header :reader header-type))
76
   (:documentation "condition when the header is not correct"))
77
 
78
 (defun read-next-byte ()
79
   "read an unsigned 8-bit byte from *midi-input* checking for unread bytes"
80
   (if *input-buffer*
81
       (pop *input-buffer*)
82
       (read-byte *midi-input*)))
83
 
84
 (defun unread-byte (byte)
85
   "unread a byte from *midi-input*"
86
   (push byte *input-buffer*))
87
 
88
 (defun write-bytes (&rest bytes)
89
   "write an arbitrary number of bytes to *midi-output*"
90
   (mapc #'(lambda (byte) (write-byte byte *midi-output*)) bytes))
91
 
92
 (defun read-fixed-length-quantity (nb-bytes)
93
   "read an unsigned integer of nb-bytes bytes from *midi-input*"
94
   (loop with result = 0
95
         for i from 1 to nb-bytes
96
         do (setf result (logior (ash result 8) (read-next-byte)))
97
         finally (return result)))
98
 
99
 (defun write-fixed-length-quantity (quantity nb-bytes)
100
   "write an unsigned integer of nb-bytes bytes to *midi-output*"
101
   (unless (zerop nb-bytes)
102
     (write-fixed-length-quantity (ash quantity -8) (1- nb-bytes))
103
     (write-bytes (logand quantity #xff))))
104
 
105
 (defmacro with-midi-input ((pathname &rest open-args &key &allow-other-keys) &body body)
106
   "execute body with *midi-input* assigned to a stream from pathname"
107
   `(with-open-file (*midi-input* ,pathname
108
                                  :direction :input :element-type '(unsigned-byte 8)
109
                                  ,@open-args)
110
      ,@body))
111
 
112
 (defmacro with-midi-output ((pathname &rest open-args &key &allow-other-keys) &body body)
113
   "execute body with *midi-output* assigned to a stream from pathname"
114
   `(with-open-file (*midi-output* ,pathname
115
                                   :direction :output :element-type '(unsigned-byte 8)
116
                                   ,@open-args)
117
      ,@body))
118
 
119
 (defun read-variable-length-quantity ()
120
   "read a MIDI variable length quantity from *midi-input*"
121
   (loop with result = 0
122
         with byte
123
         do (setf byte (read-next-byte)
124
                  result (logior (ash result 7) (logand byte #x7f)))
125
         until (< byte #x80)
126
         finally (return result)))
127
 
128
 (defun write-variable-length-quantity (quantity &optional (termination 0))
129
   (when (> quantity 127)
130
     (write-variable-length-quantity (ash quantity -7) #x80))
131
   (write-bytes (logior (logand quantity #x7f) termination)))
132
 
133
 (defun length-of-variables-length-quantity (quantity)
134
   (1+ (if (< quantity 128)
135
           0
136
           (length-of-variables-length-quantity (ash quantity -7)))))
137
 
138
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
139
 ;;;
140
 ;;; MIDI file representation
141
 
142
 (defclass midifile ()
143
   ((format :initarg :format :reader midifile-format)
144
    (division :initarg :division :reader midifile-division)
145
    (tracks :initarg :tracks :reader midifile-tracks))
146
   (:documentation "the class that represents a Midifile in core"))
147
 
148
 (defparameter *status* nil "the status while reading an event")
149
 (defparameter *running-status* nil "the running status while reading an event")
150
 (defparameter *dispatch-table* (make-array 256 :initial-element nil)
151
   "given values of status (and perhaps data1), find a class to create")
152
 
153
 (defun read-message ()
154
   "read a message without time indication from *midi-input*"
155
   (let ((classname-or-subtype (aref *dispatch-table* *status*)))
156
     (unless classname-or-subtype
157
       (error (make-condition 'unknown-event
158
                              :status *status*)))
159
     (if (symbolp classname-or-subtype)
160
         (make-instance classname-or-subtype)
161
         (let* ((data-byte (read-next-byte))
162
                (classname (aref classname-or-subtype data-byte)))
163
           (unless classname
164
             (error (make-condition 'unknown-event
165
                                    :status *status*
166
                                    :data-byte data-byte)))
167
           (unread-byte data-byte)
168
           (make-instance classname)))))
169
 
170
 (defparameter *time* 0 "accumulated time from the start of the track")
171
 
172
 (defun read-timed-message ()
173
   "read a message preceded with a delta-time indication"
174
   (let ((delta-time (read-variable-length-quantity))
175
         (status-or-data (read-next-byte)))
176
     (if (>= status-or-data #x80)
177
         (progn (setf *status* status-or-data)
178
                (when (<= *status* #xef)
179
                  (setf *running-status* *status*)))
180
         (progn (unread-byte status-or-data)
181
                (setf *status* *running-status*)))
182
     (let ((message (read-message)))
183
       (fill-message message)
184
       (setf (message-time message) (incf *time* delta-time))
185
       message)))
186
 
187
 (defun write-timed-message (message)
188
   "write a message preceded with a delta-time indication"
189
   (write-variable-length-quantity (- (message-time message) *time*))
190
   (setf *time* (message-time message))
191
   (write-message message))
192
 
193
 (defun read-track ()
194
   "read a track as a list of timed messages, excluding the end-of-track message"
195
   (let ((type (read-fixed-length-quantity 4))
196
         (length (read-fixed-length-quantity 4)))
197
     (declare (ignore length))
198
     (unless (= type +header-mtrk+)
199
       (error (make-condition 'header :header "MTrk")))
200
     (loop with message = nil
201
           do (setf message (read-timed-message))
202
           until (typep message 'end-of-track-message)
203
           collect message)))
204
 
205
 (defun write-track (track)
206
   "write a track (which does not contain the end-of-track message"
207
   (write-fixed-length-quantity  +header-mtrk+ 4)
208
   (let ((end-of-track-message (make-instance 'end-of-track-message)))
209
     ;; write the length of the track
210
     (write-fixed-length-quantity
211
      (+ (reduce #'+ track :key #'length-message)
212
         (length-message end-of-track-message)
213
         (loop with time = *time*
214
               for message in track
215
               sum (prog1 (length-of-variables-length-quantity
216
                           (- (message-time message) time))
217
                     (setf time (message-time message))))
218
         1) ; the delta time of the end-of-track message
219
      4)
220
     (dolist (message track)
221
       (write-timed-message message))
222
     (setf (message-time end-of-track-message) *time*)
223
     (write-timed-message end-of-track-message)))
224
 
225
 (defun read-midi-file (filename)
226
   "read an entire Midifile from the file with name given as argument"
227
   (setf *time* 0)
228
   (with-midi-input (filename)
229
     (let ((type (read-fixed-length-quantity 4))
230
           (length (read-fixed-length-quantity 4))
231
           (format (read-fixed-length-quantity 2))
232
           (nb-tracks (read-fixed-length-quantity 2))
233
           (division (read-fixed-length-quantity 2)))
234
       (unless (and (= length +header-mthd-length+) (= type +header-mthd+))
235
         (error (make-condition 'header :header "MThd")))
236
       (make-instance 'midifile
237
         :format format
238
         :division division
239
         :tracks (loop repeat nb-tracks
240
                       do (when (= format 1) (setf *time* 0))
241
                       collect (read-track))))))
242
 
243
 (defun write-midi-file (midifile filename)
244
   (with-midi-output (filename :if-exists :supersede)
245
     (write-fixed-length-quantity +header-mthd+ 4)
246
     (write-fixed-length-quantity +header-mthd-length+ 4)
247
     (with-slots (format division tracks) midifile
248
       (write-fixed-length-quantity format 2)
249
       (write-fixed-length-quantity (length tracks) 2)
250
       (write-fixed-length-quantity division 2)
251
       (setf *time* 0)
252
       (loop for track in tracks do
253
         (write-track track)
254
         (when (= (slot-value midifile 'format) 1)
255
           (setf *time* 0))))))
256
 
257
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
258
 ;;;
259
 ;;; Conversion routines
260
 
261
 (defun format1-tracks-to-format0-tracks (tracks)
262
   (list (reduce (lambda (t1 t2) (merge 'list t1 t2 #'< :key #'message-time))
263
                 (copy-tree tracks))))
264
 
265
 (defun format0-tracks-to-format1-tracks (tracks)
266
   (assert (null (cdr tracks)))
267
   (let (tempo-map track)
268
     (dolist (message (car tracks) (list (nreverse tempo-map) (nreverse track)))
269
       (if (typep message 'tempo-map-message)
270
           (push message tempo-map)
271
           (push message track)))))
272
 
273
 (defun change-to-format-0 (midifile)
274
   (assert (= (midifile-format midifile) 1))
275
   (setf (slot-value midifile 'format) 0
276
         (slot-value midifile 'tracks) (format1-tracks-to-format0-tracks (midifile-tracks midifile))))
277
 
278
 (defun change-to-format-1 (midifile)
279
   (assert (= (midifile-format midifile) 0))
280
   (setf (slot-value midifile 'format) 1
281
         (slot-value midifile 'tracks) (format0-tracks-to-format1-tracks (midifile-tracks midifile))))
282
 
283
 (defmethod (setf midifile-format) (new-value midifile)
284
   (cond
285
     ((= (midifile-format midifile) new-value) new-value)
286
     ((and (= new-value 0) (= (midifile-format midifile) 1))
287
      (change-to-format-0 midifile)
288
      new-value)
289
     ((and (= new-value 1) (= (midifile-format midifile) 0))
290
      (change-to-format-1 midifile)
291
      new-value)
292
     (t (error "Unsupported conversion from format ~S to format ~S"
293
               (midifile-format midifile) new-value))))
294
 
295
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
296
 ;;;
297
 ;;; Macro for defining midi messages
298
 
299
 (defparameter *status-min* (make-hash-table :test #'eq)
300
   "given a class name, find the minimum status value for the type of message")
301
 (defparameter *status-max* (make-hash-table :test #'eq)
302
   "given a class name, find the maximum status value for the type of message")
303
 (defparameter *data-min* (make-hash-table :test #'eq)
304
   "given a class name, find the minimum data1 value for the type of message")
305
 (defparameter *data-max* (make-hash-table :test #'eq)
306
   "given a class name, find the maximum data1 value for the type of message")
307
 
308
 (defun register-class (class superclass status-min status-max data-min data-max)
309
   (unless status-min
310
     (setf status-min (gethash superclass *status-min*)))
311
   (unless status-max
312
     (setf status-max (gethash superclass *status-max*)))
313
   (unless data-min
314
     (setf data-min (gethash superclass *data-min*)))
315
   (unless data-max
316
     (setf data-max (gethash superclass *data-max*)))
317
   ;; set status values for this class
318
   (setf (gethash class *status-min*) status-min)
319
   (setf (gethash class *status-max*) status-max)
320
   (setf (gethash class *data-min*) data-min)
321
   (setf (gethash class *data-max*) data-max)
322
   ;; update the dispatch table
323
   (when status-min
324
     (if data-min
325
         (progn (unless (arrayp (aref *dispatch-table* status-min))
326
                  (let ((secondary-dispatch (make-array 256
327
                                                        :initial-element nil)))
328
                    (loop for i from status-min to status-max do
329
                      (setf (aref *dispatch-table* i) secondary-dispatch))))
330
                (loop for i from data-min to data-max do
331
                  (setf (aref (aref *dispatch-table* status-min) i)
332
                        class)))
333
         (loop for i from status-min to status-max do
334
           (setf (aref *dispatch-table* i)
335
                 class)))))
336
 
337
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
338
 ;;;
339
 ;;; main filler, length, and writer methods
340
 
341
 (defgeneric fill-message (message))
342
 (defgeneric write-message (message))
343
 (defgeneric length-message (message)
344
   (:method-combination +))
345
 
346
 (defmethod fill-message (message)
347
   (declare (ignore message))
348
   nil)
349
 
350
 (defmethod length-message + (message)
351
   (declare (ignore message))
352
   0)
353
 
354
 (defmethod write-message (message)
355
   (declare (ignore message))
356
   nil)
357
 
358
 (defparameter *midi-channel* 0
359
   "Default MIDI channel for midi-messages for which status-min and status-max
360
 have a difference of 15.  When bound to an \(<= 0 integer 15\), the :status
361
 default value will automatically combine the message's status-min and
362
 *midi-channel*.")
363
 
364
 (defmacro define-midi-message (name superclasses
365
                                &key slots filler (length 0) writer
366
                                  status-min status-max data-min data-max)
367
   `(progn
368
 
369
      (register-class ',name ',(car superclasses)
370
                      ,status-min ,status-max ,data-min ,data-max)
371
 
372
      (defclass ,name ,superclasses
373
        ((status-min :initform ,status-min :allocation :class)
374
         (status-max :initform ,status-max :allocation :class)
375
         (data-min :initform ,data-min :allocation :class)
376
         (data-max :initform ,data-max :allocation :class)
377
         ,@slots)
378
        ,@(when (and (numberp status-min) (numberp status-max))
379
            (cond ((= status-min status-max)
380
                   `((:default-initargs :status ,status-min)))
381
                  ((= 15 (- status-max status-min))
382
                   `((:default-initargs :status (if (and (integerp *midi-channel*)
383
                                                         (<= 0 *midi-channel* 15))
384
                                                    (logior ,(logand status-min status-max)
385
                                                            *midi-channel*)
386
                                                    (error "*midi-channel*=~A not supported"
387
                                                           *midi-channel*))))))))
388
 
389
      (defmethod fill-message :after ((message ,name))
390
        (with-slots ,(mapcar #'car slots) message
391
          (symbol-macrolet ((next-byte (read-next-byte)))
392
            ,filler)))
393
 
394
      (defmethod length-message + ((message ,name))
395
        (with-slots (status-min status-max data-min data-max ,@(mapcar #'car slots))
396
            message
397
          ,length))
398
 
399
      (defmethod write-message :after ((message ,name))
400
        (with-slots (status-min status-max data-min data-max ,@(mapcar #'car slots))
401
            message
402
          ,writer))))
403
 
404
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
405
 ;;;
406
 ;;; midi messages
407
 
408
 (define-midi-message message ()
409
   :slots ((time :initarg :time :accessor message-time)
410
           (status :initarg :status :reader message-status :initform 0))
411
   :length 1
412
   :filler (setf status *status*)
413
   :writer (write-bytes status))
414
 
415
 (defgeneric print-midi-message (object stream)
416
   (:method ((object message) stream)
417
     (when (slot-boundp object 'time)
418
       (format stream " T=~A" (slot-value object 'time)))
419
     (when (slot-boundp object 'status)
420
       (format stream " S=~X" (slot-value object 'status))))
421
   (:documentation
422
    "One PRINT-OBJECT method is defined for the MIDI message class
423
 \(common ancestor\): that method prints the wrapping, then calls
424
 the PRINT-MIDI-MESSAGE method to print the slots."))
425
 
426
 (defmethod print-object ((obj message) stream)
427
   (print-unreadable-object (obj stream :type t :identity t)
428
     (print-midi-message obj stream))
429
   obj)
430
 
431
 (define-midi-message channel-message (message)
432
   :slots ((channel :reader message-channel))
433
   :filler (setf channel (logand *status* #x0f)))
434
 
435
 (defmethod print-midi-message ((object channel-message) stream)
436
   (call-next-method)
437
   (when (slot-boundp object 'channel)
438
     (format stream " C=~X" (slot-value object 'channel))))
439
 
440
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
441
 ;;;
442
 ;;; voice messages
443
 
444
 (define-midi-message voice-message (channel-message))
445
 
446
 (define-midi-message note-off-message (voice-message)
447
   :status-min #x80 :status-max #x8f
448
   :slots ((key :initarg :key :reader message-key)
449
           (velocity :initarg :velocity :reader message-velocity))
450
   :filler (setf key next-byte
451
                 velocity next-byte)
452
   :length 2
453
   :writer (write-bytes key velocity))
454
 
455
 (defmethod print-midi-message ((object note-off-message) stream)
456
   (call-next-method)
457
   (when (slot-boundp object 'key)
458
     (format stream " k=~A" (slot-value object 'key)))
459
   (when (slot-boundp object 'velocity)
460
     (format stream " v=~A" (slot-value object 'velocity))))
461
 
462
 (define-midi-message note-on-message (voice-message)
463
   :status-min #x90 :status-max #x9f
464
   :slots ((key :initarg :key :reader message-key)
465
           (velocity :initarg :velocity :reader message-velocity))
466
   :filler (setf key next-byte
467
                 velocity next-byte)
468
   :length 2
469
   :writer (write-bytes key velocity))
470
 
471
 (defmethod print-midi-message ((object note-on-message) stream)
472
   (call-next-method)
473
   (when (slot-boundp object 'key)
474
     (format stream " K=~A" (slot-value object 'key)))
475
   (when (slot-boundp object 'velocity)
476
     (format stream " V=~A" (slot-value object 'velocity))))
477
 
478
 (define-midi-message polyphonic-key-pressure-message (voice-message)
479
   :status-min #xa0 :status-max #xaf
480
   :slots ((key)
481
           (pressure))
482
   :filler (setf key next-byte
483
                 pressure next-byte)
484
   :length 2
485
   :writer (write-bytes key pressure))
486
 
487
 (define-midi-message control-change-message (voice-message)
488
   :status-min #xb0 :status-max #xbf
489
   :data-min #x00 :data-max #x78
490
   :slots ((controller :initarg :controller)
491
           (value :initarg value))
492
   :filler (setf controller next-byte
493
                 value next-byte)
494
   :length 2
495
   :writer (write-bytes controller value))
496
 
497
 (define-midi-message program-change-message (voice-message)
498
   :status-min #xc0 :status-max #xcf
499
   :slots ((program :initarg :program :reader message-program))
500
   :filler (setf program next-byte)
501
   :length 1
502
   :writer (write-bytes program))
503
 
504
 (defmethod print-midi-message ((object program-change-message) stream)
505
   (call-next-method)
506
   (when (slot-boundp object 'program)
507
     (format stream " P=~A" (slot-value object 'program))))
508
 
509
 (define-midi-message channel-pressure-message (voice-message)
510
   :status-min #xd0 :status-max #xdf
511
   :slots ((pressure))
512
   :filler (setf pressure next-byte)
513
   :length 1
514
   :writer (write-bytes pressure))
515
 
516
 (define-midi-message pitch-bend-message (voice-message)
517
   :status-min #xe0 :status-max #xef
518
   :slots ((value :initarg :value :reader message-value))
519
   :filler (setf value (logior next-byte (ash next-byte 7)))
520
   :length 2
521
   :writer (write-bytes (logand value #x7f) (logand (ash value -7) #x7f)))
522
 
523
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
524
 ;;;
525
 ;;; mode messages
526
 
527
 (define-midi-message mode-message (channel-message)
528
   :filler next-byte) ; consume data byte
529
 
530
 (define-midi-message reset-all-controllers-message (mode-message)
531
   :status-min #xb0 :status-max #xbf
532
   :data-min #x79 :data-max #x79
533
   :filler next-byte ; consume unused byte
534
   :length 2
535
   :writer (write-bytes #x79 0))
536
 
537
 (define-midi-message local-control-message (mode-message)
538
   :status-min #xb0 :status-max #xbf
539
   :data-min #x7a :data-max #x7a
540
   :slots ((mode))
541
   :filler (setf mode (if (= next-byte 0) :off :on))
542
   :length 2
543
   :writer (write-bytes #x7a (if (eq mode :off) 0 127)))
544
 
545
 (define-midi-message all-notes-off-message (mode-message)
546
   :status-min #xb0 :status-max #xbf
547
   :data-min #x7b :data-max #x7b
548
   :filler next-byte ; consume unused byte
549
   :length 2
550
   :writer (write-bytes #x7b 0))
551
 
552
 (define-midi-message omni-mode-off-message (mode-message)
553
   :status-min #xb0 :status-max #xbf
554
   :data-min #x7c :data-max #x7c
555
   :filler next-byte ; consume unused byte
556
   :length 2
557
   :writer (write-bytes #x7c 0))
558
 
559
 (define-midi-message omni-mode-on-message (mode-message)
560
   :status-min #xb0 :status-max #xbf
561
   :data-min #x7d :data-max #x7d
562
   :filler next-byte ; consume unused byte
563
   :length 2
564
   :writer (write-bytes #x7d 0))
565
 
566
 (define-midi-message mono-mode-on-message (mode-message)
567
   :status-min #xb0 :status-max #xbf
568
   :data-min #x7e :data-max #x7e
569
   :slots ((nb-channels))
570
   :filler (setf nb-channels next-byte)
571
   :length 2
572
   :writer (write-bytes #x7e nb-channels))
573
 
574
 (define-midi-message poly-mode-on-message (mode-message)
575
   :status-min #xb0 :status-max #xbf
576
   :data-min #x7f :data-max #x7f
577
   :filler next-byte ; consume unused byte
578
   :length 2
579
   :writer (write-bytes #x7f 0))
580
 
581
 (define-midi-message system-message (message))
582
 
583
 (define-midi-message tempo-map-message (message))
584
 
585
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
586
 ;;;
587
 ;;; system common messages
588
 
589
 (define-midi-message common-message (system-message))
590
 
591
 (define-midi-message timing-code-message (common-message)
592
   :status-min #xf1 :status-max #xf1
593
   :slots ((code))
594
   :filler (setf code next-byte)
595
   :length 1
596
   :writer (write-bytes code))
597
 
598
 (defmethod print-midi-message ((object timing-code-message) stream)
599
   (call-next-method)
600
   (when (slot-boundp object 'code)
601
     (format stream " code=~A" (slot-value object 'code))))
602
 
603
 (define-midi-message song-position-pointer-message (common-message)
604
   :status-min #xf2 :status-max #xf2
605
   :slots ((pointer))
606
   :filler (setf pointer (logior next-byte (ash next-byte 7)))
607
   :length 2
608
   :writer (write-bytes (logand pointer #x7f) (logand (ash pointer -7) #x7f)))
609
 
610
 (define-midi-message song-select-message (common-message)
611
   :status-min #xf3 :status-max #xf3
612
   :slots ((song))
613
   :filler (setf song next-byte)
614
   :length 1
615
   :writer (write-bytes song))
616
 
617
 (define-midi-message tune-request-message (common-message)
618
   :status-min #xf6 :status-max #xf6)
619
 
620
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
621
 ;;;
622
 ;;; system real-time messages
623
 
624
 (define-midi-message real-time-message (system-message))
625
 
626
 (define-midi-message timing-clock-message (real-time-message)
627
   :status-min #xf8 :status-max #xf8)
628
 
629
 (define-midi-message start-sequence-message (real-time-message)
630
   :status-min #xfa :status-max #xfa)
631
 
632
 (define-midi-message continue-sequence-message (real-time-message)
633
   :status-min #xfb :status-max #xfb)
634
 
635
 (define-midi-message stop-sequence-message (real-time-message)
636
   :status-min #xfc :status-max #xfc)
637
 
638
 (define-midi-message active-sensing-message (real-time-message)
639
   :status-min #xfe :status-max #xfe)
640
 
641
 ;; (define-midi-message tune-request-message (real-time-message)
642
 ;;  :status-min #xf6 :status-max #xf6)
643
 
644
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
645
 ;;;
646
 ;;; system exclusive messages
647
 
648
 (define-midi-message system-exclusive-message (system-message)
649
   :status-min #xf0 :status-max #xf0
650
   :slots ((data))
651
   :filler (loop with len = (read-variable-length-quantity)
652
                   initially (setf data (make-array
653
                                         len :element-type '(unsigned-byte 8)))
654
                 for i from 0 below len
655
                 do (setf (aref data i) next-byte))
656
   :length (+ (length-of-variables-length-quantity (length data))
657
              (length data))
658
   :writer (progn (write-variable-length-quantity (length data))
659
                  (loop for elem across data do (write-bytes elem))))
660
 
661
 (define-midi-message authorization-system-exclusive-message (system-message)
662
   :status-min #xf7 :status-max #xf7
663
   :slots ((data))
664
   :filler (loop with len = (read-variable-length-quantity)
665
                   initially (setf data (make-array
666
                                         len :element-type '(unsigned-byte 8)))
667
                 for i from 0 below len
668
                 do (setf (aref data i) next-byte))
669
   :length (+ (length-of-variables-length-quantity (length data))
670
              (length data))
671
   :writer (progn (write-variable-length-quantity (length data))
672
                  (loop for elem across data do (write-bytes elem))))
673
 
674
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
675
 ;;;
676
 ;;; meta messages
677
 
678
 (define-midi-message meta-message (message)
679
   :status-min #xff :status-max #xff
680
   :length 2 ; the first data byte and the length byte
681
   :filler next-byte ; the first data byte which gives the type of meta message
682
   :writer (write-bytes data-min))
683
 
684
 (define-midi-message sequence-number-message (meta-message tempo-map-message)
685
   :data-min #x00 :data-max #x00
686
   :slots ((sequence))
687
   :filler (let ((data2 next-byte))
688
             (setf sequence (if (zerop data2)
689
                                0
690
                                (logior (ash next-byte 8) next-byte))))
691
   :length (if (zerop sequence) 0 2)
692
   :writer (unless (zerop sequence)
693
             (write-bytes (ash sequence -8) (logand sequence #xf))))
694
 
695
 (define-midi-message text-message (meta-message)
696
   :slots ((text))
697
   :filler (setf text (loop with len = next-byte
698
                            with str = (make-string len)
699
                            for i from 0 below len
700
                            do (setf (aref str i)
701
                                     (code-char next-byte))
702
                            finally (return str)))
703
   :length (length text)
704
   :writer (progn (write-bytes (length text))
705
                  (loop for char across text do
706
                    (write-bytes (char-code char)))))
707
 
708
 (defmethod print-midi-message ((object text-message) stream)
709
   (call-next-method)
710
   (when (slot-boundp object 'text)
711
     (format stream " [~A]" (slot-value object 'text))))
712
 
713
 (define-midi-message general-text-message (text-message)
714
   :data-min #x01 :data-max #x01)
715
 
716
 (define-midi-message copyright-message (text-message)
717
   :data-min #x02 :data-max #x02)
718
 
719
 (define-midi-message sequence/track-name-message (text-message tempo-map-message)
720
   :data-min #x03 :data-max #x03)
721
 
722
 (define-midi-message instrument-message (text-message)
723
   :data-min #x04 :data-max #x04)
724
 
725
 (define-midi-message lyric-message (text-message)
726
   :data-min #x05 :data-max #x05)
727
 
728
 (define-midi-message marker-message (text-message tempo-map-message)
729
   :data-min #x06 :data-max #x06)
730
 
731
 (define-midi-message cue-point-message (text-message)
732
   :data-min #x07 :data-max #x07)
733
 
734
 (define-midi-message program-name-message (text-message)
735
   :data-min #x08 :data-max #x08)
736
 
737
 (define-midi-message device-name-message (text-message)
738
   :data-min #x09 :data-max #x09)
739
 
740
 (define-midi-message channel-prefix-message (meta-message)
741
   :data-min #x20 :data-max #x20
742
   :slots ((channel))
743
   :length 1
744
   :filler (progn next-byte (setf channel next-byte))
745
   :writer (write-bytes 1 channel))
746
 
747
 (define-midi-message midi-port-message (meta-message)
748
   :data-min #x21 :data-max #x21
749
   :slots ((port))
750
   :length 1
751
   :filler (progn next-byte (setf port next-byte))
752
   :writer (write-bytes 1 port))
753
 
754
 (define-midi-message end-of-track-message (meta-message)
755
   :data-min #x2f :data-max #x2f
756
   :slots ((status :initform #xff))
757
   :filler next-byte
758
   :length 0
759
   :writer (write-bytes 0))
760
 
761
 (define-midi-message tempo-message (meta-message tempo-map-message)
762
   :data-min #x51 :data-max #x51
763
   :slots ((tempo :initarg :tempo :reader message-tempo))
764
   :filler (progn next-byte (setf tempo (read-fixed-length-quantity 3)))
765
   :length 3
766
   :writer (progn (write-bytes 3) (write-fixed-length-quantity tempo 3)))
767
 
768
 (defmethod print-midi-message ((object tempo-message) stream)
769
   (call-next-method)
770
   (when (slot-boundp object 'tempo)
771
     (format stream " tempo=~A" (slot-value object 'tempo))))
772
 
773
 (define-midi-message smpte-offset-message (meta-message tempo-map-message)
774
   :data-min #x54 :data-max #x54
775
   :slots ((hr) (mn) (se) (fr) (ff))
776
   :filler (progn next-byte (setf hr next-byte mn next-byte se next-byte
777
                                  fr next-byte ff next-byte))
778
   :length 5
779
   :writer (write-bytes 5 hr mn se fr ff))
780
 
781
 (defmethod print-midi-message ((object smpte-offset-message) stream)
782
   (call-next-method)
783
   (when (or (slot-boundp object 'hr)
784
             (slot-boundp object 'mn)
785
             (slot-boundp object 'se)
786
             (slot-boundp object 'fr)
787
             (slot-boundp object 'ff))
788
     (format stream
789
             " hmsff=~A/~A/~A/~A/~A"
790
             (ignore-errors (slot-value object 'hr))
791
             (ignore-errors (slot-value object 'mn))
792
             (ignore-errors (slot-value object 'se))
793
             (ignore-errors (slot-value object 'fr))
794
             (ignore-errors (slot-value object 'ff)))))
795
 
796
 (define-midi-message time-signature-message (meta-message tempo-map-message)
797
   :data-min #x58 :data-max #x58
798
   :slots ((nn :reader message-numerator)
799
           (dd :reader message-denominator)
800
           (cc) (bb))
801
   :filler (progn next-byte (setf nn next-byte dd next-byte
802
                                  cc next-byte bb next-byte))
803
   :length 4
804
   :writer (write-bytes 4 nn dd cc bb))
805
 
806
 (defmethod print-midi-message ((object time-signature-message) stream)
807
   (call-next-method)
808
   (when (or (slot-boundp object 'nn)
809
             (slot-boundp object 'dd)
810
             (slot-boundp object 'cc)
811
             (slot-boundp object 'bb))
812
     (format stream
813
             " n/dcb=~A/~A/~A/~A"
814
             (ignore-errors (slot-value object 'nn))
815
             (ignore-errors (slot-value object 'dd))
816
             (ignore-errors (slot-value object 'cc))
817
             (ignore-errors (slot-value object 'bb)))))
818
 
819
 (define-midi-message key-signature-message (meta-message)
820
   :data-min #x59 :data-max #x59
821
   :slots ((sf :reader message-sf)
822
           (mi :reader message-mi))
823
   :filler (progn next-byte (setf sf (let ((temp-sf next-byte))
824
                                       (if (> temp-sf 127)
825
                                           (- temp-sf 256)
826
                                           temp-sf))
827
                                  mi next-byte))
828
   :length 2
829
   :writer (write-bytes 2 (if (< sf 0) (+ sf 256) sf) mi))
830
 
831
 (define-midi-message proprietary-event (meta-message)
832
   :data-min #x7f :data-max #x7f
833
   :slots ((data))
834
   :filler (setf data (loop with len = (read-variable-length-quantity)
835
                            with vec = (make-array
836
                                        len
837
                                        :element-type '(unsigned-byte 8))
838
                            for i from 0 below len
839
                            do (setf (aref vec i) next-byte)
840
                            finally (return vec)))
841
   :writer (map nil (lambda (byte) (write-bytes byte))
842
                data)) ; FIXME