Mercurial > core / lisp/lib/dat/midi.lisp
changeset 550: |
4d34907c69eb |
parent: |
4e6838e03f61
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Tue, 16 Jul 2024 21:52:09 -0400 |
permissions: |
-rw-r--r-- |
description: |
more work on tcompact/thrift, fixed type info in parquet-struct-objects |
1 ;;; dat/midi.lisp --- MIDI data 3 ;;; (c) copyright 2003 by Mathieu Chabanne, Camille Constant, 4 ;;; Emmanuel Necibar and Stephanie Recco 6 ;;; (c) copyright 2003 by Robert Strandh (strandh@labri.fr) 8 ;;; (c) copyright 2007 by David Lewis, Marcus Pearce, Christophe 9 ;;; Rhodes and contributors 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. 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. 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. 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) 30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 (defgeneric midifile-format (midifile)) 35 (defgeneric (setf midifile-format) (format midifile)) 36 (defgeneric midifile-division (midifile)) 37 (defgeneric midifile-tracks (midifile)) 39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 (defgeneric message-time (message)) 44 (defgeneric (setf message-time) (time message)) 45 (defgeneric message-status (message)) 46 (defgeneric message-channel (message)) 47 (defgeneric message-key (message)) 48 (defgeneric message-velocity (message)) 49 (defgeneric message-tempo (message)) 50 (defgeneric message-numerator (message)) 51 (defgeneric message-denominator (message)) 52 (defgeneric message-sf (message)) 53 (defgeneric message-mi (message)) 55 (defgeneric message-program (message)) 57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 (eval-when (:compile-toplevel :load-toplevel) 61 (defun string-code (s) 62 "compute the ASCII-based numerical value of the string [warning: 63 works only if the chars are coded in ASCII]" 65 (loop for i from 0 to (1- (length s)) 66 do (setf v (+ (* v 256) (char-code (aref s i))))) 69 (defconstant +header-mthd+ #.(string-code "MThd")) 70 (defconstant +header-mtrk+ #.(string-code "MTrk")) 71 (defconstant +header-mthd-length+ 6 "value of the header MThd data's length") 73 (defparameter *midi-input* nil "stream for reading a Midifile") 74 (defparameter *input-buffer* '() "used for unreading bytes from *midi-input") 75 (defparameter *midi-output* nil "stream for writing a Midifile") 77 (define-condition unknown-event () 78 ((status :initarg :status :reader status) 79 (data-byte :initform "" :initarg :data-byte :reader data-byte)) 80 (:documentation "condition when the event does not exist in the library")) 82 (define-condition header () 83 ((header-type :initarg :header :reader header-type)) 84 (:documentation "condition when the header is not correct")) 86 (defun read-next-byte () 87 "read an unsigned 8-bit byte from *midi-input* checking for unread bytes" 90 (read-byte *midi-input*))) 92 (defun unread-byte (byte) 93 "unread a byte from *midi-input*" 94 (push byte *input-buffer*)) 96 (defun write-bytes (&rest bytes) 97 "write an arbitrary number of bytes to *midi-output*" 98 (mapc #'(lambda (byte) (write-byte byte *midi-output*)) bytes)) 100 (defun read-fixed-length-quantity (nb-bytes) 101 "read an unsigned integer of nb-bytes bytes from *midi-input*" 102 (loop with result = 0 103 for i from 1 to nb-bytes 104 do (setf result (logior (ash result 8) (read-next-byte))) 105 finally (return result))) 107 (defun write-fixed-length-quantity (quantity nb-bytes) 108 "write an unsigned integer of nb-bytes bytes to *midi-output*" 109 (unless (zerop nb-bytes) 110 (write-fixed-length-quantity (ash quantity -8) (1- nb-bytes)) 111 (write-bytes (logand quantity #xff)))) 113 (defmacro with-midi-input ((pathname &rest open-args &key &allow-other-keys) &body body) 114 "execute body with *midi-input* assigned to a stream from pathname" 115 `(with-open-file (*midi-input* ,pathname 116 :direction :input :element-type '(unsigned-byte 8) 120 (defmacro with-midi-output ((pathname &rest open-args &key &allow-other-keys) &body body) 121 "execute body with *midi-output* assigned to a stream from pathname" 122 `(with-open-file (*midi-output* ,pathname 123 :direction :output :element-type '(unsigned-byte 8) 127 (defun read-variable-length-quantity () 128 "read a MIDI variable length quantity from *midi-input*" 129 (loop with result = 0 131 do (setf byte (read-next-byte) 132 result (logior (ash result 7) (logand byte #x7f))) 134 finally (return result))) 136 (defun write-variable-length-quantity (quantity &optional (termination 0)) 137 (when (> quantity 127) 138 (write-variable-length-quantity (ash quantity -7) #x80)) 139 (write-bytes (logior (logand quantity #x7f) termination))) 141 (defun length-of-variables-length-quantity (quantity) 142 (1+ (if (< quantity 128) 144 (length-of-variables-length-quantity (ash quantity -7))))) 146 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 148 ;;; MIDI file representation 150 (defclass midifile () 151 ((format :initarg :format :reader midifile-format) 152 (division :initarg :division :reader midifile-division) 153 (tracks :initarg :tracks :reader midifile-tracks)) 154 (:documentation "the class that represents a Midifile in core")) 156 (defparameter *status* nil "the status while reading an event") 157 (defparameter *running-status* nil "the running status while reading an event") 158 (defparameter *dispatch-table* (make-array 256 :initial-element nil) 159 "given values of status (and perhaps data1), find a class to create") 161 (defun read-message () 162 "read a message without time indication from *midi-input*" 163 (let ((classname-or-subtype (aref *dispatch-table* *status*))) 164 (unless classname-or-subtype 165 (error (make-condition 'unknown-event 167 (if (symbolp classname-or-subtype) 168 (make-instance classname-or-subtype) 169 (let* ((data-byte (read-next-byte)) 170 (classname (aref classname-or-subtype data-byte))) 172 (error (make-condition 'unknown-event 174 :data-byte data-byte))) 175 (unread-byte data-byte) 176 (make-instance classname))))) 178 (defparameter *time* 0 "accumulated time from the start of the track") 180 (defun read-timed-message () 181 "read a message preceded with a delta-time indication" 182 (let ((delta-time (read-variable-length-quantity)) 183 (status-or-data (read-next-byte))) 184 (if (>= status-or-data #x80) 185 (progn (setf *status* status-or-data) 186 (when (<= *status* #xef) 187 (setf *running-status* *status*))) 188 (progn (unread-byte status-or-data) 189 (setf *status* *running-status*))) 190 (let ((message (read-message))) 191 (fill-message message) 192 (setf (message-time message) (incf *time* delta-time)) 195 (defun write-timed-message (message) 196 "write a message preceded with a delta-time indication" 197 (write-variable-length-quantity (- (message-time message) *time*)) 198 (setf *time* (message-time message)) 199 (write-message message)) 202 "read a track as a list of timed messages, excluding the end-of-track message" 203 (let ((type (read-fixed-length-quantity 4)) 204 (length (read-fixed-length-quantity 4))) 205 (declare (ignore length)) 206 (unless (= type +header-mtrk+) 207 (error (make-condition 'header :header "MTrk"))) 208 (loop with message = nil 209 do (setf message (read-timed-message)) 210 until (typep message 'end-of-track-message) 213 (defun write-track (track) 214 "write a track (which does not contain the end-of-track message" 215 (write-fixed-length-quantity +header-mtrk+ 4) 216 (let ((end-of-track-message (make-instance 'end-of-track-message))) 217 ;; write the length of the track 218 (write-fixed-length-quantity 219 (+ (reduce #'+ track :key #'length-message) 220 (length-message end-of-track-message) 221 (loop with time = *time* 223 sum (prog1 (length-of-variables-length-quantity 224 (- (message-time message) time)) 225 (setf time (message-time message)))) 226 1) ; the delta time of the end-of-track message 228 (dolist (message track) 229 (write-timed-message message)) 230 (setf (message-time end-of-track-message) *time*) 231 (write-timed-message end-of-track-message))) 233 (defun read-midi-file (filename) 234 "read an entire Midifile from the file with name given as argument" 236 (with-midi-input (filename) 237 (let ((type (read-fixed-length-quantity 4)) 238 (length (read-fixed-length-quantity 4)) 239 (format (read-fixed-length-quantity 2)) 240 (nb-tracks (read-fixed-length-quantity 2)) 241 (division (read-fixed-length-quantity 2))) 242 (unless (and (= length +header-mthd-length+) (= type +header-mthd+)) 243 (error (make-condition 'header :header "MThd"))) 244 (make-instance 'midifile 247 :tracks (loop repeat nb-tracks 248 do (when (= format 1) (setf *time* 0)) 249 collect (read-track)))))) 251 (defun write-midi-file (midifile filename) 252 (with-midi-output (filename :if-exists :supersede) 253 (write-fixed-length-quantity +header-mthd+ 4) 254 (write-fixed-length-quantity +header-mthd-length+ 4) 255 (with-slots (format division tracks) midifile 256 (write-fixed-length-quantity format 2) 257 (write-fixed-length-quantity (length tracks) 2) 258 (write-fixed-length-quantity division 2) 260 (loop for track in tracks do 262 (when (= (slot-value midifile 'format) 1) 265 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 267 ;;; Conversion routines 269 (defun format1-tracks-to-format0-tracks (tracks) 270 (list (reduce (lambda (t1 t2) (merge 'list t1 t2 #'< :key #'message-time)) 271 (copy-tree tracks)))) 273 (defun format0-tracks-to-format1-tracks (tracks) 274 (assert (null (cdr tracks))) 275 (let (tempo-map track) 276 (dolist (message (car tracks) (list (nreverse tempo-map) (nreverse track))) 277 (if (typep message 'tempo-map-message) 278 (push message tempo-map) 279 (push message track))))) 281 (defun change-to-format-0 (midifile) 282 (assert (= (midifile-format midifile) 1)) 283 (setf (slot-value midifile 'format) 0 284 (slot-value midifile 'tracks) (format1-tracks-to-format0-tracks (midifile-tracks midifile)))) 286 (defun change-to-format-1 (midifile) 287 (assert (= (midifile-format midifile) 0)) 288 (setf (slot-value midifile 'format) 1 289 (slot-value midifile 'tracks) (format0-tracks-to-format1-tracks (midifile-tracks midifile)))) 291 (defmethod (setf midifile-format) (new-value midifile) 293 ((= (midifile-format midifile) new-value) new-value) 294 ((and (= new-value 0) (= (midifile-format midifile) 1)) 295 (change-to-format-0 midifile) 297 ((and (= new-value 1) (= (midifile-format midifile) 0)) 298 (change-to-format-1 midifile) 300 (t (error "Unsupported conversion from format ~S to format ~S" 301 (midifile-format midifile) new-value)))) 303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 305 ;;; Macro for defining midi messages 307 (defparameter *status-min* (make-hash-table :test #'eq) 308 "given a class name, find the minimum status value for the type of message") 309 (defparameter *status-max* (make-hash-table :test #'eq) 310 "given a class name, find the maximum status value for the type of message") 311 (defparameter *data-min* (make-hash-table :test #'eq) 312 "given a class name, find the minimum data1 value for the type of message") 313 (defparameter *data-max* (make-hash-table :test #'eq) 314 "given a class name, find the maximum data1 value for the type of message") 316 (defun register-class (class superclass status-min status-max data-min data-max) 318 (setf status-min (gethash superclass *status-min*))) 320 (setf status-max (gethash superclass *status-max*))) 322 (setf data-min (gethash superclass *data-min*))) 324 (setf data-max (gethash superclass *data-max*))) 325 ;; set status values for this class 326 (setf (gethash class *status-min*) status-min) 327 (setf (gethash class *status-max*) status-max) 328 (setf (gethash class *data-min*) data-min) 329 (setf (gethash class *data-max*) data-max) 330 ;; update the dispatch table 333 (progn (unless (arrayp (aref *dispatch-table* status-min)) 334 (let ((secondary-dispatch (make-array 256 335 :initial-element nil))) 336 (loop for i from status-min to status-max do 337 (setf (aref *dispatch-table* i) secondary-dispatch)))) 338 (loop for i from data-min to data-max do 339 (setf (aref (aref *dispatch-table* status-min) i) 341 (loop for i from status-min to status-max do 342 (setf (aref *dispatch-table* i) 345 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 347 ;;; main filler, length, and writer methods 349 (defgeneric fill-message (message)) 350 (defgeneric write-message (message)) 351 (defgeneric length-message (message) 352 (:method-combination +)) 354 (defmethod fill-message (message) 355 (declare (ignore message)) 358 (defmethod length-message + (message) 359 (declare (ignore message)) 362 (defmethod write-message (message) 363 (declare (ignore message)) 366 (defparameter *midi-channel* 0 367 "Default MIDI channel for midi-messages for which status-min and status-max 368 have a difference of 15. When bound to an \(<= 0 integer 15\), the :status 369 default value will automatically combine the message's status-min and 372 (defmacro define-midi-message (name superclasses 373 &key slots filler (length 0) writer 374 status-min status-max data-min data-max) 377 (register-class ',name ',(car superclasses) 378 ,status-min ,status-max ,data-min ,data-max) 380 (defclass ,name ,superclasses 381 ((status-min :initform ,status-min :allocation :class) 382 (status-max :initform ,status-max :allocation :class) 383 (data-min :initform ,data-min :allocation :class) 384 (data-max :initform ,data-max :allocation :class) 386 ,@(when (and (numberp status-min) (numberp status-max)) 387 (cond ((= status-min status-max) 388 `((:default-initargs :status ,status-min))) 389 ((= 15 (- status-max status-min)) 390 `((:default-initargs :status (if (and (integerp *midi-channel*) 391 (<= 0 *midi-channel* 15)) 392 (logior ,(logand status-min status-max) 394 (error "*midi-channel*=~A not supported" 395 *midi-channel*)))))))) 397 (defmethod fill-message :after ((message ,name)) 398 (with-slots ,(mapcar #'car slots) message 399 (symbol-macrolet ((next-byte (read-next-byte))) 402 (defmethod length-message + ((message ,name)) 403 (with-slots (status-min status-max data-min data-max ,@(mapcar #'car slots)) 407 (defmethod write-message :after ((message ,name)) 408 (with-slots (status-min status-max data-min data-max ,@(mapcar #'car slots)) 412 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 416 (define-midi-message message () 417 :slots ((time :initarg :time :accessor message-time) 418 (status :initarg :status :reader message-status :initform 0)) 420 :filler (setf status *status*) 421 :writer (write-bytes status)) 423 (defgeneric print-midi-message (object stream) 424 (:method ((object message) stream) 425 (when (slot-boundp object 'time) 426 (format stream " T=~A" (slot-value object 'time))) 427 (when (slot-boundp object 'status) 428 (format stream " S=~X" (slot-value object 'status)))) 430 "One PRINT-OBJECT method is defined for the MIDI message class 431 \(common ancestor\): that method prints the wrapping, then calls 432 the PRINT-MIDI-MESSAGE method to print the slots.")) 434 (defmethod print-object ((obj message) stream) 435 (print-unreadable-object (obj stream :type t :identity t) 436 (print-midi-message obj stream)) 439 (define-midi-message channel-message (message) 440 :slots ((channel :reader message-channel)) 441 :filler (setf channel (logand *status* #x0f))) 443 (defmethod print-midi-message ((object channel-message) stream) 445 (when (slot-boundp object 'channel) 446 (format stream " C=~X" (slot-value object 'channel)))) 448 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 452 (define-midi-message voice-message (channel-message)) 454 (define-midi-message note-off-message (voice-message) 455 :status-min #x80 :status-max #x8f 456 :slots ((key :initarg :key :reader message-key) 457 (velocity :initarg :velocity :reader message-velocity)) 458 :filler (setf key next-byte 461 :writer (write-bytes key velocity)) 463 (defmethod print-midi-message ((object note-off-message) stream) 465 (when (slot-boundp object 'key) 466 (format stream " k=~A" (slot-value object 'key))) 467 (when (slot-boundp object 'velocity) 468 (format stream " v=~A" (slot-value object 'velocity)))) 470 (define-midi-message note-on-message (voice-message) 471 :status-min #x90 :status-max #x9f 472 :slots ((key :initarg :key :reader message-key) 473 (velocity :initarg :velocity :reader message-velocity)) 474 :filler (setf key next-byte 477 :writer (write-bytes key velocity)) 479 (defmethod print-midi-message ((object note-on-message) stream) 481 (when (slot-boundp object 'key) 482 (format stream " K=~A" (slot-value object 'key))) 483 (when (slot-boundp object 'velocity) 484 (format stream " V=~A" (slot-value object 'velocity)))) 486 (define-midi-message polyphonic-key-pressure-message (voice-message) 487 :status-min #xa0 :status-max #xaf 490 :filler (setf key next-byte 493 :writer (write-bytes key pressure)) 495 (define-midi-message control-change-message (voice-message) 496 :status-min #xb0 :status-max #xbf 497 :data-min #x00 :data-max #x78 498 :slots ((controller :initarg :controller) 499 (value :initarg value)) 500 :filler (setf controller next-byte 503 :writer (write-bytes controller value)) 505 (define-midi-message program-change-message (voice-message) 506 :status-min #xc0 :status-max #xcf 507 :slots ((program :initarg :program :reader message-program)) 508 :filler (setf program next-byte) 510 :writer (write-bytes program)) 512 (defmethod print-midi-message ((object program-change-message) stream) 514 (when (slot-boundp object 'program) 515 (format stream " P=~A" (slot-value object 'program)))) 517 (define-midi-message channel-pressure-message (voice-message) 518 :status-min #xd0 :status-max #xdf 520 :filler (setf pressure next-byte) 522 :writer (write-bytes pressure)) 524 (define-midi-message pitch-bend-message (voice-message) 525 :status-min #xe0 :status-max #xef 526 :slots ((value :initarg :value :reader message-value)) 527 :filler (setf value (logior next-byte (ash next-byte 7))) 529 :writer (write-bytes (logand value #x7f) (logand (ash value -7) #x7f))) 531 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 535 (define-midi-message mode-message (channel-message) 536 :filler next-byte) ; consume data byte 538 (define-midi-message reset-all-controllers-message (mode-message) 539 :status-min #xb0 :status-max #xbf 540 :data-min #x79 :data-max #x79 541 :filler next-byte ; consume unused byte 543 :writer (write-bytes #x79 0)) 545 (define-midi-message local-control-message (mode-message) 546 :status-min #xb0 :status-max #xbf 547 :data-min #x7a :data-max #x7a 549 :filler (setf mode (if (= next-byte 0) :off :on)) 551 :writer (write-bytes #x7a (if (eq mode :off) 0 127))) 553 (define-midi-message all-notes-off-message (mode-message) 554 :status-min #xb0 :status-max #xbf 555 :data-min #x7b :data-max #x7b 556 :filler next-byte ; consume unused byte 558 :writer (write-bytes #x7b 0)) 560 (define-midi-message omni-mode-off-message (mode-message) 561 :status-min #xb0 :status-max #xbf 562 :data-min #x7c :data-max #x7c 563 :filler next-byte ; consume unused byte 565 :writer (write-bytes #x7c 0)) 567 (define-midi-message omni-mode-on-message (mode-message) 568 :status-min #xb0 :status-max #xbf 569 :data-min #x7d :data-max #x7d 570 :filler next-byte ; consume unused byte 572 :writer (write-bytes #x7d 0)) 574 (define-midi-message mono-mode-on-message (mode-message) 575 :status-min #xb0 :status-max #xbf 576 :data-min #x7e :data-max #x7e 577 :slots ((nb-channels)) 578 :filler (setf nb-channels next-byte) 580 :writer (write-bytes #x7e nb-channels)) 582 (define-midi-message poly-mode-on-message (mode-message) 583 :status-min #xb0 :status-max #xbf 584 :data-min #x7f :data-max #x7f 585 :filler next-byte ; consume unused byte 587 :writer (write-bytes #x7f 0)) 589 (define-midi-message system-message (message)) 591 (define-midi-message tempo-map-message (message)) 593 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 595 ;;; system common messages 597 (define-midi-message common-message (system-message)) 599 (define-midi-message timing-code-message (common-message) 600 :status-min #xf1 :status-max #xf1 602 :filler (setf code next-byte) 604 :writer (write-bytes code)) 606 (defmethod print-midi-message ((object timing-code-message) stream) 608 (when (slot-boundp object 'code) 609 (format stream " code=~A" (slot-value object 'code)))) 611 (define-midi-message song-position-pointer-message (common-message) 612 :status-min #xf2 :status-max #xf2 614 :filler (setf pointer (logior next-byte (ash next-byte 7))) 616 :writer (write-bytes (logand pointer #x7f) (logand (ash pointer -7) #x7f))) 618 (define-midi-message song-select-message (common-message) 619 :status-min #xf3 :status-max #xf3 621 :filler (setf song next-byte) 623 :writer (write-bytes song)) 625 (define-midi-message tune-request-message (common-message) 626 :status-min #xf6 :status-max #xf6) 628 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 630 ;;; system real-time messages 632 (define-midi-message real-time-message (system-message)) 634 (define-midi-message timing-clock-message (real-time-message) 635 :status-min #xf8 :status-max #xf8) 637 (define-midi-message start-sequence-message (real-time-message) 638 :status-min #xfa :status-max #xfa) 640 (define-midi-message continue-sequence-message (real-time-message) 641 :status-min #xfb :status-max #xfb) 643 (define-midi-message stop-sequence-message (real-time-message) 644 :status-min #xfc :status-max #xfc) 646 (define-midi-message active-sensing-message (real-time-message) 647 :status-min #xfe :status-max #xfe) 649 ;; (define-midi-message tune-request-message (real-time-message) 650 ;; :status-min #xf6 :status-max #xf6) 652 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 654 ;;; system exclusive messages 656 (define-midi-message system-exclusive-message (system-message) 657 :status-min #xf0 :status-max #xf0 659 :filler (loop with len = (read-variable-length-quantity) 660 initially (setf data (make-array 661 len :element-type '(unsigned-byte 8))) 662 for i from 0 below len 663 do (setf (aref data i) next-byte)) 664 :length (+ (length-of-variables-length-quantity (length data)) 666 :writer (progn (write-variable-length-quantity (length data)) 667 (loop for elem across data do (write-bytes elem)))) 669 (define-midi-message authorization-system-exclusive-message (system-message) 670 :status-min #xf7 :status-max #xf7 672 :filler (loop with len = (read-variable-length-quantity) 673 initially (setf data (make-array 674 len :element-type '(unsigned-byte 8))) 675 for i from 0 below len 676 do (setf (aref data i) next-byte)) 677 :length (+ (length-of-variables-length-quantity (length data)) 679 :writer (progn (write-variable-length-quantity (length data)) 680 (loop for elem across data do (write-bytes elem)))) 682 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 686 (define-midi-message meta-message (message) 687 :status-min #xff :status-max #xff 688 :length 2 ; the first data byte and the length byte 689 :filler next-byte ; the first data byte which gives the type of meta message 690 :writer (write-bytes data-min)) 692 (define-midi-message sequence-number-message (meta-message tempo-map-message) 693 :data-min #x00 :data-max #x00 695 :filler (let ((data2 next-byte)) 696 (setf sequence (if (zerop data2) 698 (logior (ash next-byte 8) next-byte)))) 699 :length (if (zerop sequence) 0 2) 700 :writer (unless (zerop sequence) 701 (write-bytes (ash sequence -8) (logand sequence #xf)))) 703 (define-midi-message text-message (meta-message) 705 :filler (setf text (loop with len = next-byte 706 with str = (make-string len) 707 for i from 0 below len 708 do (setf (aref str i) 709 (code-char next-byte)) 710 finally (return str))) 711 :length (length text) 712 :writer (progn (write-bytes (length text)) 713 (loop for char across text do 714 (write-bytes (char-code char))))) 716 (defmethod print-midi-message ((object text-message) stream) 718 (when (slot-boundp object 'text) 719 (format stream " [~A]" (slot-value object 'text)))) 721 (define-midi-message general-text-message (text-message) 722 :data-min #x01 :data-max #x01) 724 (define-midi-message copyright-message (text-message) 725 :data-min #x02 :data-max #x02) 727 (define-midi-message sequence/track-name-message (text-message tempo-map-message) 728 :data-min #x03 :data-max #x03) 730 (define-midi-message instrument-message (text-message) 731 :data-min #x04 :data-max #x04) 733 (define-midi-message lyric-message (text-message) 734 :data-min #x05 :data-max #x05) 736 (define-midi-message marker-message (text-message tempo-map-message) 737 :data-min #x06 :data-max #x06) 739 (define-midi-message cue-point-message (text-message) 740 :data-min #x07 :data-max #x07) 742 (define-midi-message program-name-message (text-message) 743 :data-min #x08 :data-max #x08) 745 (define-midi-message device-name-message (text-message) 746 :data-min #x09 :data-max #x09) 748 (define-midi-message channel-prefix-message (meta-message) 749 :data-min #x20 :data-max #x20 752 :filler (progn next-byte (setf channel next-byte)) 753 :writer (write-bytes 1 channel)) 755 (define-midi-message midi-port-message (meta-message) 756 :data-min #x21 :data-max #x21 759 :filler (progn next-byte (setf port next-byte)) 760 :writer (write-bytes 1 port)) 762 (define-midi-message end-of-track-message (meta-message) 763 :data-min #x2f :data-max #x2f 764 :slots ((status :initform #xff)) 767 :writer (write-bytes 0)) 769 (define-midi-message tempo-message (meta-message tempo-map-message) 770 :data-min #x51 :data-max #x51 771 :slots ((tempo :initarg :tempo :reader message-tempo)) 772 :filler (progn next-byte (setf tempo (read-fixed-length-quantity 3))) 774 :writer (progn (write-bytes 3) (write-fixed-length-quantity tempo 3))) 776 (defmethod print-midi-message ((object tempo-message) stream) 778 (when (slot-boundp object 'tempo) 779 (format stream " tempo=~A" (slot-value object 'tempo)))) 781 (define-midi-message smpte-offset-message (meta-message tempo-map-message) 782 :data-min #x54 :data-max #x54 783 :slots ((hr) (mn) (se) (fr) (ff)) 784 :filler (progn next-byte (setf hr next-byte mn next-byte se next-byte 785 fr next-byte ff next-byte)) 787 :writer (write-bytes 5 hr mn se fr ff)) 789 (defmethod print-midi-message ((object smpte-offset-message) stream) 791 (when (or (slot-boundp object 'hr) 792 (slot-boundp object 'mn) 793 (slot-boundp object 'se) 794 (slot-boundp object 'fr) 795 (slot-boundp object 'ff)) 797 " hmsff=~A/~A/~A/~A/~A" 798 (ignore-errors (slot-value object 'hr)) 799 (ignore-errors (slot-value object 'mn)) 800 (ignore-errors (slot-value object 'se)) 801 (ignore-errors (slot-value object 'fr)) 802 (ignore-errors (slot-value object 'ff))))) 804 (define-midi-message time-signature-message (meta-message tempo-map-message) 805 :data-min #x58 :data-max #x58 806 :slots ((nn :reader message-numerator) 807 (dd :reader message-denominator) 809 :filler (progn next-byte (setf nn next-byte dd next-byte 810 cc next-byte bb next-byte)) 812 :writer (write-bytes 4 nn dd cc bb)) 814 (defmethod print-midi-message ((object time-signature-message) stream) 816 (when (or (slot-boundp object 'nn) 817 (slot-boundp object 'dd) 818 (slot-boundp object 'cc) 819 (slot-boundp object 'bb)) 822 (ignore-errors (slot-value object 'nn)) 823 (ignore-errors (slot-value object 'dd)) 824 (ignore-errors (slot-value object 'cc)) 825 (ignore-errors (slot-value object 'bb))))) 827 (define-midi-message key-signature-message (meta-message) 828 :data-min #x59 :data-max #x59 829 :slots ((sf :reader message-sf) 830 (mi :reader message-mi)) 831 :filler (progn next-byte (setf sf (let ((temp-sf next-byte)) 837 :writer (write-bytes 2 (if (< sf 0) (+ sf 256) sf) mi)) 839 (define-midi-message proprietary-event (meta-message) 840 :data-min #x7f :data-max #x7f 842 :filler (setf data (loop with len = (read-variable-length-quantity) 843 with vec = (make-array 845 :element-type '(unsigned-byte 8)) 846 for i from 0 below len 847 do (setf (aref vec i) next-byte) 848 finally (return vec))) 849 :writer (map nil (lambda (byte) (write-bytes byte))