src/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.  Most of this
   4 ;;; could be converted to a very data-driven style of programming.
   5 ;;;
   6 ;;; Other things that should be checked/fixed:
   7 ;;;     - durations should get tweaked (say, by parse-music-section) if
   8 ;;;       we're inside a triplet or tuplet figure.
   9 ;;;     - haven't figured out yet who should deal with specifying an
  10 ;;;       initial tempo if we don't find one before the first note.  I
  11 ;;;       have a feeling I should just have this code insert a tempo
  12 ;;;       set event on any channel where we get a duration-dependant
  13 ;;;       event before any tempo is set.
  14 ;;;
  15 ;;; (an abashed) Julian Squires <tek@wiw.org> / 2004
  16 ;;;
  17
  18 (in-package :mumble)
  19
  20 ;;;; CONSTANTS AND PARAMETERS.
  21
  22 (defparameter *channel-select-characters* "ABCDEFGHIJ")
  23 (defparameter *duration-digits* "0123456789")
  24 (defparameter *note-characters* "c_d_ef_g_a_b")
  25 (defparameter *whitespace-characters* #(#\Space #\Newline #\Tab))
  26 (defparameter *ws-and-barline-characters* #(#\Space #\Newline #\Tab #\|))
  27
  28 (defconstant +octave-size+ 12)
  29
  30 (defparameter *staccato-base-division* 1/8)
  31 (defparameter *default-duration* (make-duration 4))
  32 (defparameter *default-octave* 4)
  33 (defparameter *default-staccato* 1)
  34 (defparameter *default-tempo* 120)
  35
  36
  37 ;;;; LOW-LEVEL PARSE/LEX ROUTINES.
  38
  39 (defun digit-to-int (char)
  40   (- (char-code char) (char-code #\0)))
  41
  42 (defun expect-int (stream)
  43   ;; if the next character is a digit, read digits until the next
  44   ;; character is not a digit.
  45   (do ((next-char #1=(peek-char nil stream) #1#)
  46        (int nil))
  47       ((not (find next-char *duration-digits*)) int)
  48     (let ((digit (digit-to-int (read-char stream))))
  49       (if int
  50           (setf int (+ (* int 10) digit))
  51           (setf int digit)))))
  52
  53 (defun expect-duration (stream)
  54   (let ((duration (make-duration (expect-int stream)))
  55         ;; if the next character is a dot, read dots until the next
  56         ;; character is not a dot.
  57         (dots (do ((next-char #1=(peek-char nil stream) #1#)
  58                    (number-of-dots 0 (1+ number-of-dots)))
  59                   ((char/= next-char #\.) number-of-dots)
  60                 (read-char stream))))
  61
  62     (when (and (plusp dots) (null duration))
  63       (error "Bad duration (relative dots are not allowed)."))
  64     (do ((i 0 (1+ i))
  65          (orig duration (/ orig 2)))
  66         ((>= i dots))
  67       (incf duration (/ orig 2)))
  68
  69     ;; tie.
  70     (unless (null duration)
  71       (do ((next-char #2=(peek-char nil stream) #2#))
  72           ((char/= next-char #\^))
  73         (read-char stream)
  74         (incf duration (make-duration (expect-int stream)))))
  75
  76     duration))
  77
  78 (defun read-accidentals (stream)
  79   (do ((next-char #1=(peek-char nil stream) #1#)
  80        (accidentals 0))
  81       ((char/= next-char #\+ #\-) accidentals)
  82     (if (char= (read-char stream) #\+)
  83         (incf accidentals)
  84         (decf accidentals))))
  85
  86 (defun expect-note (stream)
  87   (let* ((note-char (read-char stream))
  88          (accidentals (read-accidentals stream))
  89          (duration (expect-duration stream)))
  90
  91     ;; this function should always be called when we know there's a
  92     ;; note character next.
  93     (assert (find note-char *note-characters*))
  94
  95     (values note-char accidentals duration)))
  96
  97 (defun expect-rest (stream)
  98   (let ((rest-char (read-char stream))
  99         (duration (expect-duration stream)))
 100
 101     (if (char= rest-char #\r)
 102         (values :rest duration)
 103         (values :wait duration))))
 104
 105 (defun expect-channels (stream)
 106   (do ((next-char #1=(peek-char nil stream) #1#)
 107        (channels))
 108       ((not (find next-char *channel-select-characters*)) channels)
 109     ;; XXX dumb hack
 110     (push (- (char-code (read-char stream))
 111              (char-code (char *channel-select-characters* 0)))
 112           channels)))
 113
 114 (defun eat-whitespace (stream &optional (characters *whitespace-characters*))
 115   (do ((next-char #1=(peek-char nil stream) #1#))
 116       ((not (find next-char characters)))
 117     (read-char stream)))
 118
 119 (defun expect-= (stream)
 120   (eat-whitespace stream)
 121   (assert (char= (read-char stream) #\=))
 122   (eat-whitespace stream))
 123
 124 (defun read-numbers-and-loop-macro (stream)
 125   (assert (char= (read-char stream) #\{))
 126   (eat-whitespace stream)
 127   (do ((next-char #1=(peek-char nil stream) #1#)
 128        list)
 129       ((char= next-char #\}) (progn (read-char stream)
 130                                     (reverse list)))
 131     (cond ((char= next-char #\|)
 132            (read-char stream)
 133            (push :loop list))
 134           ((find next-char "0123456789-")
 135            (push (read stream) list))
 136           (t
 137            (read-char stream)
 138            (format t "~&Warning: ignored ~A in macro definition."
 139                    next-char)))
 140     (eat-whitespace stream)))
 141
 142 (defun read-symbols-macro (stream)
 143   (assert (char= (read-char stream) #\{))
 144   (eat-whitespace stream)
 145   (do ((symbol (read stream) (read stream))
 146        list)
 147       ((eql symbol '}) (reverse list))
 148     (push symbol list)))
 149
 150 (defparameter *macro-table-mapping*
 151   '((#\a :arpeggio read-numbers-and-loop-macro)
 152     (#\v :volume-envelope read-numbers-and-loop-macro)
 153     (#\i :instrument read-symbols-macro)
 154     (#\~ :vibrato read-symbols-macro)))
 155
 156 (defun read-macro-definition (stream)
 157   (assert (char= (read-char stream) #\@))
 158   (let* ((dispatch (read-char stream))
 159          (index (expect-int stream))
 160          (mapping (find dispatch *macro-table-mapping* :test #'equal
 161                         :key #'first)))
 162     (expect-= stream)
 163     (values (second mapping) index (funcall (third mapping) stream))))
 164
 165
 166 ;;;; HIGH-LEVEL PARSE ROUTINES.
 167
 168 ;;; We should really just create a readtable for the use of all the
 169 ;;; following routines.  Basically, what's in parse-header-section,
 170 ;;; but with the other CL standard macro characters disabled (parens,
 171 ;;; single/back quote, comma).
 172 (defun parse-mumble-file (stream)
 173   (let ((*read-eval* nil)
 174         (tune (make-tune)))
 175     ;; Any preamble that occurs before the first section is ignored.
 176     (parse-comment-section stream)
 177     (handler-case
 178         (do ((section (read stream) (read stream)))
 179             (nil)
 180           ;; Note that the section handler is always responsible for
 181           ;; eating the # sign so we don't see it.
 182           (ecase section
 183             (COMMENT (parse-comment-section stream))
 184             (MACROS (parse-macro-section stream tune))
 185             (HEADER (parse-header-section stream tune))
 186             (MUSIC (parse-music-section stream (tune-channels tune)))))
 187       (end-of-file () tune))))
 188
 189
 190 (defun parse-comment-section (stream)
 191   (do () ((char= (read-char stream) #\#))))
 192
 193 (defun parse-header-section (stream tune)
 194   (let ((*readtable* (copy-readtable))
 195         done-p)
 196     (set-macro-character #\#
 197                          (lambda (stream char)
 198                            (declare (ignore stream char))
 199                            (setf done-p t)))
 200     (do ((header (read stream) (read stream)))
 201         (done-p)
 202       (let ((argument (read stream)))
 203         (case header
 204           (REPLAY
 205            ;; XXX genericize replay stuff
 206            (assert (string= argument "YMamoto"))
 207            (setf (tune-channels tune) (make-ymamoto-channels))
 208            (setf (tune-replay tune) argument))
 209           ((TITLE COMPOSER COPYRIGHT)
 210            (push (list header argument) (tune-metadata tune))))))))
 211
 212
 213 (defun parse-macro-section (stream tune)
 214   (do ((next-char #1=(peek-char nil stream) #1#))
 215       (nil)
 216     (cond ((char= next-char #\@)
 217            (multiple-value-bind (table index entry)
 218                (read-macro-definition stream)
 219              (assert (plusp index) ()
 220                      "Bad index ~A (tables index from 1 -- 0 is the ~
 221                      \"effect off\" index)." index)
 222              (format t "~&got macro ~A ~A ~A" table index entry)
 223              (unless (tune-get-table tune table)
 224                (tune-add-table tune table))
 225              (tune-add-to-table tune table index entry)))
 226
 227           ;; Section change.
 228           ((char= next-char #\#)
 229            (read-char stream)
 230            (return))
 231
 232           ;; Comment.
 233           ((char= next-char #\;)
 234            (read-line stream))
 235
 236           ;; Something else?
 237           (t (format t "~&Ignored character in macro section: ~A (~:*~S)"
 238                      (read-char stream))))
 239     (eat-whitespace stream)))
 240
 241 ;; possible ``dispatch table'' format for routine below?
 242 #+nil '((#\o
 243    ((octave (progn (read-char stream) (expect-int stream))))
 244    (setf (channel-octave channel) octave))
 245   (#\<
 246    nil
 247    (decf (channel-octave c)))
 248   (*note-characters*
 249    ((note-char accidentals duration) (expect-note stream))
 250    (push (make-note (calculate-tone note-char
 251                                     accidentals
 252                                     (channel-octave channel))
 253                     (clarify-duration duration channel))
 254     (channel-data-stream channel))))
 255
 256
 257
 258 (defun parse-music-section (stream channels
 259                             &optional loop-channels in-loop-p)
 260   "Reads a music section from stream; returns at EOF or if a section
 261 change is detected.  Writes data and property changes to channels.
 262 Highly intolerant of malformed inputs."
 263   (do ((current-channels (and in-loop-p loop-channels))
 264        (next-char #1=(peek-char nil stream) #1#))
 265       (nil)
 266           ;; Channel selection characters.
 267     (cond ((find next-char *channel-select-characters*)
 268            (setf current-channels nil)
 269            (dolist (c (expect-channels stream))
 270              (assert (< c (length channels))
 271                      () "Invalid channel for this replay.")
 272              (push (nth c channels) current-channels)))
 273
 274           ;; Repeats (unrolled loops).
 275           ((char= next-char #\[)
 276            (assert current-channels () "Command outside channels.")
 277            (read-char stream)
 278            (dolist (c current-channels)
 279              (push (channel-current-position c)
 280                    (channel-repeats c)))
 281            (parse-music-section stream channels current-channels t))
 282
 283           ((char= next-char #\])
 284            (assert (and in-loop-p
 285                         current-channels))
 286            (read-char stream)
 287            (let ((count (expect-int stream)))
 288              (dolist (c current-channels)
 289                (let ((begin (pop (channel-repeats c)))
 290                      (end (1- (channel-current-position c))))
 291                  (dotimes (i (1- count))
 292                    (copy-and-append-channel-data c begin end)))))
 293            (return))
 294
 295           ;; Octave changes.
 296           ((char= next-char #\o)
 297            (assert current-channels () "Command outside channels.")
 298            (read-char stream)
 299            (let ((octave (expect-int stream)))
 300              (dolist (c current-channels)
 301                (setf (channel-octave c) octave))))
 302
 303           ((char= next-char #\<)
 304            (assert current-channels () "Command outside channels.")
 305            (read-char stream)
 306            (dolist (c current-channels)
 307              (decf (channel-octave c))))
 308
 309           ((char= next-char #\>)
 310            (assert current-channels () "Command outside channels.")
 311            (read-char stream)
 312            (dolist (c current-channels)
 313              (incf (channel-octave c))))
 314
 315           ;; Notes and rests.
 316           ((find next-char *note-characters*)
 317            (assert current-channels () "Command outside channels.")
 318            (multiple-value-bind (note-char accidentals duration)
 319                (expect-note stream)
 320              (dolist (c current-channels)
 321                (vector-push-extend (make-note
 322                                     (calculate-tone note-char
 323                                                     accidentals
 324                                                     (channel-octave c))
 325                                     (clarify-duration duration c))
 326                                    (channel-data-stream c)))))
 327
 328           ((or (char= next-char #\r) (char= next-char #\w))
 329            (assert current-channels () "Command outside channels.")
 330            (multiple-value-bind (note-type duration)
 331                (expect-rest stream)
 332              (dolist (c current-channels)
 333                (vector-push-extend (make-note note-type
 334                                               (clarify-duration duration c))
 335                                    (channel-data-stream c)))))
 336
 337           ;; Tempo change.
 338           ((char= next-char #\t)
 339            (assert current-channels () "Command outside channels.")
 340            (read-char stream)
 341            (let ((tempo (expect-int stream)))
 342              (dolist (c current-channels)
 343                (vector-push-extend (make-tempo-command tempo)
 344                                    (channel-data-stream c))
 345                (setf (channel-tempo c) tempo))))
 346
 347           ;; Section change.
 348           ;; XXX: add something to complain about unfinished loops.
 349           ((char= next-char #\#)
 350            (read-char stream)
 351            (when in-loop-p
 352              (format t "WARNING: changing sections during a [] repeat.  ~
 353                        This probably won't work."))
 354            (return))
 355
 356           ;; Staccato.
 357           ((char= next-char #\q)
 358            (assert current-channels () "Command outside channels.")
 359            (read-char stream)
 360            (let ((staccato (* *staccato-base-division* (expect-int stream))))
 361              (dolist (c current-channels)
 362                (vector-push-extend (make-staccato-command staccato)
 363                                    (channel-data-stream c))
 364                (setf (channel-staccato c) staccato))))
 365
 366           ;; Macro invocation.
 367           ((char= next-char #\@)
 368            (assert current-channels () "Command outside channels.")
 369            (parse-macro-invocation stream current-channels))
 370
 371           ;; Structural dispatch character.
 372           ((char= next-char #\!)
 373            (assert current-channels () "Command outside channels.")
 374            (parse-bang-invocation stream current-channels))
 375
 376           ;; Replay-special invocation.
 377           ((char= next-char #\%)
 378            (assert current-channels () "Command outside channels.")
 379            (read-char stream)
 380            ;; XXX genericize replay stuff
 381            (ymamoto-special-handler stream channels))
 382
 383           ;; Comment.
 384           ((char= next-char #\;)
 385            (read-line stream))
 386
 387           ;; Something else?
 388           (t (format t "~&Ignored character in music section: ~A (~:*~S)"
 389                      (read-char stream))))
 390     (eat-whitespace stream *ws-and-barline-characters*)))
 391
 392
 393 (defun parse-macro-invocation (stream channels)
 394   (read-char stream)
 395   (let ((next-char (peek-char nil stream)))
 396           ;; Arpeggio.
 397     (cond ((char= next-char #\a)
 398            (read-char stream)
 399            (let ((arp-num (expect-int stream)))
 400              (dolist (c channels)
 401                (vector-push-extend (make-arpeggio-command arp-num)
 402                                    (channel-data-stream c)))))
 403           ;; Volume envelope.
 404           ((char= next-char #\v)
 405            (read-char stream)
 406            (let ((venv-num (expect-int stream)))
 407              (dolist (c channels)
 408                (vector-push-extend (make-volume-envelope-command venv-num)
 409                                    (channel-data-stream c)))))
 410
 411           ;; Vibrato.
 412           ((char= next-char #\~)
 413            (read-char stream)
 414            (let ((vibrato-num (expect-int stream)))
 415              ;; XXX unimplemented
 416              vibrato-num))
 417
 418           ;; Something else?
 419           (t (format t "~&Ignored macro invocator: @~A (~:*~S)"
 420                      (read-char stream))))))
 421
 422
 423 (defun parse-bang-invocation (stream channels)
 424   (let ((symbol (read stream)))
 425     (case symbol
 426       (LOOP
 427          (dolist (c channels)
 428            (setf (channel-loop-point c) (channel-current-position c))))
 429       (END
 430        ;;; XXX how to handle this nicely?
 431        #+nil(dolist (c channels)
 432               (vector-push-extend (make-track-end-command)
 433                                   (channel-data-stream c)))))))