music-parser.lisp

   1 ;;;
   2 ;;; Several of these functions are very flaky WRT EOF, and that should
   3 ;;; eventually be fixed.  This is all just a quick hack.
   4 ;;;
   5 ;;; Other things that should be checked/fixed:
   6 ;;;     - durations should get tweaked (say, by parse-music-section) if
   7 ;;;       we're inside a triplet or tuplet figure.
   8 ;;;     - haven't figured out yet who should deal with specifying an
   9 ;;;       initial tempo if we don't find one before the first note.  I
  10 ;;;       have a feeling I should just have this code insert a tempo
  11 ;;;       set event on any channel where we get a duration-dependant
  12 ;;;       event before any tempo is set.
  13 ;;;
  14 ;;; (an abashed) Julian Squires <tek@wiw.org> / 2003
  15 ;;;
  16
  17 (in-package :mumble)
  18
  19 ;;;; CONSTANTS AND PARAMETERS.
  20
  21 (defparameter *channel-select-characters* "ABCDEFGHIJ")
  22 (defparameter *duration-digits* "0123456789")
  23 (defparameter *note-characters* "c_d_ef_g_a_b")
  24 (defparameter *whitespace-characters* #(#\Space #\Newline #\|))
  25
  26 (defconstant +octave-size+ 12)
  27
  28 (defparameter *default-duration* (make-duration 4))
  29 (defparameter *default-octave* 4)
  30 (defparameter *default-tempo* 120)
  31
  32
  33 ;;;; CLASSES AND DATA STRUCTURES.
  34
  35 (defclass duration ()
  36   ((denominator :reader duration-denominator)
  37    ;; other modifiers here
  38    (dots :reader duration-dots)))
  39
  40 (defun make-duration (denominator &optional (dots 0))
  41   (when denominator
  42     (let ((duration (make-instance 'duration)))
  43       (setf (slot-value duration 'denominator) denominator)
  44       (setf (slot-value duration 'dots) dots)
  45       duration)))
  46
  47 (defmethod print-object ((obj duration) stream)
  48   (print-unreadable-object (obj stream :type t)
  49     (princ (duration-denominator obj) stream)
  50     (dotimes (i (duration-dots obj))
  51       (princ #\. stream))))
  52
  53
  54 (defclass music-command ()
  55   ((type :reader music-command-type)
  56    (value :reader music-command-value)))
  57
  58 (defun make-tempo-command (tempo)
  59   (let ((cmd (make-instance 'music-command)))
  60     (setf (slot-value cmd 'type) :tempo)
  61     (setf (slot-value cmd 'value) tempo)
  62     cmd))
  63
  64
  65 (defclass note (music-command)
  66   ((tone :reader note-tone)
  67    (duration :reader note-duration))
  68   (:documentation "Notes encapsulate an absolute pitch (the TONE slot)
  69 and a relative length (the DURATION slot).  DURATION is relative to
  70 the current channel tempo."))
  71
  72 (defun make-note (tone duration)
  73   (let ((note (make-instance 'note)))
  74     (setf (slot-value note 'type) :note)
  75     (setf (slot-value note 'tone) tone)
  76     (setf (slot-value note 'duration) duration)
  77     note))
  78
  79 (defmethod print-object ((obj note) stream)
  80   (print-unreadable-object (obj stream :type t)
  81     (princ (note-tone obj) stream)
  82     (princ #\Space stream)
  83     (princ (note-duration obj) stream)))
  84
  85
  86 (defclass channel ()
  87   ((octave :accessor channel-octave)
  88    (tempo :accessor channel-tempo)
  89    (staccato :accessor channel-staccato)
  90    (duration :accessor channel-default-duration)
  91    (loop-point :accessor channel-loop-point)
  92    (data-stream :accessor channel-data-stream)))
  93
  94 (defun make-channel ()
  95   (let ((channel (make-instance 'channel)))
  96     (setf (channel-octave channel) *default-octave*)
  97     (setf (channel-tempo channel) *default-tempo*)
  98     (setf (channel-default-duration channel) *default-duration*)
  99     (setf (channel-data-stream channel) nil)
 100     channel))
 101
 102
 103
 104 ;;;; LOW-LEVEL PARSE/LEX ROUTINES.
 105
 106 (defun digit-to-int (char)
 107   (- (char-code char) (char-code #\0)))
 108
 109 (defun clarify-duration (duration channel)
 110   (if duration
 111       (setf (channel-default-duration channel) duration)
 112       (channel-default-duration channel)))
 113
 114 (defun expect-int (stream)
 115   ;; if the next character is a digit, read digits until the next
 116   ;; character is not a digit.
 117   (do ((next-char #1=(peek-char nil stream) #1#)
 118        (int nil))
 119       ((not (find next-char *duration-digits*)) int)
 120     (let ((digit (digit-to-int (read-char stream))))
 121       (if int
 122           (setf int (+ (* int 10) digit))
 123           (setf int digit)))))
 124
 125 (defun expect-duration (stream)
 126   (let ((duration (make-duration (expect-int stream)))
 127         ;; if the next character is a dot, read dots until the next
 128         ;; character is not a dot.
 129         (dots (do ((next-char #2=(peek-char nil stream) #2#)
 130                    (number-of-dots 0 (1+ number-of-dots)))
 131                   ((char/= next-char #\.) number-of-dots)
 132                 (read-char stream))))
 133
 134     (when (plusp dots)
 135       (setf (slot-value duration 'dots) dots))
 136     duration))
 137
 138 (defun calculate-tone (char accidentals octave)
 139   (let ((tone-value (* +octave-size+ octave)))
 140     (incf tone-value
 141           (do ((i 0 (1+ i)))
 142               ((char= char (schar *note-characters* i)) i)
 143             (assert (< i (length *note-characters*)))))
 144     (incf tone-value accidentals)
 145     tone-value))
 146
 147 (defun read-accidentals (stream)
 148   (do ((next-char #1=(peek-char nil stream) #1#)
 149        (accidentals 0))
 150       ((char/= next-char #\+ #\-) accidentals)
 151     (if (char= (read-char stream) #\+)
 152         (incf accidentals)
 153         (decf accidentals))))
 154
 155 (defun expect-note (stream)
 156   (let* ((note-char (read-char stream))
 157          (accidentals (read-accidentals stream))
 158          (duration (expect-duration stream)))
 159
 160     ;; this function should always be called when we know there's a
 161     ;; note character next.
 162     (assert (find note-char *note-characters*))
 163
 164     (values note-char accidentals duration)))
 165
 166 (defun expect-rest (stream)
 167   (let ((rest-char (read-char stream))
 168         (duration (expect-duration stream)))
 169
 170     (if (char= rest-char #\r)
 171         (values :rest duration)
 172         (values :wait duration))))
 173
 174 (defun expect-channels (stream)
 175   (do ((next-char #1=(peek-char nil stream) #1#)
 176        (channels))
 177       ((not (find next-char *channel-select-characters*)) channels)
 178     ;; XXX dumb hack
 179     (push (- (char-code (read-char stream))
 180              (char-code (char *channel-select-characters* 0)))
 181           channels)))
 182
 183 (defun eat-whitespace-and-barlines (stream)
 184   (do ((next-char #1=(peek-char nil stream) #1#))
 185       ((not (find next-char *whitespace-characters*)))
 186     (read-char stream)))
 187
 188
 189 (defmacro mv-push (source destination key)
 190   `(do ((d ,destination (cdr d))
 191         (s ,source (cdr s)))
 192     ((not d))
 193     (push (car s) (,key (car d)))))
 194
 195
 196 ;;;; HIGH-LEVEL PARSE ROUTINES.
 197
 198 (defun parse-music-section (stream channels)
 199   "Reads a music section from stream; returns at EOF or if a section
 200 change is detected.  Writes data and property changes to channels.
 201 Highly intolerant of malformed inputs."
 202   (handler-case
 203       (music-parse-internal stream channels)
 204     (end-of-file ()))
 205   (dolist (c channels)
 206     (setf (channel-data-stream c) (reverse (channel-data-stream c)))))
 207
 208 (defun music-parse-internal (stream channels)
 209   (do ((current-channels nil)
 210        (next-char #1=(peek-char nil stream) #1#))
 211       (nil)
 212           ;; Channel selection characters.
 213     (cond ((find next-char *channel-select-characters*)
 214            (setf current-channels nil)
 215            (dolist (c (expect-channels stream))
 216              (push (nth c channels) current-channels)))
 217
 218           ;; Octave changes.
 219           ((char= next-char #\o)
 220            (assert current-channels)
 221            (read-char stream)
 222            (let ((octave (expect-int stream)))
 223              (dolist (c current-channels)
 224                (setf (channel-octave c) octave))))
 225
 226           ((char= next-char #\<)
 227            (assert current-channels)
 228            (read-char stream)
 229            (dolist (c current-channels)
 230              (decf (channel-octave c))))
 231
 232           ((char= next-char #\>)
 233            (assert current-channels)
 234            (read-char stream)
 235            (dolist (c current-channels)
 236              (incf (channel-octave c))))
 237
 238           ;; Notes and rests.
 239           ((find next-char *note-characters*)
 240            (assert current-channels)
 241            (multiple-value-bind (note-char accidentals duration)
 242                (expect-note stream)
 243              (dolist (c current-channels)
 244                (push (make-note (calculate-tone note-char
 245                                                 accidentals
 246                                                 (channel-octave c))
 247                                 (clarify-duration duration c))
 248                      (channel-data-stream c)))))
 249
 250           ((or (char= next-char #\r) (char= next-char #\w))
 251            (assert current-channels)
 252            (multiple-value-bind (note-type duration)
 253                (expect-rest stream)
 254              (dolist (c current-channels)
 255                (push (make-note note-type
 256                                 (clarify-duration duration c))
 257                      (channel-data-stream c)))))
 258
 259           ;; Tempo change.
 260           ((char= next-char #\t)
 261            (assert current-channels)
 262            (read-char stream)
 263            (let ((tempo (expect-int stream)))
 264              (dolist (c current-channels)
 265                (push (make-tempo-command tempo)
 266                      (channel-data-stream c))
 267                (setf (channel-tempo c) tempo))))
 268           ((char= next-char #\#)
 269            (return))
 270
 271           ;; Something else?
 272           (t (format nil "~&Ignored character: ~A"
 273                      (read-char stream))))
 274     (eat-whitespace-and-barlines stream)))