midi.el pre-release

[Mario Lang]

Hi.

This is a pre-release of midi.el intended for review
by interested people.  Patches welcome.

;;; midi.el --- MIDI

;; Copyright (C) 2005  Free Software Foundation, Inc.

;; Author: Mario Lang <address@hidden>
;; Keywords: multimedia, files

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file 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.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; A mode for editing MIDI files

;;; Code:

(require 'cl)


;;; Standard MIDI file reader

(defsubst smf-read-byte ()
  (forward-char 1) (preceding-char))

(defun smf-read-bytes (count)
  (let ((val 0))
    (dotimes (i count val)
      (setq val (logior (lsh val 8) (smf-read-byte))))))

(defun smf-read-varlen ()
  (do* ((b (smf-read-byte)) (n (logand b #B01111111)))
      ((/= (logand b #B10000000) #B10000000) n)
    (setq b (smf-read-byte) n (logior (ash n 7) (logand b #B01111111)))))

(defun smf-read-string ()
  (let ((length (smf-read-varlen)))
    (buffer-substring (point) (progn (forward-char length) (point)))))

(defun smf-read-meta-event ()
  (case (smf-read-byte)
    (#X01 (list 'Text (smf-read-string)))
    (#X02 (list 'Copyright (smf-read-string)))
    (#X03 (list 'TrackName (smf-read-string)))
    (#X04 (list 'Instrument (smf-read-string)))
    (#X05 (list 'Lyric (smf-read-string)))
    (#X06 (list 'Marker (smf-read-string)))
    (#X07 (list 'CuePoint (smf-read-string)))
    (#X08 (list 'PatchName (smf-read-string)))
    (#X09 (list 'DeviceName (smf-read-string)))
    (#X21 (list 'UnknownMetaEvent (smf-read-string)))
    (#X2F (if (= (smf-read-byte) 0)
              t
            (error "suspicious EOT")))
    (#X51 (if (= (smf-read-byte) 3)
              (list 'TempoChange (smf-read-bytes 3))
            (error "suspicious TempoChange")))
    (#X54 (if (= (smf-read-byte) 5)
              (let ((hour (smf-read-byte))
                    (minute (smf-read-byte))
                    (second (smf-read-byte))
                    (frame (smf-read-byte))
                    (subframe (smf-read-byte)))
                (list 'SMPTEOffset hour minute second frame subframe))
            (error "suspicious SMPTE Offset")))
    (#X58 (if (= (smf-read-byte) 4)
              (let ((numerator (smf-read-byte))
                    (denominator (expt 2 (smf-read-byte)))
                    (cc (smf-read-byte))
                    (bb (smf-read-byte)))
                (list 'TimeSig numerator denominator cc bb))
            (error "suspicious TimeSig")))
    (#X59 (if (= (smf-read-byte) 2)
              (let ((sf (smf-read-byte))
                    (mi (smf-read-byte)))
                (list 'KeySig sf mi))
            (error "suspicious KeySig")))
    (#X7F (list 'Proprietary (smf-read-string)))
    (t (error "unhandled meta event %d" (char-before)))))

(defun smf-read-mtrk (length)
  "Read one MTrk chunk. NoteOn/NoteOff and NoteOn/NoteOn(vel=0) event
pairs are unified into a Note event with a certain duration."
  (let ((end (+ (point) length))
        (notes (make-vector 16 nil))
        (ticks 0) (running-status 0))
    (dotimes (i 16) (aset notes i (make-vector 128 nil)))
    (loop while (< (point) end)
          do (incf ticks (smf-read-varlen))
          for event =
          (let ((status (following-char)))
            (if (/= (logand status #B10000000) #B10000000)
                (if (= running-status 0)
                    (error "Seen data byte without running status")
                  (setq status running-status))
              (forward-char 1))
            (unless (= status #XFF) (setq running-status status))
            (let ((lower (logand status #X0F)))
              (case (ash status -4)
                (8  (let* ((note (smf-read-byte)) (vel (smf-read-byte))
                           (old-note (aref (aref notes lower) note)))
                      (if (not old-note)
                          (list 'NoteOff lower note vel)
                        (setcar (cdr old-note) 'Note)
                        (setcdr (nthcdr 4 old-note)
                                (list (- ticks (car old-note)) vel))
                        (aset (aref notes lower) note nil))))
                (9  (let* ((note (smf-read-byte)) (vel (smf-read-byte))
                           (data (cons ticks (list 'NoteOn lower note vel))))
                      (if (= vel 0)
                          (let ((old-note (aref (aref notes lower) note)))
                            (if (not old-note)
                                (cdr data)
                              (setcar (cdr old-note) 'Note)
                              (setcdr (nthcdr 4 old-note)
                                      (list (- ticks (car old-note))))
                              (aset (aref notes lower) note nil)))
                        (cdr (aset (aref notes lower) note data)))))
                (10 (list 'At lower (smf-read-byte) (smf-read-byte)))
                (11 (list 'CC lower (smf-read-byte) (smf-read-byte)))
                (12 (list 'PC lower (smf-read-byte)))
                (13 (list 'CP lower (smf-read-byte)))
                (14 (list 'PW lower (logior (smf-read-byte)
                                            (lsh (smf-read-byte) 7))))
                (15 (case lower
                      (2  (let ((value (logior (smf-read-byte)
                                               (lsh (smf-read-byte) 7))))
                            (list 'SongPosition value)))
                      (3  (list 'SongSelect (smf-read-byte)))
                      (6  (list 'TuneRequest))
                      (8  (list 'Clock))
                      (9  (list 'Tick))
                      (10 (list 'Start))
                      (11 (list 'Continue))
                      (12 (list 'Stop))
                      (14 (list 'ActiveSense))
                      (15 (smf-read-meta-event)))))))
          until (eq event t) when event collect (cons ticks event))))

(defun smf-read ()
  (goto-char (point-min))
  (message "Parsing MIDI data...")
  (let ((inhibit-point-motion-hooks t)
        (id (buffer-substring (point) (progn (forward-char 4) (point))))
        (length (smf-read-bytes 4)))
    (unless (and (string= id "MThd") (= length 6))
      (error "Not a Stnadard MIDI file"))
    (let ((type (smf-read-bytes 2))
          (numtracks (smf-read-bytes 2))
          (ppqn (smf-read-bytes 2))
          chunks)
      (when (and (= type 0) (/= numtracks 1))
        (error "type 0 file with more than 1 track"))
      (while (not (eobp))
        (setq id (buffer-substring (point) (progn (forward-char 4) (point)))
              length (smf-read-bytes 4))
        (setq chunks
              (nconc chunks
                     (list
                      (cons
                       id
                       (if (string= id "MTrk")
                           (progn
                             (setq numtracks (1- numtracks))
                             (smf-read-mtrk length))
                         (buffer-substring
                          (point) (progn (forward-char length) (point)))))))))
      (assert (= numtracks 0))
      (message "Parsing MIDI data...done")
      (append (list type ppqn) chunks))))


;;; Standard MIDI file writer

(defun smf-write-bytes (value count)
  (let (bytes)
    (dotimes (i count (apply #'insert bytes))
      (push (logand value '#XFF) bytes)
      (setq value (ash value -8)))))

(defun smf-write-varlen (value)
  (loop for bits from 21 downto 7 by 7
        when (>= value (expt 2 bits))
        do (insert-char (logior (logand (ash value (- bits)) 127) 128) 1))
  (insert-char (logand value 127) 1))

(defun smf-write-string (string)
  (smf-write-varlen (length string))
  (insert string))

(defvar smf-unhandled-types nil) ;;REMOVE ME
(defun smf-write (data)
  (if enable-multibyte-characters
      (error "Unabl3e to insert MIDI file data in multibyte buffer")
    (message "Encoding MIDI data...")
    (destructuring-bind (type ppqn &rest tracks) data
      (let ((inhibit-modification-hooks t)
            (inhibit-point-motion-hooks t)
            (one-percent (/ (apply #'+ (mapcar (lambda (track) (length (cdr 
track))) tracks)) 100))
            (events-written 0))
        (insert "MThd") (smf-write-bytes 6 4)
        (smf-write-bytes type 2)
        (smf-write-bytes (length tracks) 2)
        (smf-write-bytes ppqn 2)
        (mapc
         (lambda (track)
           (insert "MTrk")
           (let ((size-pos (point))
                 (tick 0)
                 notes-on)
             (mapc
              (lambda (event)
                (destructuring-bind (newtick type &rest data) event
                  (setq notes-on
                        (remove-if
                         (lambda (info)
                           (when (>= newtick (car info))
                             (smf-write-varlen (- (car info) tick))
                             (setq tick (car info))
                             (insert (logior #X80 (nth 1 info))
                                     (nth 2 info) (nth 3 info))
                             t))
                         notes-on))
                  (smf-write-varlen (- newtick tick))
                  (setq tick newtick)
                  (case type
                    (Note        (insert (logior #X90 (car data))
                                         (nth 1 data) (nth 2 data))
                                 (setq notes-on (sort (cons (list
                                                             (+ tick (nth 3 
data))
                                                             (nth 0 data) (nth 
1 data)
                                                             (or (nth 4 data) 
0))
                                                            notes-on)
                                                      #'car-less-than-car)))
                    (NoteOn      (insert (logior #X90 (car data))
                                         (nth 1 data) (nth 2 data)))
                    (NoteOff     (insert (logior #X80 (car data))
                                         (nth 1 data) (nth 2 data)))
                    (CC          (insert (logior #XB0 (car data))
                                         (nth 1 data) (nth 2 data)))
                    (PC          (insert (logior #XC0 (car data)) (nth 1 data)))
                    (PW          (insert (logior #XE0 (car data)) (logand (nth 
1 data) #B01111111) (logand (lsh (nth 1 data) -7) #B01111111)))
                    (UnknownMetaEvent (insert #XFF #X21) (smf-write-string (nth 
0 data)))
                    (TempoChange (insert #XFF #X51 3) (smf-write-bytes (car 
data) 3))
                    (SMPTEOffset (insert #XFF #X54 5 (nth 0 data) (nth 1 data) 
(nth 2 data) (nth 3 data) (nth 4 data)))
                    (TimeSig     (insert #XFF #X58 4
                                         (nth 0 data) (round (log (nth 1 data) 
2))
                                         (nth 2 data) (nth 3 data)))
                    (KeySig      (insert #XFF #X59 2 (nth 0 data) (nth 1 data)))
                    (Text        (insert #XFF #X01) (smf-write-string (nth 0 
data)))
                    (TrackName   (insert #XFF #X03) (smf-write-string (nth 0 
data)))
                    (Marker      (insert #XFF #X06) (smf-write-string (nth 0 
data)))
                    (Proprietary (insert #XFF #X7F) (smf-write-string (nth 0 
data)))
                    (t (setq smf-unhandled-types (cons type 
smf-unhandled-types))))
                  (incf events-written)
                  (if (= (% events-written one-percent) 0)
                      (message "Encoding MIDI data...%d%%"
                               (round (/ events-written one-percent))))))
              (cdr track))
             (mapc
              (lambda (info)
                (smf-write-varlen (- (car info) tick))
                (setq tick (car info))
                (insert (logior #X80 (nth 1 info)) (nth 2 info) (nth 3 info)))
              notes-on)
             (smf-write-varlen tick) (insert #XFF #X2F 0)
             (let ((size (- (point) size-pos)))
               (save-excursion
                 (goto-char size-pos)
                 (smf-write-bytes size 4)))))
         tracks)))
    (message "Encoding MIDI data...done")))


;;; Ticks

(defun smf-gcd (data)
  (apply #'gcd
         (loop for ticks in
               (loop for track in (cddr data)
                     collect (mapcar #'car (cdr track)))
               when (> (apply #'max ticks) 0) collect (apply #'gcd ticks))))

(defun smf-apply-event-time-operation (tracks operator arg)
  (mapcar (lambda (track)
            (cons (car track)
                  (mapcar (lambda (event)
                            (append (list (funcall operator (nth 0 event) arg))
                                    (case (nth 1 event)
                                      (Note (list 'Note
                                                  (nth 2 event)
                                                  (nth 3 event)
                                                  (nth 4 event)
                                                  (funcall operator
                                                           (nth 5 event) arg)
                                                  (nth 6 event)))
                                      (t (cdr event)))))
                          (cdr track))))
          tracks))

(defun smf-ticks-divide (data amount)
  (append (list (nth 0 data) (/ (nth 1 data) amount))
          (smf-apply-event-time-operation (cddr data) #'/ amount)))
        
(defun smf-use-smallest-ppqn (data)
  (smf-ticks-divide data (smf-gcd data)))


;;; Tempo

(defun smf-make-tempo-map (&rest tracks)
  "Create a \"virtual\" track with tempo and time signature information."
  (sort (apply #'append (loop for track in tracks collect
                              (loop for event in (cdr track) when
                                    (or (eq (nth 1 event) 'TempoChange)
                                        (eq (nth 1 event) 'TimeSig))
                                    collect event))) #'car-less-than-car))

(defun smf-format-ticks (ticks numer denom ppqn)
  (let* ((ppb (round (/ ppqn (/ denom 4.0))))
         (beat (/ ticks ppb))
         (measure (/ beat numer)))
    (format "%3d:%d:%03d" measure (% beat numer) (% ticks ppb))))

(defvar smf-ppqn nil)
(make-variable-buffer-local 'smf-ppqn)

(defun smf-display-insert-event (tick type &rest args)
  (insert " " (smf-format-ticks tick 4 4 smf-ppqn) " ")
  (insert (format "%S" (append (list type) args))))

(defvar smf-header-lines
  '(("Type: 0, ppqn: " (:eval (format "%d" smf-ppqn)))
    ("Type: 1, ppqn: " (:eval (format "%d" smf-ppqn))
     ", Track " (:eval (format "%d/%d"
                               (1+ (or smf-current-track 0))
                               (length smf-chunks)))))
  "Header line format for the different MIDI file types.")

(defvar smf-current-track nil)
(make-variable-buffer-local 'smf-current-track)

(defvar smf-type nil)
(make-variable-buffer-local 'smf-type)

(defun smf-set-current-track (number)
  (when (and smf-current-track (< smf-current-track (length smf-chunks)))
    (setcar (nthcdr 2 (nth smf-current-track smf-chunks)) (point)))
  (widen)
  (narrow-to-region (nth 0 (nth number smf-chunks))
                    (nth 1 (nth number smf-chunks)))
  (goto-char (nth 2 (nth number smf-chunks)))
  (setq smf-current-track number))

(defun smf-next-track (&optional n)
  (interactive "P")
  (if (= smf-type 0) (error "Type 0 MIDI files do only have one track"))
  (unless n (setq n 1))
  (smf-set-current-track (% (+ smf-current-track n) (length smf-chunks))))

(define-derived-mode midi-mode fundamental-mode "MIDI"
  "Mode for editing MIDI file content."
  (destructuring-bind (type ppqn &rest chunks) (smf-read)
    (setq smf-ppqn ppqn)
    (setq smf-type type)
    (setq smf-chunks chunks)
    
    (let ((inhibit-read-only t))
      (setq smf-chunks
            (mapcar (lambda (track)
                      (widen) (goto-char (point-max))
                      (narrow-to-region (point) (point))
                      (loop for event in (cdr track) do
                            (progn
                              (apply 'smf-display-insert-event event)
                              (put-text-property (line-beginning-position) 
(point)
                                                 'smf-event event)
                              (insert "\n")))
                      (let ((beg (point-min-marker))
                            (end (point-max-marker)))
                        (set-marker-insertion-type beg t)
                        (list beg end 1 (cdr track)))) smf-chunks))
      (set-buffer-modified-p nil))
    (smf-set-current-track 0)
    (setq header-line-format (nth type smf-header-lines))))

(add-to-list 'auto-mode-alist '("\\.mid$" . midi-mode))

(defun smf-play (data)
  (with-temp-buffer
    (set-buffer-multibyte nil)
    (smf-write data)
    (let ((filename (make-temp-file "midi")))
      (write-region (point-min) (point-max) filename)
      (start-process "timidity" nil "timidity" filename))))

(provide 'midi)
;;; midi.el ends here

-- 
CYa,
  Mario