;;; **********************************************************************
;;; Copyright (C) 2003 Heinrich Taube (taube@uiuc.edu) 
;;; This program is free software; you can redistribute it and
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; **********************************************************************

;;; generated by scheme->cltl from midi1.scm on 23-Mar-2005 12:21:23

(in-package :cm)

(defparameter +enc-route-byte+ (byte 10 22))

(defparameter +enc-lower-status-byte+ (byte 4 18))

(defparameter +enc-upper-status-byte+ (byte 4 14))

(defparameter +enc-swapped-status-byte+ (byte 8 14))

(defparameter +enc-logical-channel-byte+ (byte 14 18))

(defparameter +enc-opcode-byte+ +enc-upper-status-byte+)

(defparameter +enc-data-1-byte+ (byte 7 7))

(defparameter +enc-data-2-byte+ (byte 7 0))

(defparameter +enc-route-offs+ -22)

(defparameter +enc-lower-status-offs+ -18)

(defparameter +enc-upper-status-offs+ -10)

(defparameter +enc-swapped-status-offs+ -14)

(defparameter +enc-logical-channel-offs+ +enc-lower-status-offs+)

(defparameter +enc-opcode-offs+ +enc-upper-status-offs+)

(defparameter +enc-data-1-offs+ -7)

(defparameter +enc-data-2-offs+ 0)

(defparameter +enc-note-off-mask+ 4294852480)

(defparameter +ml-note-off-opcode+ 8)

(defparameter +ml-note-on-opcode+ 9)

(defparameter +ml-key-pressure-opcode+ 10)

(defparameter +ml-control-change-opcode+ 11)

(defparameter +ml-program-change-opcode+ 12)

(defparameter +ml-channel-pressure-opcode+ 13)

(defparameter +ml-pitch-bend-opcode+ 14)

(defparameter +ml-default-note-on-velocity+ 64)

(defparameter +ml-default-note-off-velocity+ 64)

(defparameter +ml-msg-sysex-type+ 15)

(defparameter +ml-msg-mtc-quarter-frame-type+ 31)

(defparameter +ml-msg-song-position-type+ 47)

(defparameter +ml-msg-song-select-type+ 63)

(defparameter +ml-msg-cable-select-type+ 95)

(defparameter +ml-msg-tune-request-type+ 111)

(defparameter +ml-msg-eox-type+ 127)

(defparameter +ml-msg-timing-clock-type+ 143)

(defparameter +ml-msg-timing-tick-type+ 159)

(defparameter +ml-msg-start-type+ 175)

(defparameter +ml-msg-continue-type+ 191)

(defparameter +ml-msg-stop-type+ 207)

(defparameter +ml-msg-active-sensing-type+ 239)

(defparameter +ml-msg-system-reset-type+ 255)

(defparameter +ml-meta-type+ 0)

(defparameter +ml-file-meta-marker+ 255)

(defparameter +ml-file-sequence-number-opcode+ 0)

(defparameter +ml-file-text-event-opcode+ 1)

(defparameter +ml-file-copyright-note-opcode+ 2)

(defparameter +ml-file-sequence/track-name-opcode+ 3)

(defparameter +ml-file-instrument-name-opcode+ 4)

(defparameter +ml-file-lyric-opcode+ 5)

(defparameter +ml-file-marker-opcode+ 6)

(defparameter +ml-file-cue-point-opcode+ 7)

(defparameter +ml-file-midi-channel-opcode+ 32)

(defparameter +ml-file-midi-port-opcode+ 33)

(defparameter +ml-file-eot-opcode+ 47)

(defparameter +ml-file-tempo-change-opcode+ 81)

(defparameter +ml-file-smpte-offset-opcode+ 84)

(defparameter +ml-file-time-signature-opcode+ 88)

(defparameter +ml-file-key-signature-opcode+ 89)

(defparameter +ml-file-sequencer-event-opcode+ 127)

(defun midimsg-data1 (message) (ldb +enc-data-1-byte+ message))

(defun midimsg-data2 (message) (ldb +enc-data-2-byte+ message))

(defun midi-channel-message-p (message)
  (< 0 (ldb +enc-opcode-byte+ message) 15))

(defun midi-system-message-p (message)
  (= (ldb +enc-upper-status-byte+ message) 15))

(defun midi-meta-message-p (message)
  (= (ldb +enc-swapped-status-byte+ message) +ml-meta-type+))

(defparameter +channel-message-sizes+ #(3 3 3 3 2 2 3))

(defparameter +system-message-sizes+ #(0
                                       2
                                       3
                                       2
                                       -1
                                       2
                                       1
                                       1
                                       1
                                       1
                                       1
                                       1
                                       1
                                       -1
                                       1
                                       1))

(defparameter +ml-channel-msg-type-strings+ #("Note-Off"
                                              "Note-On"
                                              "Key-Pressure"
                                              "Control-Change"
                                              "Program-Change"
                                              "Channel-Pressure"
                                              "Pitch-Bend"))

(defparameter +ml-msg-type-strings+ #("Sysex"
                                      "MTC Quarter Frame"
                                      "Song-Position"
                                      "Song-Select"
                                      "Undefined"
                                      "Cable-Select"
                                      "Tune-Request"
                                      "Eox"
                                      "Timing-Clock"
                                      "Timing-Tick"
                                      "Start"
                                      "Continue"
                                      "Stop"
                                      "Undefined"
                                      "Active-Sensing"
                                      "System-Reset"))

(defparameter +ml-meta-msg-type-strings+ #((0 . "Sequence Number")
                                           (1 . "Text Event")
                                           (2 . "Copyright Note")
                                           (3
                                            . "Sequence/Track Name")
                                           (4 . "Instrument Name")
                                           (5 . "Lyric")
                                           (6 . "Marker")
                                           (7 . "Cue Point")
                                           (32 . "MIDI Channel")
                                           (33 . "MIDI Port")
                                           (47 . "End of Track")
                                           (81 . "Tempo Change")
                                           (84 . "SMPTE Offset")
                                           (88 . "Time Signature")
                                           (89 . "Key Signature")
                                           (127 . "Sequencer Event")))

