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.
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.
15 ;;; (an abashed) Julian Squires <tek@wiw.org> / 2004
20 ;;;; CONSTANTS AND PARAMETERS.
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
#\|
))
28 (defconstant +octave-size
+ 12)
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)
36 ;;;; LOW-LEVEL PARSE/LEX ROUTINES.
38 (defun digit-to-int (char)
39 (- (char-code char
) (char-code #\
0)))
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#)
46 ((not (find next-char
*duration-digits
*)) int
)
47 (let ((digit (digit-to-int (read-char stream
))))
49 (setf int
(+ (* int
10) digit
))
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
)
61 (when (and (plusp dots
) (null duration
))
62 (error "Bad duration (relative dots are not allowed)."))
64 (orig duration
(/ orig
2)))
66 (incf duration
(/ orig
2)))
69 (unless (null duration
)
70 (do ((next-char #2=(peek-char nil stream
) #2#))
71 ((char/= next-char
#\^
))
73 (incf duration
(make-duration (expect-int stream
)))))
77 (defun read-accidentals (stream)
78 (do ((next-char #1=(peek-char nil stream
) #1#)
80 ((char/= next-char
#\
+ #\-
) accidentals
)
81 (if (char= (read-char stream
) #\
+)
85 (defun expect-note (stream)
86 (let* ((note-char (read-char stream
))
87 (accidentals (read-accidentals stream
))
88 (duration (expect-duration stream
)))
90 ;; this function should always be called when we know there's a
91 ;; note character next.
92 (assert (find note-char
*note-characters
*))
94 (values note-char accidentals duration
)))
96 (defun expect-rest (stream)
97 (let ((rest-char (read-char stream
))
98 (duration (expect-duration stream
)))
100 (if (char= rest-char
#\r)
101 (values :rest duration
)
102 (values :wait duration
))))
104 (defun expect-channels (stream)
105 (do ((next-char #1=(peek-char nil stream
) #1#)
107 ((not (find next-char
*channel-select-characters
*)) channels
)
109 (push (- (char-code (read-char stream
))
110 (char-code (char *channel-select-characters
* 0)))
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
)))
118 (defun expect-= (stream)
119 (eat-whitespace stream
)
120 (assert (char= (read-char stream
) #\
=))
121 (eat-whitespace stream
))
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#)
128 ((char= next-char
#\
}) (progn (read-char stream
)
130 (cond ((char= next-char
#\|
)
133 ((find next-char
"0123456789-")
134 (push (read stream
) list
))
137 (format t
"~&Warning: ignored ~A in macro definition."
139 (eat-whitespace stream
)))
141 (defun read-symbols-macro (stream)
142 (assert (char= (read-char stream
) #\
{))
143 (eat-whitespace stream
)
144 (do ((symbol (read stream
) (read stream
))
146 ((eql symbol
'}) (reverse list
))
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
)))
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
162 (values (second mapping
) index
(funcall (third mapping
) stream
))))
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
)))
172 (make-simple-volume-command volume
)
173 (channel-data-stream c
))
174 (setf (channel-volume c
) volume
))))
175 ((char= next-char
#\
+)
179 (make-simple-volume-command (1+ (channel-volume c
)))
180 (channel-data-stream c
))))
181 ((char= next-char
#\-
)
185 (make-simple-volume-command (1- (channel-volume c
)))
186 (channel-data-stream c
))))
187 (t (error "~&Bad volume character: v~A" next-char
)))))
191 ;;;; HIGH-LEVEL PARSE ROUTINES.
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
))
201 ;; Any preamble that occurs before the first section is ignored.
202 (parse-comment-section stream
)
204 (do ((section (read stream
) (read stream
)))
206 ;; Note that the section handler is always responsible for
207 ;; eating the # sign so we don't see it.
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
))))
216 (defun parse-comment-section (stream)
217 (do () ((char= (read-char stream
) #\
#))))
219 (defun parse-header-section (stream tune
)
220 (let ((*readtable
* (copy-readtable))
222 (set-macro-character #\
#
223 (lambda (stream char
)
224 (declare (ignore stream char
))
226 (do ((header (read stream
) (read stream
)))
228 (let ((argument (read stream
)))
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
))))))))
239 (defun parse-macro-section (stream tune
)
240 (eat-whitespace stream
)
241 (do ((next-char #1=(peek-char nil stream
) #1#))
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
)))
254 ((char= next-char
#\
#)
259 ((char= next-char
#\
;)
263 (t (format t
"~&Ignored character in macro section: ~A (~:*~S)"
264 (read-char stream
))))
265 (eat-whitespace stream
)))
267 ;; possible ``dispatch table'' format for routine below?
269 ((octave (progn (read-char stream
) (expect-int stream
))))
270 (setf (channel-octave channel
) octave
))
273 (decf (channel-octave c
)))
275 ((note-char accidentals duration
) (expect-note stream
))
276 (push (make-note (calculate-tone note-char
278 (channel-octave channel
))
279 (clarify-duration duration channel
))
280 (channel-data-stream channel
))))
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#))
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
)))
301 ;; Repeats (unrolled loops).
302 ((char= next-char
#\
[)
303 (assert current-channels
() "Command outside channels.")
305 (dolist (c current-channels
)
306 (push (channel-current-position c
)
307 (channel-repeats c
)))
308 (parse-music-section stream tune current-channels t
))
310 ((char= next-char
#\
])
311 (assert (and in-loop-p
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
)))))
323 ((char= next-char
#\o
)
324 (assert current-channels
() "Command outside channels.")
326 (let ((octave (expect-int stream
)))
327 (dolist (c current-channels
)
328 (setf (channel-octave c
) octave
))))
330 ((char= next-char
#\
<)
331 (assert current-channels
() "Command outside channels.")
333 (dolist (c current-channels
)
334 (decf (channel-octave c
))))
336 ((char= next-char
#\
>)
337 (assert current-channels
() "Command outside channels.")
339 (dolist (c current-channels
)
340 (incf (channel-octave c
))))
342 ;; (Non-venv) volume changes.
343 ((char= next-char
#\v)
344 (assert current-channels
() "Command outside channels.")
345 (handle-simple-volume stream current-channels
))
348 ((find next-char
*note-characters
*)
349 (assert current-channels
() "Command outside channels.")
350 (multiple-value-bind (note-char accidentals duration
)
352 (dolist (c current-channels
)
353 (vector-push-extend (make-note
354 (calculate-tone note-char
357 (clarify-duration duration c
))
358 (channel-data-stream c
)))))
360 ((or (char= next-char
#\r) (char= next-char
#\w
))
361 (assert current-channels
() "Command outside channels.")
362 (multiple-value-bind (note-type duration
)
364 (dolist (c current-channels
)
365 (vector-push-extend (make-note note-type
366 (clarify-duration duration c
))
367 (channel-data-stream c
)))))
370 ((char= next-char
#\t)
371 (assert current-channels
() "Command outside channels.")
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
))))
380 ;; XXX: add something to complain about unfinished loops.
381 ((char= next-char
#\
#)
384 (format t
"WARNING: changing sections during a [] repeat. ~
385 This probably won't work."))
389 ((char= next-char
#\q
)
390 (assert current-channels
() "Command outside channels.")
392 (let ((staccato (* *staccato-base-division
* (expect-int stream
))))
393 (dolist (c current-channels
)
394 (vector-push-extend (make-staccato-command staccato
)
395 (channel-data-stream c
))
396 (setf (channel-staccato c
) staccato
))))
399 ((char= next-char
#\
@)
400 (assert current-channels
() "Command outside channels.")
401 (parse-macro-invocation stream current-channels
))
403 ;; Structural dispatch character.
404 ((char= next-char
#\
!)
405 (assert current-channels
() "Command outside channels.")
406 (parse-bang-invocation stream current-channels
))
408 ;; Replay-special invocation.
409 ((char= next-char
#\%
)
410 (assert current-channels
() "Command outside channels.")
412 (replay-special-handler (tune-replay tune
) stream
416 ((char= next-char
#\
;)
420 (t (format t
"~&Ignored character in music section: ~A (~:*~S)"
421 (read-char stream
))))
422 (eat-whitespace stream
*ws-and-barline-characters
*)))
425 ;;; XXX: should use *macro-table-mapping*
426 (defun parse-macro-invocation (stream channels
)
428 (let ((next-char (peek-char nil stream
)))
430 (cond ((char= next-char
#\a)
432 (let ((arp-num (expect-int stream
)))
434 (vector-push-extend (make-arpeggio-command arp-num
)
435 (channel-data-stream c
)))))
437 ((char= next-char
#\v)
439 (let ((venv-num (expect-int stream
)))
441 (vector-push-extend (make-volume-envelope-command venv-num
)
442 (channel-data-stream c
)))))
445 ((char= next-char
#\~
)
447 (let ((vibrato-num (expect-int stream
)))
449 (vector-push-extend (make-vibrato-command vibrato-num
)
450 (channel-data-stream c
)))))
453 (t (format t
"~&Ignored macro invocator: @~A (~:*~S)"
454 (read-char stream
))))))
457 (defun parse-bang-invocation (stream channels
)
458 (assert (char= (read-char stream
) #\
!))
459 (let* ((symbol (read stream
)))
463 (setf (channel-loop-point c
) (channel-current-position c
))))
465 (format t
"~&I'm afraid !end is currently unsupported.")
466 ;;; XXX how to handle this nicely?
467 #+nil
(dolist (c channels
)
468 (vector-push-extend (make-track-end-command)
469 (channel-data-stream c
)))))))