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 (defun handle-simple-volume (stream channels)
 166   (assert (char= (read-char stream) #\v))
 167   (let ((next-char (peek-char nil stream)))
 168     (cond ((find next-char *duration-digits*)
 169            (let ((volume (expect-int stream)))
 170              (dolist (c channels)
 171                (vector-push-extend
 172                 (make-simple-volume-command volume)
 173                 (channel-data-stream c))
 174                (setf (channel-volume c) volume))))
 175           ((char= next-char #\+)
 176            (read-char stream)
 177            (dolist (c channels)
 178              (vector-push-extend
 179               (make-simple-volume-command (1+ (channel-volume c)))
 180               (channel-data-stream c))))
 181           ((char= next-char #\-)
 182            (read-char stream)
 183            (dolist (c channels)
 184              (vector-push-extend
 185               (make-simple-volume-command (1- (channel-volume c)))
 186               (channel-data-stream c))))
 187           (t (error "~&Bad volume character: v~A" next-char)))))
 188
 189
 190
 191 ;;;; HIGH-LEVEL PARSE ROUTINES.
 192
 193 ;;; We should really just create a readtable for the use of all the
 194 ;;; following routines.  Basically, what's in parse-header-section,
 195 ;;; but with the other CL standard macro characters disabled (parens,
 196 ;;; single/back quote, comma).
 197 (defun parse-mumble-file (stream)
 198   (let ((*read-eval* nil)
 199         (*package* (find-package :mumble))
 200         (tune (make-tune)))
 201     ;; Any preamble that occurs before the first section is ignored.
 202     (parse-comment-section stream)
 203     (handler-case
 204         (do ((section (read stream) (read stream)))
 205             (nil)
 206           ;; Note that the section handler is always responsible for
 207           ;; eating the # sign so we don't see it.
 208           (ecase section
 209             (COMMENT (parse-comment-section stream))
 210             (MACROS (parse-macro-section stream tune))
 211             (HEADER (parse-header-section stream tune))
 212             (MUSIC (parse-music-section stream tune))))
 213       (end-of-file () tune))))
 214
 215
 216 (defun parse-comment-section (stream)
 217   (do () ((char= (read-char stream) #\#))))
 218
 219 (defun parse-header-section (stream tune)
 220   (let ((*readtable* (copy-readtable))
 221         done-p)
 222     (set-macro-character #\#
 223                          (lambda (stream char)
 224                            (declare (ignore stream char))
 225                            (setf done-p t)))
 226     (do ((header (read stream) (read stream)))
 227         (done-p)
 228       (let ((argument (read stream)))
 229         (case header
 230           (REPLAY
 231            ;; XXX genericize replay stuff
 232            (assert (set-tune-replay argument tune))
 233            (setf (tune-channels tune)
 234                  (funcall (replay-channel-creator (tune-replay tune)))))
 235           ((TITLE COMPOSER COPYRIGHT)
 236            (push (list header argument) (tune-metadata tune))))))))
 237
 238
 239 (defun parse-macro-section (stream tune)
 240   (eat-whitespace stream)
 241   (do ((next-char #1=(peek-char nil stream) #1#))
 242       (nil)
 243     (cond ((char= next-char #\@)
 244            (multiple-value-bind (table index entry)
 245                (read-macro-definition stream)
 246              (assert (plusp index) ()
 247                      "Bad index ~A (tables index from 1 -- 0 is the ~
 248                      \"effect off\" index)." index)
 249              (unless (tune-get-table tune table)
 250                (tune-add-table tune table))
 251              (tune-add-to-table tune table index entry)))
 252
 253           ;; Section change.
 254           ((char= next-char #\#)
 255            (read-char stream)
 256            (return))
 257
 258           ;; Comment.
 259           ((char= next-char #\;)
 260            (read-line stream))
 261
 262           ;; Something else?
 263           (t (format t "~&Ignored character in macro section: ~A (~:*~S)"
 264                      (read-char stream))))
 265     (eat-whitespace stream)))
 266
 267 ;; possible ``dispatch table'' format for routine below?
 268 #+nil '((#\o
 269    ((octave (progn (read-char stream) (expect-int stream))))
 270    (setf (channel-octave channel) octave))
 271   (#\<
 272    nil
 273    (decf (channel-octave c)))
 274   (*note-characters*
 275    ((note-char accidentals duration) (expect-note stream))
 276    (push (make-note (calculate-tone note-char
 277                                     accidentals
 278                                     (channel-octave channel))
 279                     (clarify-duration duration channel))
 280     (channel-data-stream channel))))
 281
 282
 283
 284 (defun parse-music-section (stream tune
 285                             &optional loop-channels in-loop-p)
 286   "Reads a music section from stream; returns at EOF or if a section
 287 change is detected.  Writes data and property changes to channels.
 288 Highly intolerant of malformed inputs."
 289   (eat-whitespace stream)
 290   (do ((current-channels (and in-loop-p loop-channels))
 291        (next-char #1=(peek-char nil stream) #1#))
 292       (nil)
 293           ;; Channel selection characters.
 294     (cond ((find next-char *channel-select-characters*)
 295            (setf current-channels nil)
 296            (dolist (c (expect-channels stream))
 297              (assert (< c (length (tune-channels tune)))
 298                      () "Invalid channel for this replay.")
 299              (push (nth c (tune-channels tune)) current-channels)))
 300
 301           ;; Repeats (unrolled loops).
 302           ((char= next-char #\[)
 303            (assert current-channels () "Command outside channels.")
 304            (read-char stream)
 305            (dolist (c current-channels)
 306              (push (channel-current-position c)
 307                    (channel-repeats c)))
 308            (parse-music-section stream tune current-channels t))
 309
 310           ((char= next-char #\])
 311            (assert (and in-loop-p
 312                         current-channels))
 313            (read-char stream)
 314            (let ((count (expect-int stream)))
 315              (dolist (c current-channels)
 316                (let ((begin (pop (channel-repeats c)))
 317                      (end (1- (channel-current-position c))))
 318                  (dotimes (i (1- count))
 319                    (copy-and-append-channel-data c begin end)))))
 320            (return))
 321
 322           ;; Octave changes.
 323           ((char= next-char #\o)
 324            (assert current-channels () "Command outside channels.")
 325            (read-char stream)
 326            (let ((octave (expect-int stream)))
 327              (dolist (c current-channels)
 328                (setf (channel-octave c) octave))))
 329
 330           ((char= next-char #\<)
 331            (assert current-channels () "Command outside channels.")
 332            (read-char stream)
 333            (dolist (c current-channels)
 334              (decf (channel-octave c))))
 335
 336           ((char= next-char #\>)
 337            (assert current-channels () "Command outside channels.")
 338            (read-char stream)
 339            (dolist (c current-channels)
 340              (incf (channel-octave c))))
 341
 342           ;; (Non-venv) volume changes.
 343           ((char= next-char #\v)
 344            (assert current-channels () "Command outside channels.")
 345            (handle-simple-volume stream current-channels))
 346
 347           ;; Notes and rests.
 348           ((find next-char *note-characters*)
 349            (assert current-channels () "Command outside channels.")
 350            (multiple-value-bind (note-char accidentals duration)
 351                (expect-note stream)
 352              (dolist (c current-channels)
 353                (vector-push-extend (make-note
 354                                     (calculate-tone note-char
 355                                                     accidentals
 356                                                     (channel-octave c))
 357                                     (clarify-duration duration c))
 358                                    (channel-data-stream c)))))
 359
 360           ((or (char= next-char #\r) (char= next-char #\w))
 361            (assert current-channels () "Command outside channels.")
 362            (multiple-value-bind (note-type duration)
 363                (expect-rest stream)
 364              (dolist (c current-channels)
 365                (vector-push-extend (make-note note-type
 366                                               (clarify-duration duration c))
 367                                    (channel-data-stream c)))))
 368
 369           ;; Tempo change.
 370           ((char= next-char #\t)
 371            (assert current-channels () "Command outside channels.")
 372            (read-char stream)
 373            (let ((tempo (expect-int stream)))
 374              (dolist (c current-channels)
 375                (vector-push-extend (make-tempo-command tempo)
 376                                    (channel-data-stream c))
 377                (setf (channel-tempo c) tempo))))
 378
 379           ;; Section change.
 380           ((char= next-char #\#)
 381            (read-char stream)
 382            (when in-loop-p
 383              (warn "Changing sections during a [] repeat.  ~
 384                     This probably won't work."))
 385            (return))
 386
 387           ;; Staccato.
 388           ((char= next-char #\q)
 389            (assert current-channels () "Command outside channels.")
 390            (read-char stream)
 391            (let ((staccato (* *staccato-base-division* (expect-int stream))))
 392              (dolist (c current-channels)
 393                (vector-push-extend (make-staccato-command staccato)
 394                                    (channel-data-stream c))
 395                (setf (channel-staccato c) staccato))))
 396
 397           ;; Macro invocation.
 398           ((char= next-char #\@)
 399            (assert current-channels () "Command outside channels.")
 400            (parse-macro-invocation stream current-channels))
 401
 402           ;; Structural dispatch character.
 403           ((char= next-char #\!)
 404            (assert current-channels () "Command outside channels.")
 405            (parse-bang-invocation stream current-channels))
 406
 407           ;; Replay-special invocation.
 408           ((char= next-char #\%)
 409            (assert current-channels () "Command outside channels.")
 410            (read-char stream)
 411            (funcall (replay-special-handler (tune-replay tune))
 412                     stream current-channels))
 413
 414           ;; Comment.
 415           ((char= next-char #\;)
 416            (read-line stream))
 417
 418           ;; Something else?
 419           (t (format t "~&Ignored character in music section: ~A (~:*~S)"
 420                      (read-char stream))))
 421     (eat-whitespace stream *ws-and-barline-characters*)))
 422
 423
 424 ;;; XXX: should use *macro-table-mapping*
 425 (defun parse-macro-invocation (stream channels)
 426   (read-char stream)
 427   (let ((next-char (peek-char nil stream)))
 428           ;; Arpeggio.
 429     (cond ((char= next-char #\a)
 430            (read-char stream)
 431            (let ((arp-num (expect-int stream)))
 432              (dolist (c channels)
 433                (vector-push-extend (make-arpeggio-command arp-num)
 434                                    (channel-data-stream c)))))
 435           ;; Volume envelope.
 436           ((char= next-char #\v)
 437            (read-char stream)
 438            (let ((venv-num (expect-int stream)))
 439              (dolist (c channels)
 440                (vector-push-extend (make-volume-envelope-command venv-num)
 441                                    (channel-data-stream c)))))
 442
 443           ;; Vibrato.
 444           ((char= next-char #\~)
 445            (read-char stream)
 446            (let ((vibrato-num (expect-int stream)))
 447              (dolist (c channels)
 448                (vector-push-extend (make-vibrato-command vibrato-num)
 449                                    (channel-data-stream c)))))
 450
 451           ;; Something else?
 452           (t (format t "~&Ignored macro invocator: @~A (~:*~S)"
 453                      (read-char stream))))))
 454
 455
 456 (defun parse-bang-invocation (stream channels)
 457   (assert (char= (read-char stream) #\!))
 458   (let* ((symbol (read stream)))
 459     (ecase symbol
 460       (LOOP
 461          (dolist (c channels)
 462            (setf (channel-loop-point c) (channel-current-position c))))
 463       (END
 464        (format t "~&I'm afraid !end is currently unsupported.")
 465        ;;; XXX how to handle this nicely?
 466        #+nil(dolist (c channels)
 467               (vector-push-extend (make-track-end-command)
 468                                   (channel-data-stream c)))))))