(defun get-meta-msg-type-string (type)
  (let ((res
         (find type
               +ml-meta-msg-type-strings+
               :test
               #'=
               :key
               #'car)))
    (if res (cdr res) "Unknown Meta Event")))

(defun midimsg-logical-channel (m) (ldb +enc-logical-channel-byte+ m))

(defun midimsg-route (m) (ldb +enc-route-byte+ m))

(defun midimsg-opcode (m) (ldb +enc-opcode-byte+ m))

(defun midimsg-upper-status (m) (ldb +enc-upper-status-byte+ m))

(defun midimsg-lower-status (m) (ldb +enc-lower-status-byte+ m))

(defun midimsg-status (m) (ldb +enc-swapped-status-byte+ m))

(defun midimsg-size (m)
  (if (midi-channel-message-p m)
      (elt +channel-message-sizes+
           (logand (ash m +enc-swapped-status-offs+) 7))
      (elt +system-message-sizes+
           (logand (ash m +enc-lower-status-offs+) 15))))

(defun channel-note-hash (m)
  (logior (ash (ldb +enc-logical-channel-byte+ m) 8)
          (midimsg-data1 m)))

(defun %midi-encode-channel-message (bytes size)
  (if (= size 3)
      (make-channel-message (ash (logand bytes 15728640) -20)
       (ash (logand bytes 983040) -16) (ash (logand bytes 32512) -8)
       (logand bytes 127))
      (if (= size 2)
          (make-channel-message (ash (logand bytes 61440) -12)
           (ash (logand bytes 3840) -8) (logand bytes 127))
          (error "Size ~s cannot be a channel message." size))))

(defparameter *midi-open* ())

(defparameter *midi-time* -1)

(defmacro define-message-set! (accessor bytespec)
  (make-midi-message-set! accessor bytespec))

(defun make-channel-message (opcode channel data1 &rest args)
  (let ((data2 (if (null args) 0 (car args))))
    (dpb channel
         +enc-logical-channel-byte+
         (dpb opcode
              +enc-opcode-byte+
              (dpb data1
                   +enc-data-1-byte+
                   (dpb data2 +enc-data-2-byte+ 0))))))

(defun channel-message-p (message) (midi-channel-message-p message))

(defun channel-message-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun channel-message-opcode (message)
  (ldb +enc-opcode-byte+ message))

(defun channel-message-data1 (message)
  (ldb +enc-data-1-byte+ message))

(defun channel-message-data2 (message)
  (ldb +enc-data-2-byte+ message))

(define-message-set! channel-message-channel
 +enc-logical-channel-byte+)

(define-message-set! channel-message-opcode +enc-opcode-byte+)

(define-message-set! channel-message-data1 +enc-data-1-byte+)

(define-message-set! channel-message-data2 +enc-data-2-byte+)

(defun make-note-off (channel key velocity)
  (make-channel-message +ml-note-off-opcode+ channel key velocity))

(defun note-off-p (message)
  (= (ldb +enc-opcode-byte+ message) +ml-note-off-opcode+))

(defun note-off-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun note-off-key (message) (ldb +enc-data-1-byte+ message))

(defun note-off-velocity (message) (ldb +enc-data-2-byte+ message))

(define-message-set! note-off-channel +enc-logical-channel-byte+)

(define-message-set! note-off-key +enc-data-1-byte+)

(define-message-set! note-off-velocity +enc-data-2-byte+)

(defun make-note-on (channel key velocity)
  (make-channel-message +ml-note-on-opcode+ channel key velocity))

(defun note-on-p (message)
  (= (ldb +enc-opcode-byte+ message) +ml-note-on-opcode+))

(defun note-on-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun note-on-key (message) (ldb +enc-data-1-byte+ message))

(defun note-on-velocity (message) (ldb +enc-data-2-byte+ message))

(define-message-set! note-on-channel +enc-logical-channel-byte+)

(define-message-set! note-on-key +enc-data-1-byte+)

(define-message-set! note-on-velocity +enc-data-2-byte+)

(defun make-key-pressure (channel key pressure)
  (make-channel-message +ml-key-pressure-opcode+ channel key
   pressure))

(defun key-pressure-p (message)
  (= (ldb +enc-opcode-byte+ message) +ml-key-pressure-opcode+))

(defun key-pressure-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun key-pressure-key (message) (ldb +enc-data-1-byte+ message))

(defun key-pressure-pressure (message)
  (ldb +enc-data-2-byte+ message))

(define-message-set! key-pressure-channel +enc-logical-channel-byte+)

(define-message-set! key-pressure-key +enc-data-1-byte+)

(define-message-set! key-pressure-pressure +enc-data-2-byte+)

(defun make-control-change (channel controller value)
  (make-channel-message +ml-control-change-opcode+ channel controller
   value))

(defun control-change-p (message)
  (= (ldb +enc-opcode-byte+ message) +ml-control-change-opcode+))

(defun control-change-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun control-change-controller (message)
  (ldb +enc-data-1-byte+ message))

(defun control-change-value (message) (ldb +enc-data-2-byte+ message))

(define-message-set! control-change-channel
 +enc-logical-channel-byte+)

(define-message-set! control-change-controller +enc-data-1-byte+)

(define-message-set! control-change-value +enc-data-2-byte+)

(defun make-program-change (channel program)
  (make-channel-message +ml-program-change-opcode+ channel program))

(defun program-change-p (message)
  (= (ldb +enc-opcode-byte+ message) +ml-program-change-opcode+))

(defun program-change-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun program-change-program (message)
  (ldb +enc-data-1-byte+ message))

(define-message-set! program-change-channel
 +enc-logical-channel-byte+)

(define-message-set! program-change-program +enc-data-1-byte+)

(defun make-channel-pressure (channel pressure)
  (make-channel-message +ml-channel-pressure-opcode+ channel
   pressure))

(defun channel-pressure-p (message)
  (= (ldb +enc-opcode-byte+ message) +ml-channel-pressure-opcode+))

(defun channel-pressure-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun channel-pressure-pressure (message)
  (ldb +enc-data-1-byte+ message))

(define-message-set! channel-pressure-channel
 +enc-logical-channel-byte+)

(define-message-set! channel-pressure-pressure +enc-data-1-byte+)

(defun make-pitch-bend (channel value &rest args)
  (let ((width (if (null args) 2 (car args))))
    (let ((bend (floor (rescale value (- width) width 0 16383))))
      (make-channel-message +ml-pitch-bend-opcode+ channel
       (ldb (byte 7 0) bend) (ldb (byte 7 7) bend)))))

(defun pitch-bend-p (message)
  (= (ldb +enc-opcode-byte+ message) +ml-pitch-bend-opcode+))

(defun pitch-bend-channel (message)
  (ldb +enc-logical-channel-byte+ message))

(defun pitch-bend-lsb (message) (ldb +enc-data-1-byte+ message))

(defun pitch-bend-msb (message) (ldb +enc-data-2-byte+ message))

(define-message-set! pitch-bend-channel +enc-logical-channel-byte+)

(define-message-set! pitch-bend-lsb +enc-data-1-byte+)

(define-message-set! pitch-bend-msb +enc-data-2-byte+)

(defun make-system-message (type route &optional (data1 0) (data2 0))
  (dpb route
       +enc-route-byte+
       (dpb type
            +enc-swapped-status-byte+
            (dpb data1
                 +enc-data-1-byte+
                 (dpb data2 +enc-data-2-byte+ 0)))))

(defun system-message-p (message) (midi-system-message-p message))

(defun system-message-route (message) (ldb +enc-route-byte+ message))

(defun system-message-status (message)
  (ldb +enc-swapped-status-byte+ message))

(defun system-message-data1 (message) (ldb +enc-data-1-byte+ message))

(defun system-message-data2 (message) (ldb +enc-data-2-byte+ message))

(define-message-set! system-message-route +enc-route-byte+)

(define-message-set! system-message-status +enc-swapped-status-byte+)

(define-message-set! system-message-data1 +enc-data-1-byte+)

(define-message-set! system-message-data2 +enc-data-2-byte+)

(defun make-sysex-data (&rest args)
  (let ((len 2) (i 0) (msg #()))
    (labels ((incflen (args)
               (dolist (a args)
                 (cond ((characterp a) (incf len))
                       ((and (integerp a) (<= 0 i 255)) (incf len))
                       ((stringp a) (incf len (+ (length a) 1)))
                       ((consp a) (incflen a))
                       (t
                        (error "~s not char, byte or string." a)))))
             (stuff (byte) (incf i) (setf (elt msg i) byte))
             (stuffdata (args)
               (dolist (a args)
                 (cond ((characterp a) (stuff (char-code a)))
                       ((stringp a)
                        (loop for i below (length a)
                              for c = (elt a i)
                              do (stuff (char-code c))
                              finally (stuff 0)))
                        ((and (integerp a) (<= 0 i 255)) (stuff a))
                        ((consp a) (stuffdata a))
                        (t
                         (error "~s not char, byte or string."
                                a))))))
             (incflen args)
             (setf msg (make-array len :initial-element 0))
             (stuffdata args)
             (setf (elt msg 0) 240)
             (setf (elt msg (- len 1)) 247)
             msg)))

(defun make-sysex (route data)
  (values (make-system-message +ml-msg-sysex-type+ route)
          (if (consp data)
              (apply #'make-sysex-data data)
              (if (vectorp data)
                  data
                  (error "~s is not a pair or a vector." data)))))

(defun sysex-p (message)
  (= (ldb +enc-swapped-status-byte+ message) +ml-msg-sysex-type+))

(defun sysex-route (message) (ldb +enc-route-byte+ message))

(define-message-set! sysex-route +enc-route-byte+)

(defun make-mtc-quarter-frame (route tag nibble)
  (make-system-message +ml-msg-mtc-quarter-frame-type+ route
   (logior (ash tag 4) nibble)))

(defun mtc-quarter-frame-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-mtc-quarter-frame-type+))

(defun mtc-quarter-frame-route (message)
  (ldb +enc-route-byte+ message))

(defun mtc-quarter-frame-tag (message)
  (logand (ldb +enc-data-1-byte+ message) 112))

(defun mtc-quarter-frame-nibble (message)
  (logand (ldb +enc-data-1-byte+ message) 15))

(define-message-set! mtc-quarter-frame-route +enc-route-byte+)

(defun make-song-position (route lsb msb)
  (make-system-message +ml-msg-song-position-type+ route lsb msb))

(defun song-position-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-song-position-type+))

(defun song-position-route (message) (ldb +enc-route-byte+ message))

(defun song-position-lsb (message) (ldb +enc-data-1-byte+ message))

(defun song-position-msb (message) (ldb +enc-data-2-byte+ message))

(define-message-set! song-position-route +enc-route-byte+)

(define-message-set! song-position-lsb +enc-data-1-byte+)

(define-message-set! song-position-msb +enc-data-2-byte+)

(defun make-song-select (route song)
  (make-system-message +ml-msg-song-select-type+ route song))

(defun song-select-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-song-select-type+))

(defun song-select-route (message) (ldb +enc-route-byte+ message))

(defun song-select-song (message) (ldb +enc-data-1-byte+ message))

(define-message-set! song-select-route +enc-route-byte+)

(define-message-set! song-select-song +enc-data-1-byte+)

(defun make-cable-select (route cable)
  (make-system-message +ml-msg-cable-select-type+ route cable))

(defun cable-select-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-cable-select-type+))

(defun cable-select-route (message) (ldb +enc-route-byte+ message))

(defun cable-select-cable (message) (ldb +enc-data-1-byte+ message))

(define-message-set! cable-select-route +enc-route-byte+)

(define-message-set! cable-select-cable +enc-data-1-byte+)

(defun make-tune-request (route)
  (make-system-message +ml-msg-tune-request-type+ route))

(defun tune-request-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-tune-request-type+))

(defun tune-request-route (message) (ldb +enc-route-byte+ message))

(define-message-set! tune-request-route +enc-route-byte+)

(defun make-eox (route) (make-system-message +ml-msg-eox-type+ route))

(defun eox-p (message)
  (= (ldb +enc-swapped-status-byte+ message) +ml-msg-eox-type+))

(defun eox-route (message) (ldb +enc-route-byte+ message))

(define-message-set! eox-route +enc-route-byte+)

(defun make-timing-clock (route)
  (make-system-message +ml-msg-timing-clock-type+ route))

(defun timing-clock-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-timing-clock-type+))

(defun timing-clock-route (message) (ldb +enc-route-byte+ message))

(define-message-set! timing-clock-route +enc-route-byte+)

(defun make-timing-tick (route)
  (make-system-message +ml-msg-timing-tick-type+ route))

(defun timing-tick-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-timing-tick-type+))

(defun timing-tick-route (message) (ldb +enc-route-byte+ message))

(define-message-set! timing-tick-route +enc-route-byte+)

(defun make-start (route)
  (make-system-message +ml-msg-start-type+ route))

(defun start-p (message)
  (= (ldb +enc-swapped-status-byte+ message) +ml-msg-start-type+))

(defun start-route (message) (ldb +enc-route-byte+ message))

(define-message-set! start-route +enc-route-byte+)

(defun make-continue (route)
  (make-system-message +ml-msg-continue-type+ route))

(defun continue-p (message)
  (= (ldb +enc-swapped-status-byte+ message) +ml-msg-continue-type+))

(defun continue-route (message) (ldb +enc-route-byte+ message))

(define-message-set! continue-route +enc-route-byte+)

(defun make-stop (route)
  (make-system-message +ml-msg-stop-type+ route))

(defun stop-p (message)
  (= (ldb +enc-swapped-status-byte+ message) +ml-msg-stop-type+))

(defun stop-route (message) (ldb +enc-route-byte+ message))

(define-message-set! stop-route +enc-route-byte+)

(defun make-active-sensing (route)
  (make-system-message +ml-msg-active-sensing-type+ route))

(defun active-sensing-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-active-sensing-type+))

(defun active-sensing-route (message) (ldb +enc-route-byte+ message))

(define-message-set! active-sensing-route +enc-route-byte+)

(defun make-system-reset (route)
  (make-system-message +ml-msg-system-reset-type+ route))

(defun system-reset-p (message)
  (= (ldb +enc-swapped-status-byte+ message)
     +ml-msg-system-reset-type+))

(defun system-reset-route (message) (ldb +enc-route-byte+ message))

(define-message-set! system-reset-route +enc-route-byte+)

