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 ;;;; LOW-LEVEL PARSE/LEX ROUTINES.
  37
  38 (defun digit-to-int (char)
  39   (- (char-code char) (char-code #\0)))
  40
  41 (defun expect-int (stream)
  42   ;; if the next character is a digit, read digits until the next
  43   ;; character is not a digit.
  44   (do ((next-char #1=(peek-char nil stream) #1#)
  45        (int nil))
  46       ((not (find next-char *duration-digits*)) int)
  47     (let ((digit (digit-to-int (read-char stream))))
  48       (if int
  49           (setf int (+ (* int 10) digit))
  50           (setf int digit)))))
  51
  52 (defun expect-duration (stream)
  53   (let ((duration (make-duration (expect-int stream)))
  54         ;; if the next character is a dot, read dots until the next
  55         ;; character is not a dot.
  56         (dots (do ((next-char #1=(peek-char nil stream) #1#)
  57                    (number-of-dots 0 (1+ number-of-dots)))
  58                   ((char/= next-char #\.) number-of-dots)
  59                 (read-char stream))))
  60
  61     (when (and (plusp dots) (null duration))
  62       (error "Bad duration (relative dots are not allowed)."))
  63     (do ((i 0 (1+ i))
  64          (orig duration (/ orig 2)))
  65         ((>= i dots))
  66       (incf duration (/ orig 2)))
  67
  68     ;; tie.
  69     (unless (null duration)
  70       (do ((next-char #2=(peek-char nil stream) #2#))
  71           ((char/= next-char #\^))
  72         (read-char stream)
  73         (incf duration (make-duration (expect-int stream)))))
  74
  75     duration))
  76
  77 (defun read-accidentals (stream)
  78   (do ((next-char #1=(peek-char nil stream) #1#)
  79        (accidentals 0))
  80       ((char/= next-char #\+ #\-) accidentals)
  81     (if (char= (read-char stream) #\+)
  82         (incf accidentals)
  83         (decf accidentals))))
  84
  85 (defun expect-note (stream)
  86   (let* ((note-char (read-char stream))
  87          (accidentals (read-accidentals stream))
  88          (duration (expect-duration stream)))
  89
  90     ;; this function should always be called when we know there's a
  91     ;; note character next.
  92     (assert (find note-char *note-characters*))
  93
  94     (values note-char accidentals duration)))
  95
  96 (defun expect-rest (stream)
  97   (let ((rest-char (read-char stream))
  98         (duration (expect-duration stream)))
  99
 100     (if (char= rest-char #\r)
 101         (values :rest duration)
 102         (values :wait duration))))
 103
 104 (defun expect-channels (stream)
 105   (do ((next-char #1=(peek-char nil stream) #1#)
 106        (channels))
 107       ((not (find next-char *channel-select-characters*)) channels)
 108     ;; XXX dumb hack
 109     (push (- (char-code (read-char stream))
 110              (char-code (char *channel-select-characters* 0)))
 111           channels)))
 112
 113 (defun eat-whitespace (stream &optional (characters *whitespace-characters*))
 114   (do ((next-char #1=(peek-char nil stream) #1#))
 115       ((not (find next-char characters)))
 116     (read-char stream)))
 117
 118 (defun expect-= (stream)
 119   (eat-whitespace stream)
 120   (assert (char= (read-char stream) #\=))
 121   (eat-whitespace stream))
 122
 123 (defun read-numbers-and-loop-macro (stream)
 124   (assert (char= (read-char stream) #\{))
 125   (eat-whitespace stream)
 126   (do ((next-char #1=(peek-char nil stream) #1#)
 127        list)
 128       ((char= next-char #\}) (progn (read-char stream)
 129                                     (reverse list)))
 130     (cond ((char= next-char #\|)
 131            (read-char stream)
 132            (push :loop list))
 133           ((find next-char "0123456789-")
 134            (push (read stream) list))
 135           (t
 136            (read-char stream)
 137            (format t "~&Warning: ignored ~A in macro definition."
 138                    next-char)))
 139     (eat-whitespace stream)))
 140
 141 (defun read-symbols-macro (stream)
 142   (assert (char= (read-char stream) #\{))
 143   (eat-whitespace stream)
 144   (do ((symbol (read stream) (read stream))
 145        list)
 146       ((eql symbol '}) (reverse list))
 147     (push symbol list)))
 148
 149 (defparameter *macro-table-mapping*
 150   '((#\a :arpeggio read-numbers-and-loop-macro)
 151     (#\v :volume-envelope read-numbers-and-loop-macro)
 152     (#\i :instrument read-symbols-macro)
 153     (#\~ :vibrato read-symbols-macro)))
 154
 155 (defun read-macro-definition (stream)
 156   (assert (char= (read-char stream) #\@))
 157   (let* ((dispatch (read-char stream))
 158          (index (expect-int stream))
 159          (mapping (find dispatch *macro-table-mapping* :test #'equal
 160                         :key #'first)))
 161     (expect-= stream)
 162     (values (second mapping) index (funcall (third mapping) stream))))
 163
 164
 165 ;;;; HIGH-LEVEL PARSE ROUTINES.
 166
 167 ;;; We should really just create a readtable for the use of all the
 168 ;;; following routines.  Basically, what's in parse-header-section,
 169 ;;; but with the other CL standard macro characters disabled (parens,
 170 ;;; single/back quote, comma).
 171 (defun parse-mumble-file (stream)
 172   (let ((*read-eval* nil)
 173         (*package* (find-package :mumble))
 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))))
 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 (set-tune-replay argument tune))
 207            (setf (tune-channels tune)
 208                  (replay-create-channels (tune-replay tune))))
 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              (unless (tune-get-table tune table)
 223                (tune-add-table tune table))
 224              (tune-add-to-table tune table index entry)))
 225
 226           ;; Section change.
 227           ((char= next-char #\#)
 228            (read-char stream)
 229            (return))
 230
 231           ;; Comment.
 232           ((char= next-char #\;)
 233            (read-line stream))
 234
 235           ;; Something else?
 236           (t (format t "~&Ignored character in macro section: ~A (~:*~S)"
 237                      (read-char stream))))
 238     (eat-whitespace stream)))
 239
 240 ;; possible ``dispatch table'' format for routine below?
 241 #+nil '((#\o
 242    ((octave (progn (read-char stream) (expect-int stream))))
 243    (setf (channel-octave channel) octave))
 244   (#\<
 245    nil
 246    (decf (channel-octave c)))
 247   (*note-characters*
 248    ((note-char accidentals duration) (expect-note stream))
 249    (push (make-note (calculate-tone note-char
 250                                     accidentals
 251                                     (channel-octave channel))
 252                     (clarify-duration duration channel))
 253     (channel-data-stream channel))))
 254
 255
 256
 257 (defun parse-music-section (stream tune
 258                             &optional loop-channels in-loop-p)
 259   "Reads a music section from stream; returns at EOF or if a section
 260 change is detected.  Writes data and property changes to channels.
 261 Highly intolerant of malformed inputs."
 262   (do ((current-channels (and in-loop-p loop-channels))
 263        (next-char #1=(peek-char nil stream) #1#))
 264       (nil)
 265           ;; Channel selection characters.
 266     (cond ((find next-char *channel-select-characters*)
 267            (setf current-channels nil)
 268            (dolist (c (expect-channels stream))
 269              (assert (< c (length (tune-channels tune)))
 270                      () "Invalid channel for this replay.")
 271              (push (nth c (tune-channels tune)) current-channels)))
 272
 273           ;; Repeats (unrolled loops).
 274           ((char= next-char #\[)
 275            (assert current-channels () "Command outside channels.")
 276            (read-char stream)
 277            (dolist (c current-channels)
 278              (push (channel-current-position c)
 279                    (channel-repeats c)))
 280            (parse-music-section stream tune current-channels t))
 281
 282           ((char= next-char #\])
 283            (assert (and in-loop-p
 284                         current-channels))
 285            (read-char stream)
 286            (let ((count (expect-int stream)))
 287              (dolist (c current-channels)
 288                (let ((begin (pop (channel-repeats c)))
 289                      (end (1- (channel-current-position c))))
 290                  (dotimes (i (1- count))
 291                    (copy-and-append-channel-data c begin end)))))
 292            (return))
 293
 294           ;; Octave changes.
 295           ((char= next-char #\o)
 296            (assert current-channels () "Command outside channels.")
 297            (read-char stream)
 298            (let ((octave (expect-int stream)))
 299              (dolist (c current-channels)
 300                (setf (channel-octave c) octave))))
 301
 302           ((char= next-char #\<)
 303            (assert current-channels () "Command outside channels.")
 304            (read-char stream)
 305            (dolist (c current-channels)
 306              (decf (channel-octave c))))
 307
 308           ((char= next-char #\>)
 309            (assert current-channels () "Command outside channels.")
 310            (read-char stream)
 311            (dolist (c current-channels)
 312              (incf (channel-octave c))))
 313
 314           ;; Notes and rests.
 315           ((find next-char *note-characters*)
 316            (assert current-channels () "Command outside channels.")
 317            (multiple-value-bind (note-char accidentals duration)
 318                (expect-note stream)
 319              (dolist (c current-channels)
 320                (vector-push-extend (make-note
 321                                     (calculate-tone note-char
 322                                                     accidentals
 323                                                     (channel-octave c))
 324                                     (clarify-duration duration c))
 325                                    (channel-data-stream c)))))
 326
 327           ((or (char= next-char #\r) (char= next-char #\w))
 328            (assert current-channels () "Command outside channels.")
 329            (multiple-value-bind (note-type duration)
 330                (expect-rest stream)
 331              (dolist (c current-channels)
 332                (vector-push-extend (make-note note-type
 333                                               (clarify-duration duration c))
 334                                    (channel-data-stream c)))))
 335
 336           ;; Tempo change.
 337           ((char= next-char #\t)
 338            (assert current-channels () "Command outside channels.")
 339            (read-char stream)
 340            (let ((tempo (expect-int stream)))
 341              (dolist (c current-channels)
 342                (vector-push-extend (make-tempo-command tempo)
 343                                    (channel-data-stream c))
 344                (setf (channel-tempo c) tempo))))
 345
 346           ;; Section change.
 347           ;; XXX: add something to complain about unfinished loops.
 348           ((char= next-char #\#)
 349            (read-char stream)
 350            (when in-loop-p
 351              (format t "WARNING: changing sections during a [] repeat.  ~
 352                        This probably won't work."))
 353            (return))
 354
 355           ;; Staccato.
 356           ((char= next-char #\q)
 357            (assert current-channels () "Command outside channels.")
 358            (read-char stream)
 359            (let ((staccato (* *staccato-base-division* (expect-int stream))))
 360              (dolist (c current-channels)
 361                (vector-push-extend (make-staccato-command staccato)
 362                                    (channel-data-stream c))
 363                (setf (channel-staccato c) staccato))))
 364
 365           ;; Macro invocation.
 366           ((char= next-char #\@)
 367            (assert current-channels () "Command outside channels.")
 368            (parse-macro-invocation stream current-channels))
 369
 370           ;; Structural dispatch character.
 371           ((char= next-char #\!)
 372            (assert current-channels () "Command outside channels.")
 373            (parse-bang-invocation stream current-channels))
 374
 375           ;; Replay-special invocation.
 376           ((char= next-char #\%)
 377            (assert current-channels () "Command outside channels.")
 378            (read-char stream)
 379            (replay-special-handler (tune-replay tune) stream
 380                                    (tune-channels tune)))
 381
 382           ;; Comment.
 383           ((char= next-char #\;)
 384            (read-line stream))
 385
 386           ;; Something else?
 387           (t (format t "~&Ignored character in music section: ~A (~:*~S)"
 388                      (read-char stream))))
 389     (eat-whitespace stream *ws-and-barline-characters*)))
 390
 391
 392 (defun parse-macro-invocation (stream channels)
 393   (read-char stream)
 394   (let ((next-char (peek-char nil stream)))
 395           ;; Arpeggio.
 396     (cond ((char= next-char #\a)
 397            (read-char stream)
 398            (let ((arp-num (expect-int stream)))
 399              (dolist (c channels)
 400                (vector-push-extend (make-arpeggio-command arp-num)
 401                                    (channel-data-stream c)))))
 402           ;; Volume envelope.
 403           ((char= next-char #\v)
 404            (read-char stream)
 405            (let ((venv-num (expect-int stream)))
 406              (dolist (c channels)
 407                (vector-push-extend (make-volume-envelope-command venv-num)
 408                                    (channel-data-stream c)))))
 409
 410           ;; Vibrato.
 411           ((char= next-char #\~)
 412            (read-char stream)
 413            (let ((vibrato-num (expect-int stream)))
 414              ;; XXX unimplemented
 415              vibrato-num))
 416
 417           ;; Something else?
 418           (t (format t "~&Ignored macro invocator: @~A (~:*~S)"
 419                      (read-char stream))))))
 420
 421
 422 (defun parse-bang-invocation (stream channels)
 423   (assert (char= (read-char stream) #\!))
 424   (let* ((symbol (read stream)))
 425     (ecase 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)))))))