From: Graham Grindlay
Subject: parsing MIDI events in LISP?
Date: Tue, 06 May 2003 01:02:43 +0000
Message-ID: <3EB709B3.80900@soe.ucsc.edu> Hi all,
I am looking for some simple lisp code to parse MIDI files into a list
of events. I'm trying to stay away from Common Music as well as any
platform or environment specific stuff. Does anyone know where I might
find some straight CLISP code to do this?
Thanks,
Graham
www.isomorphous.com From: Robert STRANDH
Subject: Re: parsing MIDI events in LISP?
Date: Tue, 06 May 2003 06:13:58 +0000
Message-ID: <6w8ytka9g9.fsf@serveur3.labri.fr> Graham Grindlay <········@soe.ucsc.edu> writes:
> Hi all,
>
> I am looking for some simple lisp code to parse MIDI files into a list
> of events. I'm trying to stay away from Common Music as well as any
> platform or environment specific stuff. Does anyone know where I
> might find some straight CLISP code to do this?
I recently wrote a library for doing exactly that. Here is a
preliminary version. My students have a more recent one with some
bugs fixed that I can mail to anyone interested as soon as I get it.
I would appreciate any comments and bug fixes.
;;; (c) copyright 2003 by Robert Strandh (·······@labri.fr)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of version 2 of the GNU Lesser General
;;; Public License as published by the Free Software Foundation.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;;
;;; This file contains library for MIDI and Midifiles. Messages are
;;; represented as CLOS class instances in a class hierarchy that
;;; reflects interesting aspects of the messages themselves.
(defpackage :midi
(:use :common-lisp))
(export (find-symbol "READ-MIDI-FILE" 'midi) 'midi)
(in-package :midi)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File support
(defparameter *midi-input* nil "stream for reading a Midifile")
(defparameter *input-buffer* '() "used for unreading bytes from *midi-input")
(defparameter *midi-output* nil "stream for writing a Midifile")
(defun read-next-byte ()
"read an unsigned 8-bit byte from *midi-input* checking for unread bytes"
(if *input-buffer*
(pop *input-buffer*)
(read-byte *midi-input*)))
(defun unread-byte (byte)
"unread a byte from *midi-input*"
(push byte *input-buffer*))
(defun write-bytes (&rest bytes)
"write an arbitrary number of bytes to *midi-output*"
(mapc #'(lambda (byte) (write-byte byte *midi-output*)) bytes))
(defun read-fixed-length-quantity (nb-bytes)
"read an unsigned integer of nb-bytes bytes from *midi-input*"
(loop with result = 0
for i from 1 to nb-bytes
do (setf result (logior (ash result 8) (read-next-byte)))
finally (return result)))
(defmacro with-midi-input (filename &body body)
"execute body with *midi-input* assigned to a stream from filename"
`(with-open-file (*midi-input* ,filename
:direction :input :element-type '(unsigned-byte 8))
,@body))
(defmacro with-midi-output (filename &body body)
"execute body with *midi-output* assigned to a stream from filename"
`(with-open-file (*midi-output ,filename
:direction :output :element-type '(unsigned-byte 8))
,@body))
(defun read-variable-length-quantity ()
"read a MIDI variable length quantity from *midi-input*"
(loop with result = 0
with byte
do (setf byte (read-next-byte)
result (logior (ash result 7) (logand byte #x7f)))
until (< byte #x80)
finally (return result)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; MIDI file representation
(defclass midifile ()
((format :initarg :format :reader :midifile-format)
(division :initarg :division :reader :midifile-division)
(tracks :initarg :tracks :reader :midifile-tracks))
(:documentation "the class that represents a Midifile in core"))
(defparameter *status* nil "the (possibly running) status while reading an event")
(defun read-message ()
"read a message without time indication from *midi-input*"
(let ((classname-or-subtype (aref *dispatch-table* *status*)))
(unless classname-or-subtype
(write *status* :base 16))
(if (symbolp classname-or-subtype)
(make-instance classname-or-subtype)
(let* ((data-byte (read-next-byte))
(classname (aref classname-or-subtype data-byte)))
(unless classname
(write data-byte :base 16))
(unread-byte data-byte)
(make-instance classname)))))
(defparameter *time* 0 "accumulated time from the start of the track")
(defun read-timed-message ()
"read a message preceded with a delta-time indication"
(let ((delta-time (read-variable-length-quantity))
(status-or-data (read-next-byte)))
(if (>= status-or-data #x80)
(setf *status* status-or-data)
(unread-byte status-or-data))
(let ((message (read-message)))
(fill-message message)
(setf (message-time message) (incf *time* delta-time))
message)))
(defun read-track (format)
"read a track as a list of timed messages, excluding the end-of-track message"
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4)))
(declare (ignore type length))
(when (= format 1) (setf *time* 0))
(loop with message = nil
do (setf message (read-timed-message))
until (typep message 'end-of-track-message)
collect message)))
(defun read-midi-file (filename)
"read an entire Midifile from the file with name given as argument"
(with-midi-input filename
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4))
(format (read-fixed-length-quantity 2))
(nb-tracks (read-fixed-length-quantity 2))
(division (read-fixed-length-quantity 2)))
(declare (ignore type length))
(make-instance 'midifile
:format format
:division division
:tracks (loop repeat nb-tracks
collect (read-track format))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macro for defining midi messages
(defparameter *dispatch-table* (make-array 256 :initial-element nil)
"given values of status (and perhaps data1), find a class to create")
(defparameter *status-min* (make-hash-table :test #'eq)
"given a class name, find the minimum status value for the type of message")
(defparameter *status-max* (make-hash-table :test #'eq)
"given a class name, find the maximum status value for the type of message")
(defparameter *data-min* (make-hash-table :test #'eq)
"given a class name, find the minimum data1 value for the type of message")
(defparameter *data-max* (make-hash-table :test #'eq)
"given a class name, find the maximum data1 value for the type of message")
(defmacro define-midi-message (name superclasses
&key slots filler writer status-min status-max data-min data-max)
;; assign default values if necessary
(unless status-min
(setf status-min (gethash (car superclasses) *status-min*)))
(unless status-max
(setf status-max (gethash (car superclasses) *status-max*)))
(unless data-min
(setf data-min (gethash (car superclasses) *data-min*)))
(unless data-max
(setf data-max (gethash (car superclasses) *data-max*)))
;; set status values for this class
(setf (gethash name *status-min*) status-min)
(setf (gethash name *status-max*) status-max)
(setf (gethash name *data-min*) data-min)
(setf (gethash name *data-max*) data-max)
;; update the dispatch table
(when status-min
(if data-min
(progn (unless (arrayp (aref *dispatch-table* status-min))
(let ((secondary-dispatch (make-array 256 :initial-element nil)))
(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i) secondary-dispatch))))
(loop for i from data-min to data-max do
(setf (aref (aref *dispatch-table* status-min) i)
name)))
(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i)
name))))
`(progn
(defclass ,name ,superclasses
,slots)
(defmethod fill-message :after ((message ,name))
(with-slots ,(mapcar #'car slots) message
(symbol-macrolet ((next-byte (read-next-byte)))
,filler)))
(defmethod write-message :after ((message ,name))
(with-slots ,(mapcar #'car slots) message
,writer))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; main filler and writer methods
(defmethod fill-message (message)
(declare (ignore message))
nil)
(defmethod write-message (message)
(declare (ignore message))
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; midi messages
(define-midi-message message ()
:slots ((time :accessor message-time)
(status :reader message-status))
:filler (setf status *status*))
(define-midi-message channel-message (message)
:slots ((channel :reader message-channel))
:filler (setf channel (logand *status* #x0f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; voice messages
(define-midi-message voice-message (channel-message))
(define-midi-message note-off-message (voice-message)
:status-min #x80 :status-max #x8f
:slots ((key :reader message-key)
(velocity :reader message-velocity))
:filler (setf key next-byte
velocity next-byte)
:writer (write-bytes key velocity))
(define-midi-message note-on-message (voice-message)
:status-min #x90 :status-max #x9f
:slots ((key :reader message-key)
(velocity :reader message-velocity))
:filler (setf key next-byte
velocity next-byte)
:writer (write-bytes key velocity))
(define-midi-message polyphonic-key-pressure-message (voice-message)
:status-min #xa0 :status-max #xaf
:slots ((key)
(pressure))
:filler (setf key next-byte
pressure next-byte)
:writer (write-bytes key pressure))
(define-midi-message control-change-message (voice-message)
:status-min #xb0 :status-max #xbf
:data-min #x00 :data-max #x78
:slots ((controller)
(value))
:filler (setf controller next-byte
value next-byte)
:writer (write-bytes controller value))
(define-midi-message program-change-message (voice-message)
:status-min #xc0 :status-max #xcf
:slots ((program))
:filler (setf program next-byte)
:writer (write-bytes program))
(define-midi-message channel-pressure-message (voice-message)
:status-min #xd0 :status-max #xdf
:slots ((pressure))
:filler (setf pressure next-byte)
:writer (write-bytes pressure))
(define-midi-message pitch-bend-message (voice-message)
:status-min #xe0 :status-max #xef
:slots ((value))
:filler (setf value (logior (ash next-byte 8) next-byte))
:writer (write-bytes (ash value -8) (logand value #xf)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; mode messages
(define-midi-message mode-message (channel-message)
:filler next-byte)
; consume data byte
(define-midi-message reset-all-controllers-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x79 :data-max #x79
:filler next-byte ; consume unused byte
:writer (write-bytes #x79 0))
(define-midi-message local-control-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7a :data-max #x7a
:slots ((mode))
:filler (setf mode (if (= next-byte 0) :off :on))
:writer (write-bytes #x7a (if (eq mode :off) 0 127)))
(define-midi-message all-notes-off-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7b :data-max #x7b
:filler next-byte ; consume unused byte
:writer (write-bytes #x7b 0))
(define-midi-message omni-mode-off-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7c :data-max #x7c
:filler next-byte ; consume unused byte
:writer (write-bytes #x7c 0))
(define-midi-message omni-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7d :data-max #x7d
:filler next-byte ; consume unused byte
:writer (write-bytes #x7d 0))
(define-midi-message mono-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7e :data-max #x7e
:slots ((nb-channels))
:filler (setf nb-channels next-byte)
:writer (write-bytes #x7e nb-channels))
(define-midi-message poly-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7f :data-max #x7f
:filler next-byte ; consume unused byte
:writer (write-bytes #x7f 0))
(define-midi-message system-message (message))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system common messages
(define-midi-message common-message (system-message))
(define-midi-message timing-code-message (common-message)
:status-min #xf1 :status-max #xf1
:slots ((code))
:filler (setf code next-byte)
:writer (write-bytes code))
(define-midi-message song-position-pointer-message (common-message)
:status-min #xf2 :status-max #xf2
:slots ((pointer))
:filler (setf pointer (logior (ash next-byte 8) next-byte))
:writer (write-bytes (ash pointer -8) (logand pointer #xf)))
(define-midi-message song-select-message (common-message)
:status-min #xf3 :status-max #xf3
:slots ((song))
:filler (setf song next-byte)
:writer (write-bytes song))
(define-midi-message tune-request-message (common-message)
:status-min #xf6 :status-max #xf6)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system real-time messages
(define-midi-message real-time-message (system-message))
(define-midi-message timing-clock-message (real-time-message)
:status-min #xf8 :status-max #xf8)
(define-midi-message start-sequence-message (real-time-message)
:status-min #xfa :status-max #xfa)
(define-midi-message continue-sequence-message (real-time-message)
:status-min #xfb :status-max #xfb)
(define-midi-message stop-sequence-message (real-time-message)
:status-min #xfc :status-max #xfc)
(define-midi-message active-sensing-message (real-time-message)
:status-min #xfe :status-max #xfe)
;; (define-midi-message tune-request-message (real-time-message)
;; :status-min #xf6 :status-max #xf6)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system exclusive messages
(define-midi-message system-exclusive-message (system-message)
:status-min #xf0 :status-max #xf0
:filler (loop until (= next-byte #xf7))
:writer (write-bytes #xf7))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; midi file messages
(define-midi-message midifile-message (message)
:status-min #xff :status-max #xff
:filler next-byte)
(define-midi-message sequence-number-message (midifile-message)
:data-min #x00 :data-max #x00
:slots ((sequence))
:filler (let ((data2 next-byte))
(setf sequence (if (zerop data2)
0
(logior (ash next-byte 8) next-byte))))
:writer (if (zerop sequence)
(write-bytes 0)
(write-bytes (ash sequence -8) (logand sequence #xf))))
(define-midi-message text-message (midifile-message)
:slots ((text))
:filler (setf text (loop with len = next-byte
with str = (make-string len)
for i from 0 below len
do (setf (aref str i)
(code-char next-byte))
finally (return str)))
:writer (map nil (lambda (char) (write-bytes (char-code char)))
text))
; FIXME
(define-midi-message general-text-message (text-message)
:data-min #x01 :data-max #x01)
(define-midi-message copyright-message (text-message)
:data-min #x02 :data-max #x02)
(define-midi-message sequence/track-name-message (text-message)
:data-min #x03 :data-max #x03)
(define-midi-message instrument-message (text-message)
:data-min #x04 :data-max #x04)
(define-midi-message lyric-message (text-message)
:data-min #x05 :data-max #x05)
(define-midi-message marker-message (text-message)
:data-min #x06 :data-max #x06)
(define-midi-message cue-point-message (text-message)
:data-min #x07 :data-max #x07)
(define-midi-message program-name-message (text-message)
:data-min #x08 :data-max #x08)
(define-midi-message device-name-message (text-message)
:data-min #x09 :data-max #x09)
(define-midi-message channel-prefix-message (midifile-message)
:data-min #x20 :data-max #x20
:slots ((channel))
:filler (progn next-byte (setf channel next-byte)))
(define-midi-message end-of-track-message (midifile-message)
:data-min #x2f :data-max #x2f
:filler next-byte
:writer (write-bytes #x2f 0))
(define-midi-message tempo-message (midifile-message)
:data-min #x51 :data-max #x51
:slots ((tempo :reader message-tempo))
:filler (progn next-byte (setf tempo (read-fixed-length-quantity 3)))
:writer nil)
; FIXME
(define-midi-message smpte-offset-message (midifile-message)
:data-min #x54 :data-max #x54
:slots ((hr) (mn) (se) (fr) (ff))
:filler (progn next-byte (setf hr next-byte mn next-byte se next-byte
fr next-byte ff next-byte))
:writer (write-bytes #x54 hr mn se fr ff))
(define-midi-message time-signature-message (midifile-message)
:data-min #x58 :data-max #x58
:slots ((nn :reader message-numerator)
(dd :reader message-denominator)
(cc) (bb))
:filler (progn next-byte (setf nn next-byte dd next-byte
cc next-byte bb next-byte))
:writer (write-bytes #x58 nn dd cc bb))
(define-midi-message key-signature-message (midifile-message)
:data-min #x59 :data-max #x59
:slots ((sf) (mi))
:filler (progn next-byte (setf sf next-byte mi next-byte))
:writer (write-bytes #x59 sf mi))
(define-midi-message proprietary-event (midifile-message)
:data-min #x7f :data-max #x7f
:slots ((data))
:filler (setf data (loop with len = (read-variable-length-quantity)
with vec = (make-array len :element-type '(unsigned-byte 8))
for i from 0 below len
do (setf (aref vec i) next-byte)
finally (return vec)))
:writer (map nil (lambda (byte) (write-bytes byte))
data))
; FIXME
--
Robert Strandh
---------------------------------------------------------------------
Greenspun's Tenth Rule of Programming: any sufficiently complicated C
or Fortran program contains an ad hoc informally-specified bug-ridden
slow implementation of half of Common Lisp.
--------------------------------------------------------------------- From: Robert STRANDH
Subject: Re: parsing MIDI events in LISP?
Date: Wed, 07 May 2003 05:57:30 +0000
Message-ID: <6wfznrl2np.fsf@serveur3.labri.fr> Robert STRANDH <·······@labri.fr> writes:
> I recently wrote a library for doing exactly that. Here is a
> preliminary version. My students have a more recent one with some
> bugs fixed that I can mail to anyone interested as soon as I get it.
> I would appreciate any comments and bug fixes.
Here is a newer version :
;;; (c) copyright 2003 by Mathieu Chabanne, Camille Constant,
;;; Emmanuel Necibar and Stephanie Recco
;;; Corrected and modified when it is mentionned.
;;;
;;; (c) copyright 2003 by Robert Strandh (·······@labri.fr)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of version 2 of the GNU Lesser General
;;; Public License as published by the Free Software Foundation.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;;
;;; This file contains library for MIDI and Midifiles. Messages are
;;; represented as CLOS class instances in a class hierarchy that
;;; reflects interesting aspects of the messages themselves.
(defpackage :midi
(:use :common-lisp)
(:export "READ-MIDI-FILE"
"MIDIFILE-FORMAT" "MIDIFILE-TRACKS" "MIDIFILE-DIVISION"
"MESSAGE" "NOTE-OFF-MESSAGE" "NOTE-ON-MESSAGE" "TEMPO-MESSAGE"
"KEY-SIGNATURE-MESSAGE" "TIME-SIGNATURE-MESSAGE"
"SMPTE-OFFSET-MESSAGE"
"MESSAGE-CHANNEL" "MESSAGE-KEY" "MESSAGE-TIME"
"MESSAGE-VELOCITY" "MESSAGE-NUMERATOR" "MESSAGE-DENOMINATOR"
"MESSAGE-SF" "MESSAGE-MI" "MESSAGE-TEMPO"
"HEADER" "HEADER-TYPE"
"UNKNOWN-EVENT" "STATUS" "DATA-BYTE"))
(in-package :midi)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File support
;; modified
(defconstant *header-mthd* 1297377380 "decimal value of the string MThd")
(defconstant *header-mtrk* 1297379947 "decimal value of the string MTrk")
(defconstant *header-mthd-length* 6 "value of the header MThd data's length")
(defparameter *midi-input* nil "stream for reading a Midifile")
(defparameter *input-buffer* '() "used for unreading bytes from *midi-input")
(defparameter *midi-output* nil "stream for writing a Midifile")
;; modified
(define-condition unknown-event ()
((status :initarg :status :reader status)
(data-byte :initform "" :initarg :data-byte :reader data-byte))
(:documentation "condition when the event does not exist in the library"))
;; modified
(define-condition header ()
((header-type :initarg :header :reader header-type))
(:documentation "condition when the header is not correct"))
(defun read-next-byte ()
"read an unsigned 8-bit byte from *midi-input* checking for unread bytes"
(if *input-buffer*
(pop *input-buffer*)
(read-byte *midi-input*)))
(defun unread-byte (byte)
"unread a byte from *midi-input*"
(push byte *input-buffer*))
(defun write-bytes (&rest bytes)
"write an arbitrary number of bytes to *midi-output*"
(mapc #'(lambda (byte) (write-byte byte *midi-output*)) bytes))
(defun read-fixed-length-quantity (nb-bytes)
"read an unsigned integer of nb-bytes bytes from *midi-input*"
(loop with result = 0
for i from 1 to nb-bytes
do (setf result (logior (ash result 8) (read-next-byte)))
finally (return result)))
(defmacro with-midi-input (filename &body body)
"execute body with *midi-input* assigned to a stream from filename"
`(with-open-file (*midi-input* ,filename
:direction :input :element-type '(unsigned-byte 8))
,@body))
(defmacro with-midi-output (filename &body body)
"execute body with *midi-output* assigned to a stream from filename"
`(with-open-file (*midi-output* ,filename
:direction :output :element-type '(unsigned-byte 8))
,@body))
(defun read-variable-length-quantity ()
"read a MIDI variable length quantity from *midi-input*"
(loop with result = 0
with byte
do (setf byte (read-next-byte)
result (logior (ash result 7) (logand byte #x7f)))
until (< byte #x80)
finally (return result)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; MIDI file representation
(defclass midifile ()
((format :initarg :format :reader midifile-format)
(division :initarg :division :reader midifile-division)
(tracks :initarg :tracks :reader midifile-tracks))
(:documentation "the class that represents a Midifile in core"))
(defparameter *status* nil "the status while reading an event")
;; modified
(defparameter *running-status* nil "the running status while reading an event")
;; modified
(defun read-message ()
"read a message without time indication from *midi-input*"
(let ((classname-or-subtype (aref *dispatch-table* *status*)))
(unless classname-or-subtype
(error (make-condition 'unknown-event
:status *status*)))
(if (symbolp classname-or-subtype)
(make-instance classname-or-subtype)
(let* ((data-byte (read-next-byte))
(classname (aref classname-or-subtype data-byte)))
(unless classname
(error (make-condition 'unknown-event
:status *status*
:data-byte data-byte)))
(unread-byte data-byte)
(make-instance classname)))))
(defparameter *time* 0 "accumulated time from the start of the track")
;; modified
(defun read-timed-message ()
"read a message preceded with a delta-time indication"
(let ((delta-time (read-variable-length-quantity))
(status-or-data (read-next-byte)))
(if (>= status-or-data #x80)
(progn (setf *status* status-or-data)
(when (<= *status* #xef)
(setf *running-status* *status*)))
(progn (unread-byte status-or-data)
(setf *status* *running-status*)))
(let ((message (read-message)))
(fill-message message)
(setf (message-time message) (incf *time* delta-time))
message)))
;; modified
(defun read-track ()
"read a track as a list of timed messages, excluding the end-of-track message"
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4)))
(declare (ignore length))
(unless (= type *header-mtrk*)
(error (make-condition 'header :header "MTrk")))
(loop with message = nil
do (setf message (read-timed-message))
until (typep message 'end-of-track-message)
collect message)))
;; modified
(defun read-midi-file (filename)
"read an entire Midifile from the file with name given as argument"
(setf *time* 0)
(with-midi-input filename
(let ((type (read-fixed-length-quantity 4))
(length (read-fixed-length-quantity 4))
(format (read-fixed-length-quantity 2))
(nb-tracks (read-fixed-length-quantity 2))
(division (read-fixed-length-quantity 2)))
(unless (and (= length *header-mthd-length*) (= type *header-mthd*))
(error (make-condition 'header :header "MThd")))
(make-instance 'midifile
:format format
:division division
:tracks (loop repeat nb-tracks
do (when (= format 1) (setf *time* 0))
collect (read-track))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macro for defining midi messages
(defparameter *dispatch-table* (make-array 256 :initial-element nil)
"given values of status (and perhaps data1), find a class to create")
(defparameter *status-min* (make-hash-table :test #'eq)
"given a class name, find the minimum status value for the type of message")
(defparameter *status-max* (make-hash-table :test #'eq)
"given a class name, find the maximum status value for the type of message")
(defparameter *data-min* (make-hash-table :test #'eq)
"given a class name, find the minimum data1 value for the type of message")
(defparameter *data-max* (make-hash-table :test #'eq)
"given a class name, find the maximum data1 value for the type of message")
(defun register-class (class superclass status-min status-max data-min data-max)
(unless status-min
(setf status-min (gethash superclass *status-min*)))
(unless status-max
(setf status-max (gethash superclass *status-max*)))
(unless data-min
(setf data-min (gethash superclass *data-min*)))
(unless data-max
(setf data-max (gethash superclass *data-max*)))
;; set status values for this class
(setf (gethash class *status-min*) status-min)
(setf (gethash class *status-max*) status-max)
(setf (gethash class *data-min*) data-min)
(setf (gethash class *data-max*) data-max)
;; update the dispatch table
(when status-min
(if data-min
(progn (unless (arrayp (aref *dispatch-table* status-min))
(let ((secondary-dispatch (make-array 256
:initial-element nil)))
(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i) secondary-dispatch))))
(loop for i from data-min to data-max do
(setf (aref (aref *dispatch-table* status-min) i)
class)))
(loop for i from status-min to status-max do
(setf (aref *dispatch-table* i)
class)))))
(defmacro define-midi-message (name superclasses
&key slots filler writer
status-min status-max data-min data-max)
`(progn
(register-class ',name ',(car superclasses)
,status-min ,status-max ,data-min ,data-max)
(defclass ,name ,superclasses
,slots)
(defmethod fill-message :after ((message ,name))
(with-slots ,(mapcar #'car slots) message
(symbol-macrolet ((next-byte (read-next-byte)))
,filler)))
(defmethod write-message :after ((message ,name))
(with-slots ,(mapcar #'car slots) message
,writer))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; main filler and writer methods
(defmethod fill-message (message)
(declare (ignore message))
nil)
(defmethod write-message (message)
(declare (ignore message))
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; midi messages
(define-midi-message message ()
:slots ((time :accessor message-time)
(status :reader message-status))
:filler (setf status *status*))
(define-midi-message channel-message (message)
:slots ((channel :reader message-channel))
:filler (setf channel (logand *status* #x0f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; voice messages
(define-midi-message voice-message (channel-message))
(define-midi-message note-off-message (voice-message)
:status-min #x80 :status-max #x8f
:slots ((key :reader message-key)
(velocity :reader message-velocity))
:filler (setf key next-byte
velocity next-byte)
:writer (write-bytes key velocity))
;; modified
(define-midi-message note-on-message (voice-message)
:status-min #x90 :status-max #x9f
:slots ((key :reader message-key)
(velocity :reader message-velocity))
:filler (setf key next-byte
velocity next-byte)
:writer (write-bytes key velocity))
(define-midi-message polyphonic-key-pressure-message (voice-message)
:status-min #xa0 :status-max #xaf
:slots ((key)
(pressure))
:filler (setf key next-byte
pressure next-byte)
:writer (write-bytes key pressure))
(define-midi-message control-change-message (voice-message)
:status-min #xb0 :status-max #xbf
:data-min #x00 :data-max #x78
:slots ((controller)
(value))
:filler (setf controller next-byte
value next-byte)
:writer (write-bytes controller value))
(define-midi-message program-change-message (voice-message)
:status-min #xc0 :status-max #xcf
:slots ((program))
:filler (setf program next-byte)
:writer (write-bytes program))
(define-midi-message channel-pressure-message (voice-message)
:status-min #xd0 :status-max #xdf
:slots ((pressure))
:filler (setf pressure next-byte)
:writer (write-bytes pressure))
(define-midi-message pitch-bend-message (voice-message)
:status-min #xe0 :status-max #xef
:slots ((value))
:filler (setf value (logior (ash next-byte 8) next-byte))
:writer (write-bytes (ash value -8) (logand value #xf)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; mode messages
(define-midi-message mode-message (channel-message)
:filler next-byte)
; consume data byte
(define-midi-message reset-all-controllers-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x79 :data-max #x79
:filler next-byte ; consume unused byte
:writer (write-bytes #x79 0))
(define-midi-message local-control-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7a :data-max #x7a
:slots ((mode))
:filler (setf mode (if (= next-byte 0) :off :on))
:writer (write-bytes #x7a (if (eq mode :off) 0 127)))
(define-midi-message all-notes-off-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7b :data-max #x7b
:filler next-byte ; consume unused byte
:writer (write-bytes #x7b 0))
(define-midi-message omni-mode-off-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7c :data-max #x7c
:filler next-byte ; consume unused byte
:writer (write-bytes #x7c 0))
(define-midi-message omni-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7d :data-max #x7d
:filler next-byte ; consume unused byte
:writer (write-bytes #x7d 0))
(define-midi-message mono-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7e :data-max #x7e
:slots ((nb-channels))
:filler (setf nb-channels next-byte)
:writer (write-bytes #x7e nb-channels))
(define-midi-message poly-mode-on-message (mode-message)
:status-min #xb0 :status-max #xbf
:data-min #x7f :data-max #x7f
:filler next-byte ; consume unused byte
:writer (write-bytes #x7f 0))
(define-midi-message system-message (message))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system common messages
(define-midi-message common-message (system-message))
(define-midi-message timing-code-message (common-message)
:status-min #xf1 :status-max #xf1
:slots ((code))
:filler (setf code next-byte)
:writer (write-bytes code))
(define-midi-message song-position-pointer-message (common-message)
:status-min #xf2 :status-max #xf2
:slots ((pointer))
:filler (setf pointer (logior (ash next-byte 8) next-byte))
:writer (write-bytes (ash pointer -8) (logand pointer #xf)))
(define-midi-message song-select-message (common-message)
:status-min #xf3 :status-max #xf3
:slots ((song))
:filler (setf song next-byte)
:writer (write-bytes song))
(define-midi-message tune-request-message (common-message)
:status-min #xf6 :status-max #xf6)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system real-time messages
(define-midi-message real-time-message (system-message))
(define-midi-message timing-clock-message (real-time-message)
:status-min #xf8 :status-max #xf8)
(define-midi-message start-sequence-message (real-time-message)
:status-min #xfa :status-max #xfa)
(define-midi-message continue-sequence-message (real-time-message)
:status-min #xfb :status-max #xfb)
(define-midi-message stop-sequence-message (real-time-message)
:status-min #xfc :status-max #xfc)
(define-midi-message active-sensing-message (real-time-message)
:status-min #xfe :status-max #xfe)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; system exclusive messages
;; modified
(define-midi-message system-exclusive-message (system-message)
:status-min #xf0 :status-max #xf0
:filler (loop with len = (read-variable-length-quantity)
with data = (read-fixed-length-quantity (1- len))
until (= next-byte #xf7)
do
next-byte
(setf len (read-variable-length-quantity)
data (read-fixed-length-quantity (1- len))))
:writer nil)
; FIXME
;; modified
(define-midi-message authorization-system-exclusive-message (system-message)
:status-min #xf7 :status-max #xf7
:filler (read-fixed-length-quantity (read-variable-length-quantity))
:writer nil)
; FIXME
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; meta messages
(define-midi-message meta-message (message)
:status-min #xff :status-max #xff
:filler next-byte)
;; modified
(define-midi-message sequence-number-message (meta-message)
:data-min #x0 :data-max #x0
:slots ((sequence))
:filler (let ((data2 next-byte))
(setf sequence (if (zerop data2)
0
(logior (ash next-byte 8) next-byte))))
:writer (if (zerop sequence)
(write-bytes 0)
(write-bytes (ash sequence -8) (logand sequence #xf))))
(define-midi-message text-message (meta-message)
:slots ((text))
:filler (setf text (loop with len = next-byte
with str = (make-string len)
for i from 0 below len
do (setf (aref str i)
(code-char next-byte))
finally (return str)))
:writer (map nil (lambda (char) (write-bytes (char-code char)))
text))
; FIXME
(define-midi-message general-text-message (text-message)
:data-min #x01 :data-max #x01)
(define-midi-message copyright-message (text-message)
:data-min #x02 :data-max #x02)
(define-midi-message sequence/track-name-message (text-message)
:data-min #x03 :data-max #x03)
(define-midi-message instrument-message (text-message)
:data-min #x04 :data-max #x04)
(define-midi-message lyric-message (text-message)
:data-min #x05 :data-max #x05)
(define-midi-message marker-message (text-message)
:data-min #x06 :data-max #x06)
(define-midi-message cue-point-message (text-message)
:data-min #x07 :data-max #x07)
(define-midi-message program-name-message (text-message)
:data-min #x08 :data-max #x08)
(define-midi-message device-name-message (text-message)
:data-min #x09 :data-max #x09)
(define-midi-message channel-prefix-message (meta-message)
:data-min #x20 :data-max #x20
:slots ((channel))
:filler (progn next-byte (setf channel next-byte)))
;; modified
(define-midi-message midi-port-message (meta-message)
:data-min #x21 :data-max #x21
:slots ((port))
:filler (progn next-byte (setf port next-byte)))
(define-midi-message end-of-track-message (meta-message)
:data-min #x2f :data-max #x2f
:filler next-byte
:writer (write-bytes #x2f 0))
;; modified
(define-midi-message tempo-message (meta-message)
:data-min #x51 :data-max #x51
:slots ((tempo :reader message-tempo))
:filler (progn next-byte (setf tempo (read-fixed-length-quantity 3)))
:writer nil)
; FIXME
(define-midi-message smpte-offset-message (meta-message)
:data-min #x54 :data-max #x54
:slots ((hr) (mn) (se) (fr) (ff))
:filler (progn next-byte (setf hr next-byte mn next-byte se next-byte
fr next-byte ff next-byte))
:writer (write-bytes #x54 hr mn se fr ff))
;; modified
(define-midi-message time-signature-message (meta-message)
:data-min #x58 :data-max #x58
:slots ((nn :reader message-numerator)
(dd :reader message-denominator)
(cc) (bb))
:filler (progn next-byte (setf nn next-byte dd next-byte
cc next-byte bb next-byte))
:writer (write-bytes #x58 nn dd cc bb))
;; modified
(define-midi-message key-signature-message (meta-message)
:data-min #x59 :data-max #x59
:slots ((sf :reader message-sf) (mi :reader message-mi))
:filler (progn next-byte (setf sf (let ((temp-sf next-byte))
(if (> temp-sf 127)
(- temp-sf 256)
temp-sf))
mi next-byte))
:writer (write-bytes #x59 sf mi))
(define-midi-message proprietary-event (meta-message)
:data-min #x7f :data-max #x7f
:slots ((data))
:filler (setf data (loop with len = (read-variable-length-quantity)
with vec = (make-array
len
:element-type '(unsigned-byte 8))
for i from 0 below len
do (setf (aref vec i) next-byte)
finally (return vec)))
:writer (map nil (lambda (byte) (write-bytes byte))
data))
; FIXME
--
Robert Strandh
---------------------------------------------------------------------
Greenspun's Tenth Rule of Programming: any sufficiently complicated C
or Fortran program contains an ad hoc informally-specified bug-ridden
slow implementation of half of Common Lisp.
---------------------------------------------------------------------