(defun make-meta-message (type &rest data-bytes)
  (values (dpb +ml-meta-type+
               +enc-swapped-status-byte+
               (dpb type +enc-data-1-byte+ 0))
          (let ((l (length data-bytes)) (v nil) (d nil))
            (setf v
                  (if (< l 128)
                      1
                      (if (< l 16384)
                          2
                          (if (< l 2097152)
                              3
                              (if
                               (< l 268435456)
                               4
                               (error "Illegal length: ~s" l))))))
            (setf d (make-array (+ v l) :initial-element 0))
            (do ((i 0 (+ 1 i)) (offs (* (- v 1) 7) (- offs 7)))
                ((not (< i v)) nil)
              (setf (elt d i)
                    (if (= offs 0)
                        (ldb (byte 7 offs) l)
                        (logior (ldb (byte 7 offs) l) 128))))
            (do ((i v (+ i 1)) (b data-bytes (cdr b)))
                ((null b) nil)
              (setf (elt d i) (car b)))
            d)))

(defun meta-message-p (message) (midi-meta-message-p message))

(defun meta-message-type (message) (ldb +enc-data-1-byte+ message))

(define-message-set! meta-message-type +enc-data-1-byte+)

(defun make-sequence-number (num)
  (when (>= num 65536)
    (error "~s too big for a sequence number." num))
  (make-meta-message +ml-file-sequence-number-opcode+
   (ldb (byte 8 8) num) (ldb (byte 8 0) num)))

(defun sequence-number-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-sequence-number-opcode+)))

(defun make-text-event (string &optional
                        (type +ml-file-text-event-opcode+))
  (apply #'make-meta-message
         type
         (loop for i below (length string)
               collect (char-code (elt string i)))))

(defun text-event-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-text-event-opcode+)))

(defparameter +text-meta-event-types+ (list
                                       +ml-file-text-event-opcode+
                                       +ml-file-copyright-note-opcode+
                                       +ml-file-sequence/track-name-opcode+
                                       +ml-file-instrument-name-opcode+
                                       +ml-file-lyric-opcode+
                                       +ml-file-marker-opcode+
                                       +ml-file-cue-point-opcode+))

(defun text-meta-event-p (message)
  (and (midi-meta-message-p message)
       (find (ldb +enc-data-1-byte+ message)
             +text-meta-event-types+)))

(defun text-meta-event-data-to-string (data)
  (let ((len (elt data 0)))
    (when (= (elt data len) 0) (setf len (max (- len 1) 0)))
    (loop with str = (make-string len)
          for i below len
          do (setf (elt str i) (code-char (elt data (+ i 1))))
          finally (return str))))

(defun make-copyright-note (string)
  (make-text-event string +ml-file-copyright-note-opcode+))

(defun copyright-note-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-copyright-note-opcode+)))

(defun make-sequence/track-name (string)
  (make-text-event string +ml-file-sequence/track-name-opcode+))

(defun sequence/track-name-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-sequence/track-name-opcode+)))

(defun make-instrument-name (string)
  (make-text-event string +ml-file-instrument-name-opcode+))

(defun instrument-name-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-instrument-name-opcode+)))

(defun make-lyric (string)
  (make-text-event string +ml-file-lyric-opcode+))

(defun lyric-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message) +ml-file-lyric-opcode+)))

(defun make-marker (string)
  (make-text-event string +ml-file-marker-opcode+))

(defun marker-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message) +ml-file-marker-opcode+)))

(defun make-cue-point (string)
  (make-text-event string +ml-file-cue-point-opcode+))

(defun cue-point-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-cue-point-opcode+)))

(defun make-midi-channel (channel)
  (make-meta-message +ml-file-midi-channel-opcode+ channel))

(defun midi-channel-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-midi-channel-opcode+)))

(defun make-midi-port (port)
  (make-meta-message +ml-file-midi-port-opcode+ port))

(defun midi-port-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-midi-port-opcode+)))

(defun make-eot () (make-meta-message +ml-file-eot-opcode+))

(defun eot-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message) +ml-file-eot-opcode+)))

(defun make-tempo-change (usecs-per-beat)
  (apply #'make-meta-message
         +ml-file-tempo-change-opcode+
         (loop for pos from 16 by 8 downto 0
               collect (ldb (byte 8 pos) usecs-per-beat))))

(defun tempo-change-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-tempo-change-opcode+)))

(defun make-smpte-offset (hours mins secs frames fractional-frames)
  (make-meta-message +ml-file-smpte-offset-opcode+ hours mins secs
   frames fractional-frames))

(defun smpte-offset-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-smpte-offset-opcode+)))

(defun make-time-signature (numerator denominator &optional
                            (clocks 24) (32nds 8))
  (multiple-value-bind (f r)
      (floor (log2 denominator))
    (unless (zerop r)
      (error "Time signature denominator ~s is not a power of 2."
             denominator))
    (make-meta-message +ml-file-time-signature-opcode+ numerator f
     clocks 32nds)))

(defun time-signature-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-time-signature-opcode+)))

(defun make-key-signature (key &optional (mode ':major))
  (let ((sf nil))
    (setf mode
          (case mode
            ((:major major 0) 0)
            ((:minor minor 1) 1)
            (t (error "key signature mode not :major or :minor"))))
    (cond ((numberp key)
           (unless (<= -7 key 7)
             (error "Key signature must be between -7 (b) and 7 (#)."))
           (setf sf key))
          (t (error "~s is not a number or symbol." key)))
    (setf sf (if (< sf 0) (+ sf 256) sf))
    (make-meta-message +ml-file-key-signature-opcode+ sf mode)))

(defun key-signature-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-key-signature-opcode+)))

