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                  (replay-create-channels (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   (do ((next-char #1=(peek-char nil stream) #1#))
 241       (nil)
 242     (cond ((char= next-char #\@)
 243            (multiple-value-bind (table index entry)
 244                (read-macro-definition stream)
 245              (assert (plusp index) ()
 246                      "Bad index ~A (tables index from 1 -- 0 is the ~
 247                      \"effect off\" index)." index)
 248              (unless (tune-get-table tune table)
 249                (tune-add-table tune table))
 250              (tune-add-to-table tune table index entry)))
 251
 252           ;; Section change.
 253           ((char= next-char #\#)
 254            (read-char stream)
 255            (return))
 256
 257           ;; Comment.
 258           ((char= next-char #\;)
 259            (read-line stream))
 260
 261           ;; Something else?
 262           (t (format t "~&Ignored character in macro section: ~A (~:*~S)"
 263                      (read-char stream))))
 264     (eat-whitespace stream)))
 265
 266 ;; possible ``dispatch table'' format for routine below?
 267 #+nil '((#\o
 268    ((octave (progn (read-char stream) (expect-int stream))))
 269    (setf (channel-octave channel) octave))
 270   (#\<
 271    nil
 272    (decf (channel-octave c)))
 273   (*note-characters*
 274    ((note-char accidentals duration) (expect-note stream))
 275    (push (make-note (calculate-tone note-char
 276                                     accidentals
 277                                     (channel-octave channel))
 278                     (clarify-duration duration channel))
 279     (channel-data-stream channel))))
 280
 281
 282
 283 (defun parse-music-section (stream tune
 284                             &optional loop-channels in-loop-p)
 285   "Reads a music section from stream; returns at EOF or if a section
 286 change is detected.  Writes data and property changes to channels.
 287 Highly intolerant of malformed inputs."
 288   (do ((current-channels (and in-loop-p loop-channels))
 289        (next-char #1=(peek-char nil stream) #1#))
 290       (nil)
 291           ;; Channel selection characters.
 292     (cond ((find next-char *channel-select-characters*)
 293            (setf current-channels nil)
 294            (dolist (c (expect-channels stream))
 295              (assert (< c (length (tune-channels tune)))
 296                      () "Invalid channel for this replay.")
 297              (push (nth c (tune-channels tune)) current-channels)))
 298
 299           ;; Repeats (unrolled loops).
 300           ((char= next-char #\[)
 301            (assert current-channels () "Command outside channels.")
 302            (read-char stream)
 303            (dolist (c current-channels)
 304              (push (channel-current-position c)
 305                    (channel-repeats c)))
 306            (parse-music-section stream tune current-channels t))
 307
 308           ((char= next-char #\])
 309            (assert (and in-loop-p
 310                         current-channels))
 311            (read-char stream)
 312            (let ((count (expect-int stream)))
 313              (dolist (c current-channels)
 314                (let ((begin (pop (channel-repeats c)))
 315                      (end (1- (channel-current-position c))))
 316                  (dotimes (i (1- count))
 317                    (copy-and-append-channel-data c begin end)))))
 318            (return))
 319
 320           ;; Octave changes.
 321           ((char= next-char #\o)
 322            (assert current-channels () "Command outside channels.")
 323            (read-char stream)
 324            (let ((octave (expect-int stream)))
 325              (dolist (c current-channels)
 326                (setf (channel-octave c) octave))))
 327
 328           ((char= next-char #\<)
 329            (assert current-channels () "Command outside channels.")
 330            (read-char stream)
 331            (dolist (c current-channels)
 332              (decf (channel-octave c))))
 333
 334           ((char= next-char #\>)
 335            (assert current-channels () "Command outside channels.")
 336            (read-char stream)
 337            (dolist (c current-channels)
 338              (incf (channel-octave c))))
 339
 340           ;; (Non-venv) volume changes.
 341           ((char= next-char #\v)
 342            (assert current-channels () "Command outside channels.")
 343            (handle-simple-volume stream current-channels))
 344
 345           ;; Notes and rests.
 346           ((find next-char *note-characters*)
 347            (assert current-channels () "Command outside channels.")
 348            (multiple-value-bind (note-char accidentals duration)
 349                (expect-note stream)
 350              (dolist (c current-channels)
 351                (vector-push-extend (make-note
 352                                     (calculate-tone note-char
 353                                                     accidentals
 354                                                     (channel-octave c))
 355                                     (clarify-duration duration c))
 356                                    (channel-data-stream c)))))
 357
 358           ((or (char= next-char #\r) (char= next-char #\w))
 359            (assert current-channels () "Command outside channels.")
 360            (multiple-value-bind (note-type duration)
 361                (expect-rest stream)
 362              (dolist (c current-channels)
 363                (vector-push-extend (make-note note-type
 364                                               (clarify-duration duration c))
 365                                    (channel-data-stream c)))))
 366
 367           ;; Tempo change.
 368           ((char= next-char #\t)
 369            (assert current-channels () "Command outside channels.")
 370            (read-char stream)
 371            (let ((tempo (expect-int stream)))
 372              (dolist (c current-channels)
 373                (vector-push-extend (make-tempo-command tempo)
 374                                    (channel-data-stream c))
 375                (setf (channel-tempo c) tempo))))
 376
 377           ;; Section change.
 378           ;; XXX: add something to complain about unfinished loops.
 379           ((char= next-char #\#)
 380            (read-char stream)
 381            (when in-loop-p
 382              (format t "WARNING: changing sections during a [] repeat.  ~
 383                        This probably won't work."))
 384            (return))
 385
 386           ;; Staccato.
 387           ((char= next-char #\q)
 388            (assert current-channels () "Command outside channels.")
 389            (read-char stream)
 390            (let ((staccato (* *staccato-base-division* (expect-int stream))))
 391              (dolist (c current-channels)
 392                (vector-push-extend (make-staccato-command staccato)
 393                                    (channel-data-stream c))
 394                (setf (channel-staccato c) staccato))))
 395
 396           ;; Macro invocation.
 397           ((char= next-char #\@)
 398            (assert current-channels () "Command outside channels.")
 399            (parse-macro-invocation stream current-channels))
 400
 401           ;; Structural dispatch character.
 402           ((char= next-char #\!)
 403            (assert current-channels () "Command outside channels.")
 404            (parse-bang-invocation stream current-channels))
 405
 406           ;; Replay-special invocation.
 407           ((char= next-char #\%)
 408            (assert current-channels () "Command outside channels.")
 409            (read-char stream)
 410            (replay-special-handler (tune-replay tune) stream
 411                                    (tune-channels tune)))
 412
 413           ;; Comment.
 414           ((char= next-char #\;)
 415            (read-line stream))
 416
 417           ;; Something else?
 418           (t (format t "~&Ignored character in music section: ~A (~:*~S)"
 419                      (read-char stream))))
 420     (eat-whitespace stream *ws-and-barline-characters*)))
 421
 422
 423 (defun parse-macro-invocation (stream channels)
 424   (read-char stream)
 425   (let ((next-char (peek-char nil stream)))
 426           ;; Arpeggio.
 427     (cond ((char= next-char #\a)
 428            (read-char stream)
 429            (let ((arp-num (expect-int stream)))
 430              (dolist (c channels)
 431                (vector-push-extend (make-arpeggio-command arp-num)
 432                                    (channel-data-stream c)))))
 433           ;; Volume envelope.
 434           ((char= next-char #\v)
 435            (read-char stream)
 436            (let ((venv-num (expect-int stream)))
 437              (dolist (c channels)
 438                (vector-push-extend (make-volume-envelope-command venv-num)
 439                                    (channel-data-stream c)))))
 440
 441           ;; Vibrato.
 442           ((char= next-char #\~)
 443            (read-char stream)
 444            (let ((vibrato-num (expect-int stream)))
 445              ;; XXX unimplemented
 446              vibrato-num))
 447
 448           ;; Something else?
 449           (t (format t "~&Ignored macro invocator: @~A (~:*~S)"
 450                      (read-char stream))))))
 451
 452
 453 (defun parse-bang-invocation (stream channels)
 454   (assert (char= (read-char stream) #\!))
 455   (let* ((symbol (read stream)))
 456     (ecase symbol
 457       (LOOP
 458          (dolist (c channels)
 459            (setf (channel-loop-point c) (channel-current-position c))))
 460       (END
 461        (format t "~&I'm afraid !end is currently unsupported.")
 462        ;;; XXX how to handle this nicely?
 463        #+nil(dolist (c channels)
 464               (vector-push-extend (make-track-end-command)
 465                                   (channel-data-stream c)))))))