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 ;;;; HIGH-LEVEL PARSE ROUTINES.
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
)
174 ;; Any preamble that occurs before the first section is ignored.
175 (parse-comment-section stream
)
177 (do ((section (read stream
) (read stream
)))
179 ;; Note that the section handler is always responsible for
180 ;; eating the # sign so we don't see it.
182 (COMMENT (parse-comment-section stream
))
183 (MACROS (parse-macro-section stream tune
))
184 (HEADER (parse-header-section stream tune
))
185 (MUSIC (parse-music-section stream tune
))))
186 (end-of-file () tune
))))
189 (defun parse-comment-section (stream)
190 (do () ((char= (read-char stream
) #\
#))))
192 (defun parse-header-section (stream tune
)
193 (let ((*readtable
* (copy-readtable))
195 (set-macro-character #\
#
196 (lambda (stream char
)
197 (declare (ignore stream char
))
199 (do ((header (read stream
) (read stream
)))
201 (let ((argument (read stream
)))
204 ;; XXX genericize replay stuff
205 (assert (set-tune-replay argument tune
))
206 (setf (tune-channels tune
)
207 (replay-create-channels (tune-replay tune
))))
208 ((TITLE COMPOSER COPYRIGHT
)
209 (push (list header argument
) (tune-metadata tune
))))))))
212 (defun parse-macro-section (stream tune
)
213 (do ((next-char #1=(peek-char nil stream
) #1#))
215 (cond ((char= next-char
#\
@)
216 (multiple-value-bind (table index entry
)
217 (read-macro-definition stream
)
218 (assert (plusp index
) ()
219 "Bad index ~A (tables index from 1 -- 0 is the ~
220 \"effect off\" index)." index
)
221 (format t
"~&got macro ~A ~A ~A" table index entry
)
222 (unless (tune-get-table tune table
)
223 (tune-add-table tune table
))
224 (tune-add-to-table tune table index entry
)))
227 ((char= next-char
#\
#)
232 ((char= next-char
#\
;)
236 (t (format t
"~&Ignored character in macro section: ~A (~:*~S)"
237 (read-char stream
))))
238 (eat-whitespace stream
)))
240 ;; possible ``dispatch table'' format for routine below?
242 ((octave (progn (read-char stream
) (expect-int stream
))))
243 (setf (channel-octave channel
) octave
))
246 (decf (channel-octave c
)))
248 ((note-char accidentals duration
) (expect-note stream
))
249 (push (make-note (calculate-tone note-char
251 (channel-octave channel
))
252 (clarify-duration duration channel
))
253 (channel-data-stream channel
))))
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#))
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
)))
273 ;; Repeats (unrolled loops).
274 ((char= next-char
#\
[)
275 (assert current-channels
() "Command outside channels.")
277 (dolist (c current-channels
)
278 (push (channel-current-position c
)
279 (channel-repeats c
)))
280 (parse-music-section stream tune current-channels t
))
282 ((char= next-char
#\
])
283 (assert (and in-loop-p
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
)))))
295 ((char= next-char
#\o
)
296 (assert current-channels
() "Command outside channels.")
298 (let ((octave (expect-int stream
)))
299 (dolist (c current-channels
)
300 (setf (channel-octave c
) octave
))))
302 ((char= next-char
#\
<)
303 (assert current-channels
() "Command outside channels.")
305 (dolist (c current-channels
)
306 (decf (channel-octave c
))))
308 ((char= next-char
#\
>)
309 (assert current-channels
() "Command outside channels.")
311 (dolist (c current-channels
)
312 (incf (channel-octave c
))))
315 ((find next-char
*note-characters
*)
316 (assert current-channels
() "Command outside channels.")
317 (multiple-value-bind (note-char accidentals duration
)
319 (dolist (c current-channels
)
320 (vector-push-extend (make-note
321 (calculate-tone note-char
324 (clarify-duration duration c
))
325 (channel-data-stream c
)))))
327 ((or (char= next-char
#\r) (char= next-char
#\w
))
328 (assert current-channels
() "Command outside channels.")
329 (multiple-value-bind (note-type duration
)
331 (dolist (c current-channels
)
332 (vector-push-extend (make-note note-type
333 (clarify-duration duration c
))
334 (channel-data-stream c
)))))
337 ((char= next-char
#\t)
338 (assert current-channels
() "Command outside channels.")
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
))))
347 ;; XXX: add something to complain about unfinished loops.
348 ((char= next-char
#\
#)
351 (format t
"WARNING: changing sections during a [] repeat. ~
352 This probably won't work."))
356 ((char= next-char
#\q
)
357 (assert current-channels
() "Command outside channels.")
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
))))
366 ((char= next-char
#\
@)
367 (assert current-channels
() "Command outside channels.")
368 (parse-macro-invocation stream current-channels
))
370 ;; Structural dispatch character.
371 ((char= next-char
#\
!)
372 (assert current-channels
() "Command outside channels.")
373 (parse-bang-invocation stream current-channels
))
375 ;; Replay-special invocation.
376 ((char= next-char
#\%
)
377 (assert current-channels
() "Command outside channels.")
379 (replay-special-handler (tune-replay tune
) stream
380 (tune-channels tune
)))
383 ((char= next-char
#\
;)
387 (t (format t
"~&Ignored character in music section: ~A (~:*~S)"
388 (read-char stream
))))
389 (eat-whitespace stream
*ws-and-barline-characters
*)))
392 (defun parse-macro-invocation (stream channels
)
394 (let ((next-char (peek-char nil stream
)))
396 (cond ((char= next-char
#\a)
398 (let ((arp-num (expect-int stream
)))
400 (vector-push-extend (make-arpeggio-command arp-num
)
401 (channel-data-stream c
)))))
403 ((char= next-char
#\v)
405 (let ((venv-num (expect-int stream
)))
407 (vector-push-extend (make-volume-envelope-command venv-num
)
408 (channel-data-stream c
)))))
411 ((char= next-char
#\~
)
413 (let ((vibrato-num (expect-int stream
)))
418 (t (format t
"~&Ignored macro invocator: @~A (~:*~S)"
419 (read-char stream
))))))
422 (defun parse-bang-invocation (stream channels
)
423 (let ((symbol (read stream
)))
427 (setf (channel-loop-point c
) (channel-current-position c
))))
429 ;;; XXX how to handle this nicely?
430 #+nil
(dolist (c channels
)
431 (vector-push-extend (make-track-end-command)
432 (channel-data-stream c
)))))))