(defun make-sequencer-event (&rest data)
  (apply #'make-meta-message +ml-file-sequencer-event-opcode+ data))

(defun sequencer-event-p (message)
  (and (midi-meta-message-p message)
       (= (ldb +enc-data-1-byte+ message)
          +ml-file-sequencer-event-opcode+)))

(defun midi-print-channel-message (stream
                                   gm?
                                   size
                                   type
                                   channel
                                   data1
                                   data2
                                   time-string)
  (let ((name (elt +ml-channel-msg-type-strings+ (logand type 7))))
    (format stream "~a~a" name time-string)
    (when gm?
      (let ((p (gm-percussion-channel-p channel)))
        (if p (setf channel "P"))
        (cond ((= type 12) (setf data1 (gm-patch-name data1)))
              ((= type 11) (setf data1 (midi-controller-name data1)))
              ((or (= type 10) (= type 8) (= type 9))
               (if p (setf data1 (gm-drum-kit-name data1)))))))
    (format stream " ~a" channel)
    (if (= size 3)
        (format stream " ~s ~s" data1 data2)
        (format stream " ~s" data1))))

(defparameter *midi-gm-mode* t)

(defun %print-sysex-aux (stream data bytes rest indent)
  (let ((offs 0) (toprint bytes) (n 0) (oldn nil) (blank nil))
    (loop while (> toprint 0)
          do (when indent (format stream indent))
             (format stream (format-integer offs 6 #\0))
             (format stream ":")
             (setf oldn n)
             (loop for i below 16
                   while (< n bytes)
                   do (progn (format
                              stream
                              (format-integer (elt data n) 2 #\0))
                             (if (oddp i) (format stream " "))
                             (incf n))
                   finally (setf blank (- 16 i)))
                   (dotimes (i
                             (-
                              (+ (* blank 3) 2)
                              (floor (/ blank 2))))
                     (format stream " "))
                   (setf n oldn)
                   (loop for i below 16
                         while (< n bytes)
                         for b = (elt data n)
                         do (progn (if
                                    (< 31 b 127)
                                    (format
                                     stream
                                     (make-string
                                      1
                                      :initial-element
                                      (code-char b)))
                                    (format stream "."))
                                   (incf n))
                         finally (decf toprint i))
                         (format stream "~%")
                         (incf offs 16))
                   (when (> rest 0)
                     (format stream
                             "         [... (~s Bytes remaining)]~%"
                             rest))
                   (values)))

(defun print-sysex-data (stream string lines data length)
  (let ((bytes 0) (rest 0))
    (unless length (setf length (length data)))
    (setf lines (if (numberp lines) lines 0))
    (setf bytes
          (if (and (> lines 0) (< (* lines 16) length))
              (* (- lines 1) 16)
              length))
    (setf rest (- length bytes))
    (if string
        (error "string output not supported")
        (when stream (%print-sysex-aux stream data bytes rest nil)))))

(defun midi-print-message (msg time &key data length (stream t)
                           (time-format t) (time-string "")
                           (gm *midi-gm-mode*) (delimit t))
  (when (and time time-format)
    (format stream "~a " (format-integer time 8 #\Space)))
  (when delimit (format stream "#<"))
  (cond ((midi-channel-message-p msg)
         (let* ((size (midimsg-size msg))
                (op (channel-message-opcode msg))
                (chan (channel-message-channel msg))
                (data1 (channel-message-data1 msg))
                (data2 (channel-message-data2 msg)))
           (midi-print-channel-message stream gm size op chan data1
            data2 time-string)))
        ((midi-system-message-p msg)
         (let ((name
                (elt +ml-msg-type-strings+
                     (ldb +enc-lower-status-byte+ msg)))
               (route (ldb +enc-route-byte+ msg))
               (size (midimsg-size msg)))
           (format stream "~a~a ~s" name time-string route)
           (cond ((= size 3)
                  (format stream
                          " ~s ~s"
                          (midimsg-data1 msg)
                          (midimsg-data2 msg)))
                 ((= size 2)
                  (format stream " ~s" (midimsg-data1 msg)))
                 (t
                  (when delimit
                    (format stream ">")
                    (setf delimit nil))
                  (when (sysex-p msg)
                    (format stream "~%")
                    (print-sysex-data t nil 0 data length))))))
        ((midi-meta-message-p msg)
         (cond ((or (midi-channel-p msg) (midi-port-p msg))
                (format stream
                        "~a~a ~s"
                        (get-meta-msg-type-string
                         (ldb +enc-data-1-byte+ msg))
                        time-string
                        (if data (elt data 1) "?")))
               ((tempo-change-p msg)
                (format stream
                        "~a~a ~s ms"
                        (get-meta-msg-type-string
                         (ldb +enc-data-1-byte+ msg))
                        time-string
                        (/ (+ (ash (elt data 1) 16)
                              (ash (elt data 2) 8)
                              (elt data 3))
                           1000)))
               ((time-signature-p msg)
                (format stream
                        "~a~a ~s/~s (~s clocks, ~s 32nds)"
                        (get-meta-msg-type-string
                         (ldb +enc-data-1-byte+ msg))
                        time-string
                        (elt data 1)
                        (expt 2 (elt data 2))
                        (elt data 3)
                        (elt data 4)))
               ((key-signature-p msg)
                (let ((a (elt data 1)) (s nil))
                  (setf a (or (and (logtest a 128) (- a 256)) a))
                  (setf s (if (> (abs a) 1) "s" ""))
                  (format stream
                          "~a~a ~a ~a~a, ~a"
                          (get-meta-msg-type-string
                           (ldb +enc-data-1-byte+ msg))
                          time-string
                          (if (zerop a) "no" (abs a))
                          (case (signum a)
                            ((-1) "flat")
                            ((0) "accidentals")
                            ((1) "sharp"))
                          s
                          (if (zerop (elt data 2))
                              "major"
                              "minor"))))
               (t
                (format stream
                        "~a~a"
                        (get-meta-msg-type-string
                         (ldb +enc-data-1-byte+ msg))
                        time-string)
                (if data
                    (format stream
                            " ~s"
                            (if (text-meta-event-p msg)
                                (text-meta-event-data-to-string data)
                                data))
                    (format stream ">")))))
        (t (format stream "Bogus Midi Message~a]" time-string)))
  (when delimit (format stream ">"))
  msg)

(defparameter %deflabelvar% (gensym))

(defmacro deflabel (sym val vector str pos)
  `(progn (defparameter ,sym ,val)
          ,(if str
               `(setf (elt ,vector ,pos) ,str)
               `(progn (setf %deflabelvar% (format nil "~a" ',sym))
                       (do ((i 0 (+ i 1)) (e (length %deflabelvar%)))
                           ((not (< i e)) nil)
                         (if (char= (elt %deflabelvar% i) #\Space)
                             (setf (elt %deflabelvar% i) #\-)))
                       (setf (elt ,vector ,pos)
                             (nstring-capitalize
                              (subseq
                               %deflabelvar%
                               1
                               (- (length %deflabelvar%) 1))))))))

(defparameter +midi-controller-strings+ (make-array
                                         128
                                         :initial-element
                                         ""))

(defmacro defcontroller (sym val &body str)
  `(deflabel ,sym ,val +midi-controller-strings+
    ,(if (null str) nil (car str)) ,val))

(defun midi-opcode-name (vec code lb ub delta)
  (cond ((and (integerp code) (<= lb code ub))
         (elt vec (+ code delta)))
        ((stringp code) code)
        (t
         (error "MIDI opcode ~s not string or int ~s-~s."
                code
                lb
                ub))))

(defun midi-controller-name (c)
  (midi-opcode-name +midi-controller-strings+ c 0 127 0))

(defcontroller +bank-select+ 0)

(defcontroller +modulation-wheel+ 1)

(defcontroller +breath-control+ 2)

(defcontroller +foot-controller+ 4)

(defcontroller +portamento-time+ 5)

(defcontroller +data-entry+ 6)

(defcontroller +channel-volume+ 7)

(defparameter +volume+ 7)

(defcontroller +balance+ 8)

(defcontroller +pan+ 10)

(defcontroller +expression-controller+ 11)

(defcontroller +effect-control-1+ 12)

(defcontroller +effect-control-2+ 13)

(defcontroller +general-purpose-controller-1+ 16
 "General-Purpose Controller 1")

(defcontroller +general-purpose-controller-2+ 17
 "General-Purpose Controller 2")

(defcontroller +general-purpose-controller-3+ 18
 "General-Purpose Controller 3")

(defcontroller +general-purpose-controller-4+ 19
 "General-Purpose Controller 4")

(defcontroller +bank-select-fine+ 32 "Bank Select (Fine)")

(defcontroller +modulation-wheel-fine+ 33 "Modulation Wheel (Fine)")

(defcontroller +breath-control-fine+ 34 "Breath Control (Fine)")

(defcontroller +foot-controller-fine+ 36 "Foot Controller (Fine)")

(defcontroller +portamento-time-fine+ 37 "Portamento Time (Fine)")

(defcontroller +data-entry-fine+ 38 "Data Entry (Fine)")

(defcontroller +channel-volume-fine+ 39 "Channel Volume (Fine)")

(defparameter +volume-fine+ 39)

(defcontroller +balance-fine+ 40 "Balance (Fine)")

(defcontroller +pan-fine+ 42 "Pan (Fine)")

(defcontroller +expression-controller-fine+ 43
 "Expression Controller (Fine)")

(defcontroller +effect-control-1-fine+ 44 "Effect Control 1 (Fine)")

(defcontroller +effect-control-2-fine+ 45 "Effect Control 2 (Fine)")

(defcontroller +general-purpose-controller-1-fine+ 48
 "General-Purpose Controller 1 (Fine)")

(defcontroller +general-purpose-controller-2-fine+ 49
 "General-Purpose Controller 1 (Fine)")

(defcontroller +general-purpose-controller-3-fine+ 50
 "General-Purpose Controller 1 (Fine)")

(defcontroller +general-purpose-controller-4-fine+ 51
 "General-Purpose Controller 1 (Fine)")

(defcontroller +hold-1+ 64)

(defparameter +sustain+ 64)

(defparameter +damper-pedal+ 64)

(defcontroller +portamento+ 65)

(defcontroller +sostenuto+ 66)

(defcontroller +soft-pedal+ 67)

(defcontroller +legato-footswitch+ 68)

(defcontroller +hold-2+ 69)

(defcontroller +sound-control-1+ 70)

(defparameter +sound-variation+ 70)

(defcontroller +sound-control-2+ 71)

(defparameter +sound-timbre+ 71)

(defcontroller +sound-control-3+ 72)

(defparameter +sound-release-time+ 72)

(defcontroller +sound-control-4+ 73)

(defparameter +sound-attack-time+ 73)

(defcontroller +sound-control-5+ 74)

(defparameter +sound-brightness+ 74)

(defcontroller +sound-control-6+ 75)

(defcontroller +sound-control-7+ 76)

(defcontroller +sound-control-8+ 77)

(defcontroller +sound-control-9+ 78)

(defcontroller +sound-control-10+ 79)

(defcontroller +general-purpose-controller-5+ 80
 "General-Purpose Controller 5")

(defcontroller +general-purpose-controller-6+ 81
 "General-Purpose Controller 6")

(defcontroller +general-purpose-controller-7+ 82
 "General-Purpose Controller 7")

(defcontroller +general-purpose-controller-8+ 83
 "General-Purpose Controller 8")

(defcontroller +portamento-control+ 84)

(defcontroller +effects-1-depth+ 91)

(defparameter +effects-level+ 91)

(defcontroller +effects-2-depth+ 92)

(defparameter +tremolo-level+ 92)

(defcontroller +effects-3-depth+ 93)

(defparameter +chorus-level+ 93)

(defcontroller +effects-4-depth+ 94)

(defparameter +detune-level+ 94)

(defcontroller +effects-5-depth+ 95)

(defparameter +phasor-level+ 95)

(defcontroller +data-entry-+1+ 96)

(defparameter +data-entry-increment+ 96)

(defcontroller +data-entry--1+ 97 "Data Entry -1")

(defparameter +data-entry-decrement+ 97)

(defcontroller +non-registered-parameter-number-fine+ 98
 "Non-Registered Parameter Number (Fine)")

(defcontroller +non-registered-parameter-number+ 99
 "Non-Registered Parameter Number")

(defcontroller +registered-parameter-number-fine+ 100
 "Registered Parameter Number (Fine)")

(defcontroller +registered-parameter-number+ 101)

(defcontroller +all-sound-off+ 120)

(defcontroller +reset-all-controllers+ 121)

(defcontroller +local-control+ 122)

(defcontroller +all-notes-off+ 123)

(defcontroller +omni-mode-off+ 124)

(defcontroller +omni-mode-on+ 125)

(defcontroller +poly-mode-on/off+ 126)

(defcontroller +poly-mode-on+ 127)

(defparameter +rpn-pitch-bend-sensitivity+ (quote (0 0)))

(defparameter +rpn-fine-tuning+ (quote (0 1)))

(defparameter +rpn-coarse-tuning+ (quote (0 2)))

(defparameter +rpn-reset+ (quote (63 255)))

(defparameter +gm-patch-strings+ (make-array
                                  128
                                  :initial-element
                                  '""))

(defparameter +gm-drum-kit-strings+ (make-array
                                     50
                                     :initial-element
                                     '""))

(defmacro defgmpatch (sym val &body str)
  `(deflabel ,sym ,val +gm-patch-strings+
    ,(if (null str) nil (car str)) ,val))

(defmacro defgmdrum (sym val &body str)
  `(deflabel ,sym ,val +gm-drum-kit-strings+
    ,(if (null str) nil (car str)) ,(- val 32)))

(defun gm-patch-name (patch)
  (midi-opcode-name +gm-patch-strings+ patch 0 127 0))

(defun gm-drum-kit-name (key)
  (midi-opcode-name +gm-drum-kit-strings+ key 35 81 -32))

(defgmpatch +acoustic-grand-piano+ 0)

(defgmpatch +bright-acoustic-piano+ 1)

(defgmpatch +electric-grand-piano+ 2)

(defgmpatch +honky-tonk-piano+ 3)

(defgmpatch +electric-piano-1+ 4)

(defgmpatch +electric-piano-2+ 5)

(defgmpatch +harpsichord+ 6)

(defgmpatch +clavi+ 7)

(defgmpatch +celesta+ 8)

(defgmpatch +glockenspiel+ 9)

(defgmpatch +music-box+ 10)

(defgmpatch +vibraphone+ 11)

(defgmpatch +marimba+ 12)

(defgmpatch +xylophone+ 13)

(defgmpatch +tubular-bells+ 14)

(defgmpatch +dulcimer+ 15)

(defgmpatch +drawbar-organ+ 16)

(defgmpatch +percussive-organ+ 17)

(defgmpatch +rock-organ+ 18)

(defgmpatch +church-organ+ 19)

(defgmpatch +reed-organ+ 20)

(defgmpatch +accordion+ 21)

(defgmpatch +harmonica+ 22)

(defgmpatch +tango-accordion+ 23)

(defgmpatch +acoustic-guitar-nylon+ 24)

(defgmpatch +acoustic-guitar-steel+ 25)

(defgmpatch +electric-guitar-jazz+ 26)

(defgmpatch +electric-guitar-clean+ 27)

(defgmpatch +electric-guitar-muted+ 28)

(defgmpatch +overdriven-guitar+ 29)

(defgmpatch +distortion-guitar+ 30)

(defgmpatch +guitar-harmonics+ 31)

(defgmpatch +acoustic-bass+ 32)

(defgmpatch +electric-bass-finger+ 33)

(defgmpatch +electric-bass-pick+ 34)

(defgmpatch +fretless-bass+ 35)

(defgmpatch +slap-bass-1+ 36)

(defgmpatch +slap-bass-2+ 37)

(defgmpatch +synth-bass-1+ 38)

(defgmpatch +synth-bass-2+ 39)

(defgmpatch +violin+ 40)

(defgmpatch +viola+ 41)

(defgmpatch +cello+ 42)

(defgmpatch +contrabass+ 43)

(defgmpatch +tremolo-strings+ 44)

(defgmpatch +pizzicato-strings+ 45)

(defgmpatch +orchestral-strings+ 46)

(defgmpatch +timpani+ 47)

(defgmpatch +string-ensemble-1+ 48)

(defgmpatch +string-ensemble-2+ 49)

(defgmpatch +synthstrings-1+ 50)

(defgmpatch +synthstrings-2+ 51)

(defgmpatch +choir-aahs+ 52)

(defgmpatch +voice-oohs+ 53)

(defgmpatch +synth-voice+ 54)

(defgmpatch +orchestra-hit+ 55)

(defgmpatch +trumpet+ 56)

(defgmpatch +trombone+ 57)

(defgmpatch +tuba+ 58)

(defgmpatch +muted-trumpet+ 59)

(defgmpatch +french-horn+ 60)

(defgmpatch +brass-section+ 61)

(defgmpatch +synthbrass-1+ 62)

(defgmpatch +synthbrass-2+ 63)

(defgmpatch +soprano-sax+ 64)

(defgmpatch +alto-sax+ 65)

(defgmpatch +tenor-sax+ 66)

(defgmpatch +baritone-sax+ 67)

(defgmpatch +oboe+ 68)

(defgmpatch +english-horn+ 69)

(defgmpatch +bassoon+ 70)

(defgmpatch +clarinet+ 71)

(defgmpatch +piccolo+ 72)

(defgmpatch +flute+ 73)

(defgmpatch +recorder+ 74)

(defgmpatch +pan-flute+ 75)

(defgmpatch +blown-bottle+ 76)

(defgmpatch +skakuhachi+ 77)

(defgmpatch +whistle+ 78)

(defgmpatch +ocarina+ 79)

(defgmpatch +lead-1-square+ 80 "Lead 1 (Square)")

(defparameter +lead-1+ 80)

(defparameter +square-lead+ 80)

(defparameter +square+ 80)

(defgmpatch +lead-2-sawtooth+ 81 "Lead 2 (Sawtooth)")

(defparameter +lead-2+ 81)

(defparameter +sawtooth-lead+ 81)

(defparameter +sawtooth+ 81)

(defgmpatch +lead-3-calliope+ 82 "Lead 3 (Calliope)")

(defparameter +lead-3+ 82)

(defparameter +calliope-lead+ 82)

(defparameter +calliope+ 82)

(defgmpatch +lead-4-chiff+ 83 "Lead 4 (Chiff)")

(defparameter +lead-4+ 83)

(defparameter +chiff-lead+ 83)

(defparameter +chiff+ 83)

(defgmpatch +lead-5-charang+ 84 "Lead 5 (Charang)")

(defparameter +lead-5+ 84)

(defparameter +charang-lead+ 84)

(defparameter +charang+ 84)

(defgmpatch +lead-6-voice+ 85 "Lead 6 (Voice)")

(defparameter +lead-6+ 85)

(defparameter +voice-lead+ 85)

(defparameter +voice+ 85)

(defgmpatch +lead-7-fifths+ 86 "Lead 7 (Fifths)")

(defparameter +lead-7+ 86)

(defparameter +fifths-lead+ 86)

(defparameter +fifths+ 86)

(defgmpatch +lead-8-bass+lead+ 87 "Lead 8 (Bass+Lead)")

(defparameter +lead-8+ 87)

(defparameter +bass+lead-lead+ 87)

(defparameter +bass+lead+ 87)

(defgmpatch +pad-1-new-age+ 88 "Pad 1 (New Age)")

(defparameter +pad-1+ 88)

(defparameter +new-age-pad+ 88)

(defparameter +new-age+ 88)

(defgmpatch +pad-2-warm+ 89 "Pad 2 (Warm)")

(defparameter +pad-2+ 89)

(defparameter +warm-pad+ 89)

(defparameter +warm+ 89)

(defgmpatch +pad-3-polysynth+ 90 "Pad 3 (Polysynth)")

(defparameter +pad-3+ 90)

(defparameter +polysynth-pad+ 90)

(defparameter +polysynth+ 90)

(defgmpatch +pad-4-choir+ 91 "Pad 4 (Choir)")

(defparameter +pad-4+ 91)

(defparameter +choir-pad+ 91)

(defparameter +choir+ 91)

(defgmpatch +pad-5-bowed+ 92 "Pad 5 (Bowed)")

(defparameter +pad-5+ 92)

(defparameter +bowed-pad+ 92)

(defparameter +bowed+ 92)

(defgmpatch +pad-6-metallic+ 93 "Pad 6 (Metallic)")

(defparameter +pad-6+ 93)

(defparameter +metallic-pad+ 93)

(defparameter +metallic+ 93)

(defgmpatch +pad-7-halo+ 94 "Pad 7 (Halo)")

(defparameter +pad-7+ 94)

(defparameter +halo-pad+ 94)

(defparameter +halo+ 94)

(defgmpatch +pad-8-sweep+ 95 "Pad 8 (Sweep)")

(defparameter +pad-8+ 95)

(defparameter +sweep-pad+ 95)

(defparameter +sweep+ 95)

(defgmpatch +fx-1-rain+ 96 "FX 1 (Rain)")

(defparameter +fx-1+ 96)

(defparameter +rain-fx+ 96)

(defparameter +rain+ 96)

(defgmpatch +fx-2-soundtrack+ 97 "FX 2 (Soundtrack)")

(defparameter +fx-2+ 97)

(defparameter +soundtrack-fx+ 97)

(defparameter +soundtrack+ 97)

(defgmpatch +fx-3-crystal+ 98 "FX 3 (Crystal)")

(defparameter +fx-3+ 98)

(defparameter +crystal-fx+ 98)

(defparameter +crystal+ 98)

(defgmpatch +fx-4-atmosphere+ 99 "FX 4 (Atmosphere)")

(defparameter +fx-4+ 99)

(defparameter +atmosphere-fx+ 99)

(defparameter +atmosphere+ 99)

(defgmpatch +fx-5-brightness+ 100 "FX 5 (Brightness)")

(defparameter +fx-5+ 100)

(defparameter +brightness-fx+ 100)

(defparameter +brightness+ 100)

(defgmpatch +fx-6-goblins+ 101 "FX 6 (Goblins)")

(defparameter +fx-6+ 101)

(defparameter +goblins-fx+ 101)

(defparameter +goblins+ 101)

(defgmpatch +fx-7-echoes+ 102 "FX 7 (Echoes)")

(defparameter +fx-7+ 102)

(defparameter +echoes-fx+ 102)

(defparameter +echoes+ 102)

(defgmpatch +fx-8-sci-fi+ 103 "FX 8 (Sci-Fi)")

(defparameter +fx-8+ 103)

(defparameter +sci-fi-fx+ 103)

(defparameter +sci-fi+ 103)

(defgmpatch +sitar+ 104)

(defgmpatch +banjo+ 105)

(defgmpatch +shamisen+ 106)

(defgmpatch +koto+ 107)

(defgmpatch +kalimba+ 108)

(defgmpatch +bagpipe+ 109)

(defgmpatch +fiddle+ 110)

(defgmpatch +shanai+ 111)

(defgmpatch +tinkle-bell+ 112)

(defgmpatch +agogo+ 113)

(defgmpatch +steel-drums+ 114)

(defgmpatch +woodblock+ 115)

(defgmpatch +taiko-drum+ 116)

(defgmpatch +melodic-tom+ 117)

(defgmpatch +synth-drum+ 118)

(defgmpatch +reverse-cymbal+ 119)

(defgmpatch +guitar-fret-noise+ 120)

(defgmpatch +breath-noise+ 121)

(defgmpatch +seashore+ 122)

(defgmpatch +bird-tweet+ 123)

(defgmpatch +telephone-ring+ 124)

(defgmpatch +helicopter+ 125)

(defgmpatch +applause+ 126)

(defgmpatch +gunshot+ 127)

(defparameter *gm-percussion-channels* #(9))

(defun gm-percussion-channel-p (chan)
  (do ((i 0 (+ i 1)) (f nil) (e (length *gm-percussion-channels*)))
      ((or f (not (< i e))) f)
    (setf f (= (elt *gm-percussion-channels* i) chan))))

(defgmdrum +acoustic-bass-drum+ 35)

(defgmdrum +bass-drum-1+ 36)

(defgmdrum +side-stick+ 37)

(defgmdrum +acoustic-snare+ 38)

(defgmdrum +hand-clap+ 39)

(defgmdrum +electric-snare+ 40)

(defgmdrum +low-floor-tom+ 41)

(defgmdrum +closed-hi-hat+ 42)

(defgmdrum +high-floor-tom+ 43)

(defgmdrum +pedal-hi-hat+ 44)

(defgmdrum +low-tom+ 45)

(defgmdrum +open-hi-hat+ 46)

(defgmdrum +low-mid-tom+ 47)

(defgmdrum +hi-mid-tom+ 48)

(defgmdrum +crash-cymbal-1+ 49)

(defgmdrum +high-tom+ 50)

(defgmdrum +ride-cymbal-1+ 51)

(defgmdrum +chinese-cymbal+ 52)

(defgmdrum +ride-bell+ 53)

(defgmdrum +tambourine+ 54)

(defgmdrum +splash-cymbal+ 55)

(defgmdrum +cowbell+ 56)

(defgmdrum +crash-cymbal-2+ 57)

(defgmdrum +vibraslap+ 58)

(defgmdrum +ride-cymbal-2+ 59)

(defgmdrum +hi-bongo+ 60)

(defgmdrum +low-bongo+ 61)

(defgmdrum +mute-hi-conga+ 62)

(defgmdrum +open-hi-conga+ 63)

(defgmdrum +low-conga+ 64)

(defgmdrum +high-timbale+ 65)

(defgmdrum +low-timbale+ 66)

(defgmdrum +high-agogo+ 67)

(defgmdrum +low-agogo+ 68)

(defgmdrum +cabasa+ 69)

(defgmdrum +maracas+ 70)

(defgmdrum +short-whistle+ 71)

(defgmdrum +long-whistle+ 72)

(defgmdrum +short-guiro+ 73)

(defgmdrum +long-guiro+ 74)

(defgmdrum +claves+ 75)

(defgmdrum +hi-wood-block+ 76)

(defgmdrum +low-wood-block+ 77)

(defgmdrum +mute-cuica+ 78)

(defgmdrum +open-cuica+ 79)

(defgmdrum +mute-triangle+ 80)

(defgmdrum +open-triangle+ 81)

(defparameter +sequential-circuits-id+ 1)

(defparameter +idp-id+ 2)

(defparameter +voyetra-id+ 3)

(defparameter +moog-id+ 4)

(defparameter +passport-id+ 5)

(defparameter +lexicon-id+ 6)

(defparameter +kurzweil-id+ 7)

(defparameter +fender-id+ 8)

(defparameter +gulbransen-id+ 9)

(defparameter +akg-id+ 10)

(defparameter +voyce-id+ 11)

(defparameter +waveframe-id+ 12)

(defparameter +ada-id+ 13)

(defparameter +garfield-id+ 14)

(defparameter +ensoniq-id+ 15)

(defparameter +oberheim-id+ 16)

(defparameter +apple-id+ 17)

(defparameter +grey-matter-id+ 18)

(defparameter +digidesign-id+ 19)

(defparameter +palm-tree-id+ 20)

(defparameter +jl-cooper-id+ 21)

(defparameter +lowrey-id+ 22)

(defparameter +adams-smith-id+ 23)

(defparameter +e-mu-id+ 24)

(defparameter +harmony-id+ 25)

(defparameter +art-id+ 26)

(defparameter +baldwin-id+ 27)

(defparameter +eventide-id+ 28)

(defparameter +inventronics-id+ 29)

(defparameter +key-concepts-id+ 30)

(defparameter +clarity-id+ 31)

(defparameter +passac-id+ 32)

(defparameter +siel-id+ 33)

(defparameter +synthaxe-id+ 34)

(defparameter +stepp-id+ 35)

(defparameter +hohner-id+ 36)

(defparameter +twister-id+ 37)

(defparameter +solton-id+ 38)

(defparameter +jellinghaus-id+ 39)

(defparameter +southworth-id+ 40)

(defparameter +ppg-id+ 41)

(defparameter +jen-id+ 42)

(defparameter +solid-state-id+ 43)

(defparameter +audio-vertrieb-id+ 44)

(defparameter +hinton-id+ 45)

(defparameter +soundtracs-id+ 46)

(defparameter +elka-id+ 47)

(defparameter +dynachord-id+ 48)

(defparameter +clavia-id+ 51)

(defparameter +audio-architecture-id+ 52)

(defparameter +soundcraft-id+ 57)

(defparameter +wersi-id+ 59)

(defparameter +avab-id+ 60)

(defparameter +digigram-id+ 61)

(defparameter +waldorf-id+ 62)

(defparameter +quasimidi-id+ 63)

(defparameter +kawai-id+ 64)

(defparameter +roland-id+ 65)

(defparameter +korg-id+ 66)

(defparameter +yamaha-id+ 67)

(defparameter +casio-id+ 68)

(defparameter +moridaira-id+ 69)

(defparameter +kamiya-id+ 70)

(defparameter +akai-id+ 71)

(defparameter +japan-victor-id+ 72)

(defparameter +meisosha-id+ 73)

(defparameter +hoshino-gakki-id+ 74)

(defparameter +fujitsu-id+ 75)

(defparameter +sony-id+ 76)

(defparameter +nishin-onpa-id+ 77)

(defparameter +teac-id+ 78)

(defparameter +matsushita-electric-id+ 80)

(defparameter +fostex-id+ 81)

(defparameter +zoom-id+ 82)

(defparameter +midori-id+ 83)

(defparameter +matsushita-communication-id+ 84)

(defparameter +suzuki-id+ 85)

(defparameter +warner-id+ (quote (0 0 1)))

(defparameter +digital-music-id+ (quote (0 0 7)))

(defparameter +iota-id+ (quote (0 0 8)))

(defparameter +new-england-id+ (quote (0 0 9)))

(defparameter +artisyn-id+ (quote (0 0 10)))

(defparameter +ivl-id+ (quote (0 0 11)))

(defparameter +southern-music-id+ (quote (0 0 12)))

(defparameter +lake-butler-id+ (quote (0 0 13)))

(defparameter +alesis-id+ (quote (0 0 14)))

(defparameter +dod-id+ (quote (0 0 16)))

(defparameter +studer-id+ (quote (0 0 17)))

(defparameter +perfect-fretworks-id+ (quote (0 0 20)))

(defparameter +kat-id+ (quote (0 0 21)))

(defparameter +opcode-id+ (quote (0 0 22)))

(defparameter +rane-id+ (quote (0 0 23)))

(defparameter +spatial-sound-id+ (quote (0 0 24)))

(defparameter +kmx-id+ (quote (0 0 25)))

(defparameter +allen-&-heath-id+ (quote (0 0 26)))

(defparameter +peavey-id+ (quote (0 0 27)))

(defparameter +360-id+ (quote (0 0 28)))

(defparameter +spectrum-id+ (quote (0 0 29)))

(defparameter +marquis-musi-id+ (quote (0 0 30)))

(defparameter +zeta-id+ (quote (0 0 31)))

(defparameter +axxes-id+ (quote (0 0 32)))

(defparameter +orban-id+ (quote (0 0 33)))

(defparameter +kti-id+ (quote (0 0 36)))

(defparameter +breakaway-id+ (quote (0 0 37)))

(defparameter +cae-id+ (quote (0 0 38)))

(defparameter +rocktron-id+ (quote (0 0 41)))

(defparameter +pianodisc-id+ (quote (0 0 42)))

(defparameter +cannon-id+ (quote (0 0 43)))

(defparameter +rogers-id+ (quote (0 0 45)))

(defparameter +blue-sky-id+ (quote (0 0 46)))

(defparameter +encore-id+ (quote (0 0 47)))

(defparameter +uptown-id+ (quote (0 0 48)))

(defparameter +voce-id+ (quote (0 0 49)))

(defparameter +cti-id+ (quote (0 0 50)))

(defparameter +s&s-id+ (quote (0 0 51)))

(defparameter +broderbund-id+ (quote (0 0 52)))

(defparameter +allen-organ-id+ (quote (0 0 53)))

(defparameter +music-quest-id+ (quote (0 0 55)))

(defparameter +aphex-id+ (quote (0 0 56)))

(defparameter +gallien-krueger-id+ (quote (0 0 57)))

(defparameter +ibm-id+ (quote (0 0 58)))

(defparameter +hotz-id+ (quote (0 0 60)))

(defparameter +eta-id+ (quote (0 0 61)))

(defparameter +nsi-id+ (quote (0 0 62)))

(defparameter +ad-lib-id+ (quote (0 0 63)))

(defparameter +richmond-id+ (quote (0 0 64)))

(defparameter +microsoft-id+ (quote (0 0 65)))

(defparameter +software-toolworks-id+ (quote (0 0 66)))

(defparameter +rjmg/niche-id+ (quote (0 0 67)))

(defparameter +intone-id+ (quote (0 0 68)))

(defparameter +gt-electronics-id+ (quote (0 0 71)))

(defparameter +intermidi-id+ (quote (0 0 72)))

(defparameter +lone-wolf-id+ (quote (0 0 85)))

(defparameter +musonix-id+ (quote (0 0 100)))

(defparameter +sgi-id+ (quote (0 1 4)))

(defparameter +dream-id+ (quote (0 32 0)))

(defparameter +strand-id+ (quote (0 32 0)))

(defparameter +amek-id+ (quote (0 32 0)))

(defparameter +dr.boehm-id+ (quote (0 32 0)))

(defparameter +trident-id+ (quote (0 32 0)))

(defparameter +real-world-id+ (quote (0 32 0)))

(defparameter +yes-id+ (quote (0 32 0)))

(defparameter +audiomatica-id+ (quote (0 32 0)))

(defparameter +bontempi-id+ (quote (0 32 0)))

(defparameter +fbt-id+ (quote (0 32 0)))

(defparameter +larking-id+ (quote (0 32 0)))

(defparameter +zero-88-id+ (quote (0 32 0)))

(defparameter +micon-id+ (quote (0 32 16)))

(defparameter +forefront-id+ (quote (0 32 16)))

(defparameter +kenton-id+ (quote (0 32 16)))

(defparameter +adb-id+ (quote (0 32 16)))

(defparameter +marshall-id+ (quote (0 32 16)))

(defparameter +dda-id+ (quote (0 32 16)))

(defparameter +tc-id+ (quote (0 32 16)))

(defparameter +non-commercial-id+ 125)

(defparameter +non-real-time-id+ 126)

(defparameter +sample-dump-header-sub-id+ 1)

(defparameter +sample-dump-packet-sub-id+ 2)

(defparameter +dump-request-sub-id+ 3)

(defparameter +midi-time-code-setup-sub-id+ 4)

(defparameter +sample-dump-extensions-sub-id+ 5)

(defparameter +inquiry-message-sub-id+ 6)

(defparameter +file-dump-sub-id+ 7)

(defparameter +midi-tuning-standard-sub-id+ 8)

(defparameter +general-midi-message-sub-id+ 9)

(defparameter +end-of-file-sub-id+ 123)

(defparameter +wait-sub-id+ 124)

(defparameter +cancel-sub-id+ 125)

(defparameter +nak-sub-id+ 126)

(defparameter +ack-sub-id+ 127)

(defparameter +real-time-id+ 127)

(defparameter +long-form-mtc-sub-id+ 1)

(defparameter +midi-show-control-sub-id+ 2)

(defparameter +notation-information-sub-id+ 3)

(defparameter +device-control-sub-id+ 4)

(defparameter +real-time-mtc-cueing-sub-id+ 5)

(defparameter +midi-machine-control-command-sub-id+ 6)

(defparameter +midi-machine-control-response-sub-id+ 7)

(defparameter +single-note-retune-sub-id+ 8)

(defun n-bit-twoscomp-p (num bits signed? &rest args)
  (let ((error? (if (null args) nil (car args))))
    (if signed?
        (if (and (< num 0) (<= (integer-length num) bits))
            t
            (if error?
                (error "Not a signed ~s-bit byte: ~s." bits num)
                nil))
        (if (and (not (< num 0)) (<= (integer-length num) bits))
            t
            (if error?
                (error "Not an unsigned ~s-bit byte: ~s." bits num)
                nil)))))

(defun n-bit-twoscomp (num bits signed?)
  (n-bit-twoscomp-p num bits signed? t)
  (if (< num 0) (+ num (expt 2 bits)) num))

(defun n-bit-bytes (num bytes bits lsb-first?)
  (n-bit-twoscomp-p num (* bytes bits) (< num 0) t)
  (let ((l '()))
    (do ((i 0 (+ i 1)))
        ((not (< i bytes)) nil)
      (setf l (cons (ldb (byte bits (* i bits)) num) l)))
    (if lsb-first? (reverse l) l)))

(defun nibblize (lsb-first? &rest data)
  (let ((res '()) (o1 (if lsb-first? 0 4)) (o2 (if lsb-first? 4 0)))
    (labels ((nblize (x)
               (cond ((not x) nil)
                     ((null x) nil)
                     ((vectorp x)
                      (do ((i 0 (+ i 1)) (e (length x)))
                          ((not (< i e)) nil)
                        (nblize (elt x i))))
                     ((stringp x)
                      (do ((i 0 (+ i 1)) (e (length x)))
                          ((not (< i e)) nil)
                        (nblize (elt x i)))
                      (nblize 0))
                     ((consp x)
                      (do ((i 0 (+ i 1)) (e (length x)))
                          ((not (< i e)) nil)
                        (nblize (elt x i))))
                     ((characterp x)
                      (setf x (char-code x))
                      (push (ldb (byte 4 o1) x) res)
                      (push (ldb (byte 4 o2) x) res))
                     ((integerp x)
                      (push (ldb (byte 4 o1) x) res)
                      (push (ldb (byte 4 o2) x) res))
                     (t (error "Can't nibbilize ~s." x)))))
      (nblize data)
      (reverse res))))

(defparameter +all-device-ids+ 127)

(defun make-gm-mode-sysex-data (gm-on?
                                &key
                                (device-id +all-device-ids+))
  (make-sysex-data +non-real-time-id+ device-id
   +general-midi-message-sub-id+ (if gm-on? 1 0)))

(defparameter +master-volume-sub-id-2+ 1)

(defun make-master-volume-sysex-data (&key
                                      coarse
                                      fine
                                      (device-id +all-device-ids+))
  (unless (or coarse fine) (error "No volume specified."))
  (unless (or (and coarse (n-bit-twoscomp-p coarse 7 nil))
              (and fine (n-bit-twoscomp-p fine 14 nil)))
    (error "~a volume ~a is not a ~a-bit value."
           (if fine "Fine" "Course")
           (or coarse fine)
           (if fine "14" "7")))
  (make-sysex-data +real-time-id+ device-id +device-control-sub-id+
   +master-volume-sub-id-2+ (if fine (logand fine 127) coarse)
   (if fine (ash (logand fine 16256) -7) coarse)))

(defparameter +smpte-full-frame-sub-id-2+ 1)

(defparameter +smpte-user-bits-sub-id-2+ 2)

(defparameter +smpte-format-24fps+ 0)

(defparameter +smpte-format-25fps+ 1)

(defparameter +smpte-format-30fps-drop+ 2)

(defparameter +smpte-format-30fps+ 3)

(defun encode-smpte-data (hr mn sc fr &key subframes format)
  (unless (and (<= 0 hr 23)
               (<= 0 mn 59)
               (<= 0 sc 59)
               (<= 0
                   fr
                   (cond ((= format +smpte-format-24fps+) 23)
                         ((= format +smpte-format-25fps+) 24)
                         ((or (= format +smpte-format-30fps-drop+)
                              (= format +smpte-format-30fps+))
                          29)
                         (t
                          (error "Not a valid SMPTE format ID: ~a."
                                 format))))
               (or (not subframes) (<= 0 subframes 99)))
    (error "SMPTE values out of range: ~a ~a ~a ~a ~s."
           hr
           mn
           sc
           fr
           subframes))
  (setf hr (dpb format (byte 3 5) hr))
  (if subframes (list hr mn sc fr subframes) (list hr mn sc fr)))

(defun make-smpte-full-frame-sysex-data (hr
                                         mn
                                         sc
                                         fr
                                         &key
                                         (format
                                          +smpte-format-30fps+)
                                         (device-id
                                          +all-device-ids+))
  (make-sysex-data +real-time-id+ device-id +long-form-mtc-sub-id+
   +smpte-full-frame-sub-id-2+
   (encode-smpte-data hr mn sc fr :format format)))

(defparameter +smpte-user-bits-raw+ 0)

(defparameter +smpte-user-bits-chars+ 2)

(defun make-smpte-user-bits-sysex-data (format
                                        data
                                        &key
                                        (device-id +all-device-ids+))
  (let* ((fmt
          (case format
            ((:raw) 0)
            ((:bytes) 1)
            ((:chars) 2)
            ((:string) 3)
            (t
             (error ":format not one of :raw :bytes :chars :string"))))
         (size (if (= fmt 0) 4 8))
         (len nil)
         (ref nil))
    (cond ((stringp data) (setf len (length data)) (setf ref #'elt))
          ((vectorp data) (setf len (length data)) (setf ref #'elt))
          ((listp data) (setf len (length len)) (setf ref #'elt)))
    (unless (= len (if (= size 4) 8 4))
      (error "~a format requires ~d data bytes, got: ~s."
             format
             (if (= size 4) 8 4)
             data))
    (unless (case fmt
              ((0 1)
               (do ((f t) (i 0 (+ i 1)) (z nil))
                   ((or (not (< i len)) (not f)) f)
                 (setf z (funcall ref data))
                 (setf f (and (integerp z) (<= 0 z size)))))
              ((2)
               (do ((f t) (i 0 (+ i 1)))
                   ((or (not (< i len)) (not f)) f)
                 (setf f (characterp (funcall ref data)))))
              ((3) (stringp data)))
      (error "Not valid ~d-bit data: ~s" size data))
    (flet ((data (n)
             (if (= fmt 0)
                 (funcall ref data n)
                 (let ((d (funcall ref data (floor n 2))))
                   (when (>= fmt 2) (setf d (char-code d)))
                   (if (evenp n)
                       (ash (logand d 240) -4)
                       (logand d 15))))))
      (make-sysex-data +real-time-id+ device-id
       +long-form-mtc-sub-id+ +smpte-user-bits-sub-id-2+
       (funcall data 0) (funcall data 1) (funcall data 2)
       (funcall data 3) (funcall data 4) (funcall data 5)
       (funcall data 6) (funcall data 7)
       (if (= fmt 2)
           +smpte-user-bits-chars+
           +smpte-user-bits-raw+)))))

(defparameter +bar-marker-sub-id-2+ 1)

(defun make-measure-number-sysex-data (num
                                       &key
                                       (countoff nil)
                                       (device-id +all-device-ids+))
  (when countoff (setf num (- (abs num))))
  (setf num (n-bit-twoscomp num 14 t))
  (make-sysex-data +real-time-id+ device-id
   +notation-information-sub-id+ +bar-marker-sub-id-2+
   (ldb (byte 7 0) num) (ldb (byte 7 7) num)))

(defparameter +time-signature-now-sub-id-2+ 2)

(defparameter +time-signature-next-measure-sub-id-2+ 66)

(defun make-time-signature-sysex-data (numerators
                                       denominators
                                       &key
                                       (32nds 8)
                                       (defer nil)
                                       (device-id +all-device-ids+))
  (unless (listp numerators) (setf numerators (list numerators)))
  (unless (listp denominators)
    (setf denominators (list denominators)))
  (let* ((len (max (length numerators) (length denominators)))
         (args
          (loop with f
                and r
                for i from 0
                for n = (or (elt numerators i) n)
                for d = (or (elt denominators i) d)
                repeat len
                do (multiple-value-setq (f r) (floor (log2 d)))
                collect n
                collect (if (not (zerop r))
                            (error "Not a power of 2: ~s" d)
                            f))))
         (make-sysex-data +real-time-id+ device-id
          +notation-information-sub-id+
          (if defer
              +time-signature-next-measure-sub-id-2+
              +time-signature-now-sub-id-2+)
          (1+ (* 2 len)) (first args) (second args) 32nds
          (cdr (cdr args)))))

(defparameter +setup-special-sub-id-2+ 0)

(defparameter +setup-punch-in-point-sub-id-2+ 1)

(defparameter +setup-punch-out-point-sub-id-2+ 2)

(defparameter +setup-delete-punch-in-point-sub-id-2+ 3)

(defparameter +setup-delete-punch-out-point-sub-id-2+ 4)

(defparameter +setup-event-start-point-sub-id-2+ 5)

(defparameter +setup-event-stop-point-sub-id-2+ 6)

(defparameter +setup-xtnd-event-start-point-sub-id-2+ 7)

(defparameter +setup-xtnd-event-stop-point-sub-id-2+ 8)

(defparameter +setup-delete-event-start-point-sub-id-2+ 9)

(defparameter +setup-delete-event-stop-point-sub-id-2+ 10)

(defparameter +setup-cue-point-sub-id-2+ 11)

(defparameter +setup-xtnd-cue-point-sub-id-2+ 12)

(defparameter +setup-delete-cue-point-sub-id-2+ 13)

(defparameter +setup-event-name-sub-id-2+ 14)

(defun %make-setup-data (dev subid2 fmt hr mn sc fr ff num &optional
                         xtnd)
  (make-sysex-data +non-real-time-id+ dev
   +midi-time-code-setup-sub-id+ subid2
   (encode-smpte-data hr mn sc fr :subframes ff :format fmt)
   (cond ((and (listp num) (= (length num) 2))
          (n-bit-twoscomp-p (car num) 7 (< (car num) 0) t)
          (n-bit-twoscomp-p (cadr num) 7 (< (cadr num) 0) t)
          num)
         ((and (vectorp num) (= (length num) 2))
          (n-bit-twoscomp-p (elt num 0) 7 (< (elt num 0) 0) t)
          (n-bit-twoscomp-p (elt num 1) 7 (< (elt num 1) 0) t)
          num)
         (t (n-bit-bytes num 2 7 t)))
   (nibblize t xtnd)))

(defparameter +setup-special-time-code-offset-type+ (quote (0 0)))

(defparameter +setup-special-enable-event-list-type+ (quote (1 0)))

(defparameter +setup-special-disable-event-list-type+ (quote (2 0)))

(defparameter +setup-special-clear-event-list-type+ (quote (3 0)))

(defparameter +setup-special-system-stop-type+ (quote (4 0)))

(defparameter +setup-special-event-list-request-type+ (quote (5 0)))

(defun make-time-code-offset-sysex-data (hr
                                         mn
                                         sc
                                         fr
                                         ff
                                         &key
                                         (format
                                          +smpte-format-30fps+)
                                         (device-id
                                          +all-device-ids+))
  (%make-setup-data device-id +setup-special-sub-id-2+ format hr mn
   sc fr ff +setup-special-time-code-offset-type+))

(defun make-enable-event-list-sysex-data (&key
                                          (device-id
                                           +all-device-ids+))
  (%make-setup-data device-id +setup-special-sub-id-2+ 0 0 0 0 0 0
   +setup-special-enable-event-list-type+))

(defun make-disable-event-list-sysex-data (&key
                                           (device-id
                                            +all-device-ids+))
  (%make-setup-data device-id +setup-special-sub-id-2+ 0 0 0 0 0 0
   +setup-special-disable-event-list-type+))

(defun make-clear-event-list-sysex-data (&key
                                         (device-id
                                          +all-device-ids+))
  (%make-setup-data device-id +setup-special-sub-id-2+ 0 0 0 0 0 0
   +setup-special-clear-event-list-type+))

(defun make-system-stop-sysex-data (hr
                                    mn
                                    sc
                                    fr
                                    ff
                                    &key
                                    (format +smpte-format-30fps+)
                                    (device-id +all-device-ids+))
  (%make-setup-data device-id +setup-special-sub-id-2+ format hr mn
   sc fr ff +setup-special-system-stop-type+))

(defun make-event-list-request-sysex-data (hr
                                           mn
                                           sc
                                           fr
                                           ff
                                           &key
                                           (format
                                            +smpte-format-30fps+)
                                           (device-id
                                            +all-device-ids+))
  (%make-setup-data device-id +setup-special-sub-id-2+ format hr mn
   sc fr ff +setup-special-event-list-request-type+))

(defun make-punch-in-point-sysex-data (track
                                       hr
                                       mn
                                       sc
                                       fr
                                       ff
                                       &key
                                       (format +smpte-format-30fps+)
                                       (device-id +all-device-ids+))
  (%make-setup-data device-id +setup-punch-in-point-sub-id-2+ format
   hr mn sc fr ff track))

(defun make-punch-out-point-sysex-data (track
                                        hr
                                        mn
                                        sc
                                        fr
                                        ff
                                        &key
                                        (format +smpte-format-30fps+)
                                        (device-id +all-device-ids+))
  (%make-setup-data device-id +setup-punch-out-point-sub-id-2+ format
   hr mn sc fr ff track))

(defun make-delete-punch-in-point-sysex-data (track
                                              hr
                                              mn
                                              sc
                                              fr
                                              ff
                                              &key
                                              (format
                                               +smpte-format-30fps+)
                                              (device-id
                                               +all-device-ids+))
  (%make-setup-data device-id +setup-delete-punch-in-point-sub-id-2+
   format hr mn sc fr ff track))

(defun make-delete-punch-out-point-sysex-data (track
                                               hr
                                               mn
                                               sc
                                               fr
                                               ff
                                               &key
                                               (format
                                                +smpte-format-30fps+)
                                               (device-id
                                                +all-device-ids+))
  (%make-setup-data device-id +setup-delete-punch-out-point-sub-id-2+
   format hr mn sc fr ff track))

(defun make-event-start-point-sysex-data (event-nr
                                          hr
                                          mn
                                          sc
                                          fr
                                          ff
                                          &key
                                          (format
                                           +smpte-format-30fps+)
                                          (device-id
                                           +all-device-ids+))
  (%make-setup-data device-id +setup-event-start-point-sub-id-2+
   format hr mn sc fr ff event-nr))

(defun make-event-stop-point-sysex-data (event-nr
                                         hr
                                         mn
                                         sc
                                         fr
                                         ff
                                         &key
                                         (format
                                          +smpte-format-30fps+)
                                         (device-id
                                          +all-device-ids+))
  (%make-setup-data device-id +setup-event-stop-point-sub-id-2+
   format hr mn sc fr ff event-nr))

(defun make-xtnd-event-start-point-sysex-data (event-nr
                                               hr
                                               mn
                                               sc
                                               fr
                                               ff
                                               data
                                               &key
                                               (format
                                                +smpte-format-30fps+)
                                               (device-id
                                                +all-device-ids+))
  (%make-setup-data device-id +setup-xtnd-event-start-point-sub-id-2+
   format hr mn sc fr ff event-nr data))

(defun make-xtnd-event-stop-point-sysex-data (event-nr
                                              hr
                                              mn
                                              sc
                                              fr
                                              ff
                                              data
                                              &key
                                              (format
                                               +smpte-format-30fps+)
                                              (device-id
                                               +all-device-ids+))
  (%make-setup-data device-id +setup-xtnd-event-stop-point-sub-id-2+
   format hr mn sc fr ff event-nr data))

(defun make-delete-event-start-point-sysex-data (event-nr
                                                 hr
                                                 mn
                                                 sc
                                                 fr
                                                 ff
                                                 &key
                                                 (format
                                                  +smpte-format-30fps+)
                                                 (device-id
                                                  +all-device-ids+))
  (%make-setup-data device-id
   +setup-delete-event-start-point-sub-id-2+ format hr mn sc fr ff
   event-nr))

(defun make-delete-event-stop-point-sysex-data (event-nr
                                                hr
                                                mn
                                                sc
                                                fr
                                                ff
                                                &key
                                                (format
                                                 +smpte-format-30fps+)
                                                (device-id
                                                 +all-device-ids+))
  (%make-setup-data device-id
   +setup-delete-event-stop-point-sub-id-2+ format hr mn sc fr ff
   event-nr))

(defun make-cue-point-sysex-data (cue-nr
                                  hr
                                  mn
                                  sc
                                  fr
                                  ff
                                  &key
                                  (format +smpte-format-30fps+)
                                  (device-id +all-device-ids+))
  (%make-setup-data device-id +setup-cue-point-sub-id-2+ format hr mn
   sc fr ff cue-nr))

(defun make-xtnd-cue-point-sysex-data (cue-nr
                                       hr
                                       mn
                                       sc
                                       fr
                                       ff
                                       data
                                       &key
                                       (format +smpte-format-30fps+)
                                       (device-id +all-device-ids+))
  (%make-setup-data device-id +setup-xtnd-cue-point-sub-id-2+ format
   hr mn sc fr ff cue-nr data))

(defun make-delete-cue-point-sysex-data (cue-nr
                                         hr
                                         mn
                                         sc
                                         fr
                                         ff
                                         &key
                                         (format
                                          +smpte-format-30fps+)
                                         (device-id
                                          +all-device-ids+))
  (%make-setup-data device-id +setup-delete-cue-point-sub-id-2+
   format hr mn sc fr ff cue-nr))

(defun make-event-name-sysex-data (event-nr
                                   hr
                                   mn
                                   sc
                                   fr
                                   ff
                                   name
                                   &key
                                   (format +smpte-format-30fps+)
                                   (device-id +all-device-ids+))
  (%make-setup-data device-id +setup-event-name-sub-id-2+ format hr
   mn sc fr ff event-nr name))

(progn (defclass midi-event (event)
         ((opcode :accessor midi-event-opcode :allocation :class)))
       (defparameter <midi-event> (find-class 'midi-event))
       (finalize-class <midi-event>)
       (values))

(defmethod midi-event-data1 ((obj midi-event)) nil)

(defmethod midi-event-data2 ((obj midi-event)) nil)

(progn (defclass midi-channel-event (midi-event)
         ((channel :initform 0 :initarg :channel :accessor
           midi-event-channel)))
       (defparameter <midi-channel-event> (find-class
                                           'midi-channel-event))
       (finalize-class <midi-channel-event>)
       (values))

(progn (defclass midi-system-event (midi-event)
         ((opcode :initform 240)
          (type :initform 0 :initarg :type :accessor
           midi-event-data1)
          (data :initform nil :initarg :data :accessor
           midi-event-data2)))
       (defparameter <midi-system-event> (find-class
                                          'midi-system-event))
       (finalize-class <midi-system-event>)
       (values))

(progn (defclass midi-meta-event (midi-event)
         ((opcode :initform 255)))
       (defparameter <midi-meta-event> (find-class 'midi-meta-event))
       (finalize-class <midi-meta-event>)
       (values))

(defmethod midi-event->midi-message ((event midi-channel-event))
  (values (make-channel-message (slot-value event 'opcode)
           (midi-event-channel event) (midi-event-data1 event)
           (or (midi-event-data2 event) 0))
          nil))

(defmethod midi-event->midi-message ((event midi-system-event))
  (let* ((type (midi-event-data1 event))
         (code (logior 240 type))
         (data (midi-event-data2 event)))
    (cond ((eq type 0) (make-sysex 0 data))
          ((<= 1 type 3)
           (make-system-message 0 code (midi-event-data2 event)))
          (t (make-system-message 0 code)))))

(defmethod midi-event->midi-message ((event midi-meta-event))
  (let ((op (slot-value event 'opcode)))
    (cond ((eq op +ml-file-sequence-number-opcode+)
           (make-sequence-number (midi-event-data1 event)))
          ((eq op +ml-file-text-event-opcode+)
           (make-text-event (midi-event-data2 event)
            (midi-event-data1 event)))
          ((eq op +ml-file-eot-opcode+) (make-eot))
          ((eq op +ml-file-tempo-change-opcode+)
           (make-tempo-change (midi-event-data1 event)))
          ((eq op +ml-file-smpte-offset-opcode+)
           (apply #'make-smpte-offset (midi-event-data1 event)))
          ((eq op +ml-file-time-signature-opcode+)
           (make-time-signature (midi-event-data1 event)
            (midi-event-data2 event) (midi-event-data3 event)
            (midi-event-data4 event)))
          ((eq op +ml-file-key-signature-opcode+)
           (make-key-signature (midi-event-data1 event)
            (midi-event-data2 event)))
          ((eq op +ml-file-sequencer-event-opcode+)
           (make-sequencer-event (midi-event-data1 event)))
          (t (error "Unimplemented meta-event opcode: ~s" op)))))
