From c685564e9fd406ca9d691d8eca1229f2c781dfc9 Mon Sep 17 00:00:00 2001 From: Julian Squires Date: Fri, 24 Dec 2004 07:20:29 +0100 Subject: [PATCH] Many new parsing features; reorganization; examples added. --- README | 129 ++++++++++++ examples/ch-1.mbl | 366 +++++++++++++++++++++++++++++++++ examples/demo-y.mbl | 93 +++++++++ mumble.asd | 18 ++ music-parser.lisp | 325 ----------------------------- music-utilities.lisp | 20 -- src/classes.lisp | 128 ++++++++++++ src/music-parser.lisp | 433 +++++++++++++++++++++++++++++++++++++++ src/music-utilities.lisp | 29 +++ package.lisp => src/package.lisp | 0 src/replay-xm.lisp | 18 ++ src/replay-ymamoto.lisp | 157 ++++++++++++++ tools/dot-s-to-sc68.sh | 17 ++ ymamoto.lisp | 133 ------------ 14 files changed, 1388 insertions(+), 478 deletions(-) create mode 100644 examples/ch-1.mbl create mode 100644 examples/demo-y.mbl create mode 100644 mumble.asd delete mode 100644 music-parser.lisp delete mode 100644 music-utilities.lisp create mode 100644 src/classes.lisp create mode 100644 src/music-parser.lisp create mode 100644 src/music-utilities.lisp rename package.lisp => src/package.lisp (100%) create mode 100644 src/replay-xm.lisp create mode 100644 src/replay-ymamoto.lisp create mode 100644 tools/dot-s-to-sc68.sh delete mode 100644 ymamoto.lisp diff --git a/README b/README index 040b11e..454670f 100644 --- a/README +++ b/README @@ -1,11 +1,140 @@ +mumble +Julian Squires / 2004 + + +Mumble is a package for converting text representations of music into +data for specific playroutines. The format, described in this +document, is a variant on the (popular?) Music Macro Language (or MML) +format. + +I started writing this package so I could convert some of my older +songs (written in MML, for the NES) to a new Atari ST playroutine I +was writing. Along the way, I realized that this was my opportunity +to make some changes to the input format, and start using a single +source for output for various playroutine targets. + +This format may not be ideal for formats with more than about eight +channels, but I rarely work with more than five, anyway. + + +PLAYROUTINES (REPLAYS) SUPPORTED + +* YMamoto -- my primitive Atari ST YM-2149 playroutine. + +REPLAYS I PLAN TO WRITE MYSELF AND SUPPORT + +* nes (soon) +* some kind of opl[23] playroutine. +* a SID replay. +* some snes spc replay + +UNSUPPORTED REPLAYS I'D LIKE TO SUPPORT + +* hubbard -- Rob Hubbard's "Monty on the Run" playroutine. +* mod -- Protracker-style 4-channel MODs. (no specific replay) +* ahx, fc +* mck +* something on the atari 800XL + + + +INPUT FORMAT BASICS + +I'll just describe significant differences from MML here, for the +moment. (See various documents on the MML format available in the NES +scene.) All of this syntax might change at any time. (Sorry.) + +The biggest obvious change is that the "l" command is gone, and now +note duration is relative to the previous note duration input for the +channel in question. Lilypond has this behavior, and I find it pretty +nice (also, it should make it easier for me to typeset the music in my +chiptunes). Unfortunately it's probably the most annoying thing about +converting old MML files over to mumble. I will probably add a +compatibility flag once I get sufficiently annoyed. + +You can put "|" in the input and it will be ignored; I find it makes +things a lot cleaner, as I can keep track of my barlines in the input. + +Generic macro dispatch is done with the "@" prefix, more in the style +of CL's "#" macro dispatch (partially because I've had some thoughts +of changing things to use CL readtables instead of doing all the +parsing myself). + +@a => arpeggio. Followed by digits indicating arpeggio number, + or 0 for arpeggio off. +@b => pitch macro (mnemonic: bend). +@d => volume macro? For scripting time signatures/repeated rhythmic + accents, etc. +@i => instrument. An instrument is, broadly, a snapshot of partial + channel state; what that means depends on the replay. +@t => tempo macro? For scripting rallentendos and accelerandos. +@v => (software) volume envelope. +@~ => vibrato. + + +Playroutine-specific commands are done with the "%" prefix, which +means that the old MML use of "%" to specify an absolute number of +ticks for a note is no longer supported. + +For example, I'll show a few "%" commands from my YM playroutine +support, and from my NES playroutine support. + +YM: + +%e[uo4] => set hardware envelope to follow current notes at {unison, + octave, 4th below}. +... envelope sweep, noise carrier, AM sample playback + +NES: + +... timbre switching; channel A hardware sweep; looped noise... + +SID: + +... timbre switching/PWM; filter control; hard reset control... + +The general idea is that one should be able to write a tune, and adapt +it to various platforms primarily by changing the "%" commands; "@" +commands should be basically common to all replays. (I'm also going +to think more about this and possibly support some kind of conditional +compilation or option to ignore certain commands when using a certain +replay.) + +Some playroutines require use of instruments for most effects, while +others don't use instruments at all. Playroutine outputs that don't +use instruments should silently translate instrument use to +appropriate commands. + +The old data skip command, "!", has become a dispatch for general +structural commands: + +!loop => song loop (formerly "L"). +!end => end of track (kind of like the old "!"). + + CAVEATS Dots in durations must follow an integer duration value. (You can't write, for example, "a4 b. c8") +Repeats ("[abcabc]42") are always unfolded during parsing, to keep +basic output routines simpler. It's my belief that the output routine +code can do its own repeat optimization if it wants to, and it can do +it better than a human. Repeats should be inserted to keep the +original clean and readable. + IDEAS Tempo macros, for defining rallentendos, accellerandos, fermatas, et cetera. + +Large-scale volume macros, to define time signatures, et cetera. + +The playroutine output code is responsible for complaining to the user +if a feature is not supported (for example, using vibrato outside of +an instrument definition; or defining more than 32 instruments); but +the events that trigger these complaints should have original file +information with them so that line and ideally character positions can +be reported back to the user. diff --git a/examples/ch-1.mbl b/examples/ch-1.mbl new file mode 100644 index 0000000..d7f1d70 --- /dev/null +++ b/examples/ch-1.mbl @@ -0,0 +1,366 @@ + +Adapted for YM from the original MML for NES, as a replay test. I +might convert this to some other system as an example once other +replays are supported. + +Original was written at Chip Weekend 1, July 2004. + +#HEADER + +replay "YMamoto" +title "sight for sore thumbs" +composer "tokenrove" +maker "Julian Squires " + +#MACROS + +;;;; INSTRUMENTS + +;; Violin? (a little rough) +@v1 = { 0 1 2 3 4 5 7 7 7 6 6 6 6 5 5 5 5 4 4 4 3 } +;%t0 = { 2 2 2 2 2 3 3 } + +;;; Generic lead vibratos +; Retsyn vibratos +@~1 = { delay 12 speed 3 depth 5 } +@~2 = { delay 22 speed 2 depth 4 } +; mild vibrato +@~3 = { delay 32 speed 2 depth 2 } + + +#MUSIC + +;;;; (G) Intro + +ABC t120 +A o3 q6 %2 v8 +B o2 q6 %2 v6 +C o1 q4 + +A r1 c2 +B c2. r4 f2. r4 d2. r4 +C r1 r1 r1 r1 + +A c2 c4 c8 d2 d4 c8d c2 f4.d8 g4 d4 +B e-2 f2 g2 f4 a-4 b-2 e-8rg a-8^2 b-8gfd +C r1 r1 q7 g1 f1 + +;;;; (A) Midpart in C minor + +ABC t120 +A o3 q6 %2 v8 +B o2 q6 %2 v6 +C o1 q4 + +AB @~0 + +A c4 c c4 d4 c4.r8 cd +B c8e-ga- f2 dfa- d2 c8cc ffa-f +C c4 >c8fg8e- dd>df +B c8fa-b g2 > +C a-4 f8>f< g4 b4 > + +A c4 c c4 d4 c4.r8 cd +B c8e-ga- f2 dfa- d2 c8cc ffa-f +C c4 >c8fg8e- dd>dff< g4 b4 + +;;;; (B) Bridge + +ABC t120 +A o3 q6 %2 v4 +B o2 q6 %2 v3 +C o1 q4 + +AB @~2 + +A g1 +B e-1 +C c2 q2 c4 c4 + +A a1 +B f1 +C d4 d4 d4 d4 + +A d2 f2 +B g2 d2 +C c1 +B g1 +C >c1 + +A c< q2 c4 + +A f1 +B d1 +C d4 d4 q6 d8>d< q2 d4 + +A d2 f4 f+4 +B g8ge-g bgdf f+ + +A >c1 +B c1 +C g2 >c2 + +;;;; (F) [modified] + +ABC t120 +A o3 q6 %2 v4 +B o3 q6 %2 v6 +C o1 q4 + +AB @~0 + +A [r1]2 >c4. d8e- f4. f8r fgf +B @1 q4 [g8e-c gdfr a-fd a-fc
]2 +C >[c4. f d4. f4. g4]2 + +A e-4.r8 de-f4 g4.a-8 gde- +B g8e-c gdfr ge- e-c de- +C c4. g4. f8>f e-4. a-4. g4 + +A v+ c4.e-8 d4.f8 +B g2 a-2 +C g8>cc< a->dd< + +A g4 f4 e-8d +B g4 a-2 +C g4 f4 e-4 + +;;;; (D) lamenting solo in C minor + +ABC t120 +A o3 q7 %2 v9 +B o2 q6 %2 v5 +C o1 q4 + +A @~1 + +A [c2. r8e-16dc8r d8^2 r2]2 +B r1 r1 b2 r2 a-4 g4 f4 e-4 +B c8e-gce-gce- ce-ce-c dd +; XXX maybe just drums over this first part, no bass? +C [q7 >c2.cdcde-< >e-16dc8r cd d8 f12e-d fe-d e-4.d8 +B c8e-gce-gce- ce-ce-c dd +C q7 >c4 c4 c4c16d16e-8r +B b-1 r1 r1 >d4 f4 d4 +C e-1 d2 g8b-gb- a-1 b-1 + +A c4 f8g f4 e-4 g8gdg8^2 c2 e-8d16c16 +B r1 r2 f8d< f4 d4> +C e-4 e-4 e-4 e-4 d4 d4 c4 c4 e-8a-e-a- d4 d4 f8b-fb- + +A dgr fe-8^2 c8cc c16d16e-8df4. +B r4 e-8e-ce-8^4 df +C e-4 e-4 e-4 e-4 d4 d4 g8b->dc16d8r d +B b-2.>c4 r1 c8cc rcd4 r4 f4 r4 +C e-4 e-4 e-4 e-4 d4 d4 c4 c4 e-8a->ce- d4 d4 c1 + +;;;; (B/H) Bridge + +ABC t120 +A o3 q6 %2 v4 +B o2 q6 %2 v3 +C o1 q4 + +AB @~2 + +;A g1 +;B e-1 +;C c2 q2 c4 c4 + +A f1 +B a1 +C d4 d4 d4 d4 + +A g2 f2 +B g2 d2 +C c1 +B g1 +C >c1 + +A c< q2 c4 + +A f1 +B d1 +C d4 d4 q6 d8>d< q2 d4 + +A d2 f4 g4 +B g8ge-g bgdf f+ + +A >c1 +B c1 +C g2 >c2 + +;;;; (A) Midpart in C minor repeat + +ABC t120 +A o3 q6 @2 v8 +B o2 q6 @2 v6 +C o1 q4 + +AB @~0 + +A c4 c c4 d4 c4.r8 cd +B c8e-ga- f2 dfa- d2 c8cc ffa-f +C c4 >c8fg8e- dd>df +B c8fa-b g2 > +C a-4 f8>f< g4 b4 > + +A c4 c c4 d4 c4.r8 cd +B c8e-ga- f2 dfa- d2 c8cc ffa-f +C c4 >c8fg8e- dd>dff< g4 b4 + +;;;; (F) + +ABC t120 +A o3 q6 @2 v4 +B o3 q6 @2 v6 +C o1 q4 + +AB @~0 + +A [r1]2 >c4. d8e- f4. f8r fgf +B @1 q4 [g8e-c gdfr a-fd a-fc
]2 +C >[c4. f d4. f4. g4]2 + +A g4.r8 cde- f4.r8 gab-a +B d8gdfr fdafd fg +C g4. d4. b- a4. d4. f + +A v+ g4.f8 d4.c8 +B b-2 a2 +C g8>dd< a>dd< + +A d2 +B g2 +C g2 + +;;;; (C) + +ABC t120 +A o2 q3 @2 v7 +B o2 q3 @0 v6 +C o1 q4 + +AB @~0 + +A r1 r1 r1 r1 ;b-b-fb- e-b-g>d fdced4.r de- ce< b-4.r8 grb->c e-4.g8 d4.f8 +C g4 >d8cec g< g4 >e-2 d2 + +A d8dd cge-g ccc e-4 c4 d4c8d g4 f4 +B <dgb- e-2 dfa8^2 f4.d8 g4.b8 +C g4 >d8cf8d db + +;;;; (B) Bridge again + +ABC t120 +;A o3 q6 @2 l8 v4 +;B o2 q6 @2 l8 v3 +C o1 q4 l8 + +AB @~2 + +A e-1 +B >c1 +C c2 q2 c4 c4 + +A a1 +B f1 +C d4 d4 d4 d4 + +A d2 f2 +B g2 d2 +C c1 +B g1 +C >c1 + +A c< q2 c4 + +A f1 +B d1 +C d4 d4 q6 d8>d< q2 d4 + +A d2 f4 g4 +B g8ge-g bgdf f+ + +A >c1 +B c1 +C g2 >c2 + +;;;; (I) Final cadence. + +ABC t120 +A o3 q6 @2 v7 +B o2 q6 @2 v6 +C o1 q4 + +AB @~1 + +;A d2 f4 g4 +ABC t115 +A g8^2 b4. +B g8ge-g bgd +C q6 f f+ + +ABC t110 +A >c2. r8 +B c4. e-4. g8r +C g2 >c2 + +ABC t100 +A g8^2 b4. +B b-8b-gb- d4f f+ + +ABC t90 +A >c1 +B >c1 +C >c1 + diff --git a/examples/demo-y.mbl b/examples/demo-y.mbl new file mode 100644 index 0000000..d688ec3 --- /dev/null +++ b/examples/demo-y.mbl @@ -0,0 +1,93 @@ + +Transcription of YM tune for Ngaire. +Julian Squires / 2004 + +#HEADER + +replay "YMamoto" +title "Demo-y" +composer "tokenrove" +copyright "Julian Squires / 2004" + +#MACROS + +;; it's so great to arpeggiate. +@a1 = { 0 | 3 9 -12 } +@a2 = { 0 | 5 7 -12 } +@a3 = { 0 | 3 4 -7 } +@a4 = { 0 | 5 4 -9 } +@a5 = { 0 | 5 3 -8 } +@a6 = { 0 | 2 3 -5 } +@a7 = { 0 | 6 3 -9 } +@a8 = { 0 | 4 3 -7 } +@a9 = { 0 | 4 8 -12 } + +#MUSIC + +;;;; D minor. + +ABC t128 +B q4 + +A o2 d1 | f | +B o4 @a1 [d8d16d]3 d8d | @a2 [c8c16c]3 c8c | +C r1 | r | + +A b- | a2 g2 | +B [f8f16f]3 f8f | @a1 e8e16ee8e @a2 ee16ee8e | +C r | r | + +#COMMENT Drums should kick in here. #MUSIC + +ABC !loop + +A q6 d4 d d d8>d< | f4 f f f8e | +B @a1 [d8d16d]3 d8d | @a2 [c8c16c]3 c8c | +C r | r | +;D k8 h h h s h h h | k8 h h h s h h h | + +A b-4 b- b- b-8>f< | a4 a8>a< g4 g8>c+< | +B [f8f16f]3 f8f | @a1 e8e16ee8e @a2 ee16ee8e | +C r | r | +;D k8 h h h s h h h | k8 h16hh8h s h16hhsh8 | + + +A d4 d d d8>d< | f4 f f f8e | +B @a1 [d8d16d]3 d8d | @a2 [c8c16c]3 c8c | +C o5 d2. f4 | a2 g8 f e c+ | + +A b-4 b- b- b-8>f< | a4 a8>a< g4 g8>c+< | +B [f8f16f]3 f8f | @a1 e8e16ee8e @a2 ee16ee8e | +C d4 f | g2 a4 c+ | + + +A d4 d d d8>d< | f4 f f f8e | +B o4 @a3 [d8d16d]3 d8d | @a4 [c8c16c]3 c8c | +C o5 d2. f4 | a2 g8 f d e | + +A a4 a a a8b- | g4 g8>e< a4 a8g+ | +B @a5 e8e16ee8e @a6 gg16gg8g | @a7 b-8b-16b-b-8b- @a8 aa16a @a9 a8a | +C c2 e4 a | b-2 a4 >c+ | + +;;;; A minor. + +B @a0 q4 +C q2 +A o1 a4 a a a8>a | c4 c c c8cec a4 g | >c4 f4 f f f8>c< | e4 e8>e< d4 d8g+ | +B >[c8c16c]3 c8c< | b8b16bb8b bb16bb8b | +C f2 a8>cea | b2 g4 g+ | + + +A a | c4 c c c8c4c8 e4 f4 f f f8>c< | e4 e8>e< d4 d8g+ | +B >[c8c16c]3 c8c< | b8b16bb8b bb16bb8b | +C >c16cee< | + +;; end of data. \ No newline at end of file diff --git a/mumble.asd b/mumble.asd new file mode 100644 index 0000000..3aa229c --- /dev/null +++ b/mumble.asd @@ -0,0 +1,18 @@ +;; -*- Lisp -*- + +(defpackage #:mumble-system (:use #:cl #:asdf)) +(in-package #:mumble-system) + +(defsystem mumble + :depends-on (:anaphora) + :components + ((:module :src + :components + ((:file "package") + (:file "classes" :depends-on ("package")) + (:file "music-parser" :depends-on ("classes" + "music-utilities")) + (:file "music-utilities" :depends-on ("classes")) + (:file "replay-ymamoto" :depends-on ("music-parser")) + (:file "replay-xm" :depends-on ("music-parser")))))) + diff --git a/music-parser.lisp b/music-parser.lisp deleted file mode 100644 index 0adc1de..0000000 --- a/music-parser.lisp +++ /dev/null @@ -1,325 +0,0 @@ -;;; -;;; Several of these functions are very flaky WRT EOF, and that should -;;; eventually be fixed. This is all just a quick hack. Most of this -;;; could be converted to a very data-driven style of programming. -;;; -;;; Other things that should be checked/fixed: -;;; - durations should get tweaked (say, by parse-music-section) if -;;; we're inside a triplet or tuplet figure. -;;; - haven't figured out yet who should deal with specifying an -;;; initial tempo if we don't find one before the first note. I -;;; have a feeling I should just have this code insert a tempo -;;; set event on any channel where we get a duration-dependant -;;; event before any tempo is set. -;;; -;;; (an abashed) Julian Squires / 2004 -;;; - -(in-package :mumble) - -;;;; CONSTANTS AND PARAMETERS. - -(defparameter *channel-select-characters* "ABCDEFGHIJ") -(defparameter *duration-digits* "0123456789") -(defparameter *note-characters* "c_d_ef_g_a_b") -(defparameter *whitespace-characters* #(#\Space #\Newline #\|)) - -(defconstant +octave-size+ 12) - -(defparameter *staccato-base-division* 1/8) -(defparameter *default-duration* (make-duration 4)) -(defparameter *default-octave* 4) -(defparameter *default-staccato* 1) -(defparameter *default-tempo* 120) - - -;;;; CLASSES AND DATA STRUCTURES. - -(defclass duration () - ((denominator :reader duration-denominator) - ;; other modifiers here - (dots :reader duration-dots))) - -(defun make-duration (denominator &optional (dots 0)) - (when denominator - (let ((duration (make-instance 'duration))) - (setf (slot-value duration 'denominator) denominator) - (setf (slot-value duration 'dots) dots) - duration))) - -(defmethod print-object ((obj duration) stream) - (print-unreadable-object (obj stream :type t) - (princ (duration-denominator obj) stream) - (dotimes (i (duration-dots obj)) - (princ #\. stream)))) - - -(defclass music-command () - ((type :reader music-command-type) - (value :reader music-command-value))) - -(defun make-tempo-command (tempo) - (let ((cmd (make-instance 'music-command))) - (setf (slot-value cmd 'type) :tempo) - (setf (slot-value cmd 'value) tempo) - cmd)) - -(defun make-staccato-command (staccato) - (let ((cmd (make-instance 'music-command))) - (setf (slot-value cmd 'type) :staccato) - (setf (slot-value cmd 'value) staccato) - cmd)) - -;; This might become a special macro-command later. -(defun make-arpeggio-command (n) - (let ((cmd (make-instance 'music-command))) - (setf (slot-value cmd 'type) :arpeggio) - (setf (slot-value cmd 'value) n) - cmd)) - - -(defclass note (music-command) - ((tone :reader note-tone) - (duration :reader note-duration)) - (:documentation "Notes encapsulate an absolute pitch (the TONE slot) -and a relative length (the DURATION slot). DURATION is relative to -the current channel tempo.")) - -(defun make-note (tone duration) - (let ((note (make-instance 'note))) - (setf (slot-value note 'type) :note) - (setf (slot-value note 'tone) tone) - (setf (slot-value note 'duration) duration) - note)) - -(defmethod print-object ((obj note) stream) - (print-unreadable-object (obj stream :type t) - (princ (note-tone obj) stream) - (princ #\Space stream) - (princ (note-duration obj) stream))) - - -(defclass channel () - ((octave :accessor channel-octave) - (tempo :accessor channel-tempo) - (staccato :accessor channel-staccato) - (duration :accessor channel-default-duration) - (loop-point :accessor channel-loop-point) - (data-stream :accessor channel-data-stream))) - -(defun make-channel () - (let ((channel (make-instance 'channel))) - (setf (channel-octave channel) *default-octave*) - (setf (channel-tempo channel) *default-tempo*) - (setf (channel-staccato channel) *default-staccato*) - (setf (channel-default-duration channel) *default-duration*) - (setf (channel-data-stream channel) nil) - channel)) - - - -;;;; LOW-LEVEL PARSE/LEX ROUTINES. - -(defun digit-to-int (char) - (- (char-code char) (char-code #\0))) - -(defun clarify-duration (duration channel) - (if duration - (setf (channel-default-duration channel) duration) - (channel-default-duration channel))) - -(defun expect-int (stream) - ;; if the next character is a digit, read digits until the next - ;; character is not a digit. - (do ((next-char #1=(peek-char nil stream) #1#) - (int nil)) - ((not (find next-char *duration-digits*)) int) - (let ((digit (digit-to-int (read-char stream)))) - (if int - (setf int (+ (* int 10) digit)) - (setf int digit))))) - -(defun expect-duration (stream) - (let ((duration (make-duration (expect-int stream))) - ;; if the next character is a dot, read dots until the next - ;; character is not a dot. - (dots (do ((next-char #2=(peek-char nil stream) #2#) - (number-of-dots 0 (1+ number-of-dots))) - ((char/= next-char #\.) number-of-dots) - (read-char stream)))) - - (when (plusp dots) - (setf (slot-value duration 'dots) dots)) - duration)) - -(defun calculate-tone (char accidentals octave) - (let ((tone-value (* +octave-size+ octave))) - (incf tone-value - (do ((i 0 (1+ i))) - ((char= char (schar *note-characters* i)) i) - (assert (< i (length *note-characters*))))) - (incf tone-value accidentals) - tone-value)) - -(defun read-accidentals (stream) - (do ((next-char #1=(peek-char nil stream) #1#) - (accidentals 0)) - ((char/= next-char #\+ #\-) accidentals) - (if (char= (read-char stream) #\+) - (incf accidentals) - (decf accidentals)))) - -(defun expect-note (stream) - (let* ((note-char (read-char stream)) - (accidentals (read-accidentals stream)) - (duration (expect-duration stream))) - - ;; this function should always be called when we know there's a - ;; note character next. - (assert (find note-char *note-characters*)) - - (values note-char accidentals duration))) - -(defun expect-rest (stream) - (let ((rest-char (read-char stream)) - (duration (expect-duration stream))) - - (if (char= rest-char #\r) - (values :rest duration) - (values :wait duration)))) - -(defun expect-channels (stream) - (do ((next-char #1=(peek-char nil stream) #1#) - (channels)) - ((not (find next-char *channel-select-characters*)) channels) - ;; XXX dumb hack - (push (- (char-code (read-char stream)) - (char-code (char *channel-select-characters* 0))) - channels))) - -(defun eat-whitespace-and-barlines (stream) - (do ((next-char #1=(peek-char nil stream) #1#)) - ((not (find next-char *whitespace-characters*))) - (read-char stream))) - - -(defmacro mv-push (source destination key) - `(do ((d ,destination (cdr d)) - (s ,source (cdr s))) - ((not d)) - (push (car s) (,key (car d))))) - - -;;;; HIGH-LEVEL PARSE ROUTINES. - -(defun parse-music-section (stream channels) - "Reads a music section from stream; returns at EOF or if a section -change is detected. Writes data and property changes to channels. -Highly intolerant of malformed inputs." - (handler-case - (music-parse-internal stream channels) - (end-of-file ())) - (dolist (c channels) - (setf (channel-data-stream c) (reverse (channel-data-stream c))))) - -(defun music-parse-internal (stream channels) - (do ((current-channels nil) - (next-char #1=(peek-char nil stream) #1#)) - (nil) - ;; Channel selection characters. - (cond ((find next-char *channel-select-characters*) - (setf current-channels nil) - (dolist (c (expect-channels stream)) - (push (nth c channels) current-channels))) - - ;; Octave changes. - ((char= next-char #\o) - (assert current-channels) - (read-char stream) - (let ((octave (expect-int stream))) - (dolist (c current-channels) - (setf (channel-octave c) octave)))) - - ((char= next-char #\<) - (assert current-channels) - (read-char stream) - (dolist (c current-channels) - (decf (channel-octave c)))) - - ((char= next-char #\>) - (assert current-channels) - (read-char stream) - (dolist (c current-channels) - (incf (channel-octave c)))) - - ;; Notes and rests. - ((find next-char *note-characters*) - (assert current-channels) - (multiple-value-bind (note-char accidentals duration) - (expect-note stream) - (dolist (c current-channels) - (push (make-note (calculate-tone note-char - accidentals - (channel-octave c)) - (clarify-duration duration c)) - (channel-data-stream c))))) - - ((or (char= next-char #\r) (char= next-char #\w)) - (assert current-channels) - (multiple-value-bind (note-type duration) - (expect-rest stream) - (dolist (c current-channels) - (push (make-note note-type - (clarify-duration duration c)) - (channel-data-stream c))))) - - ;; Tempo change. - ((char= next-char #\t) - (assert current-channels) - (read-char stream) - (let ((tempo (expect-int stream))) - (dolist (c current-channels) - (push (make-tempo-command tempo) - (channel-data-stream c)) - (setf (channel-tempo c) tempo)))) - ((char= next-char #\#) - (return)) - - ;; Staccato. - ((char= next-char #\q) - (assert current-channels) - (read-char stream) - (let ((staccato (* *staccato-base-division* (expect-int stream)))) - (dolist (c current-channels) - (push (make-staccato-command staccato) - (channel-data-stream c)) - (setf (channel-staccato c) staccato)))) - - ;; Macro invocation. - ((char= next-char #\@) - (assert current-channels) - (parse-macro-invocation stream current-channels)) - - ;; Comment. - ((char= next-char #\;) - (read-line stream)) - - ;; Something else? - (t (format nil "~&Ignored character: ~A" - (read-char stream)))) - (eat-whitespace-and-barlines stream))) - - -(defun parse-macro-invocation (stream channels) - (read-char stream) - (let ((next-char (peek-char nil stream))) - ;; Arpeggio. - (cond ((char= next-char #\a) - (read-char stream) - (let ((arp-num (expect-int stream))) - (dolist (c channels) - (push (make-arpeggio-command arp-num) - (channel-data-stream c))))) - ;; Something else? - (t (format nil "~&Ignored macro invocator: @~A" - (read-char stream)))))) diff --git a/music-utilities.lisp b/music-utilities.lisp deleted file mode 100644 index d61b3a6..0000000 --- a/music-utilities.lisp +++ /dev/null @@ -1,20 +0,0 @@ - -(in-package :mumble) - -;; 60 seconds in a minute, 4 beats per whole note. -(defconstant +seconds-per-minute+ 60) -(defconstant +beats-per-whole-note+ 4) - -(defun duration-to-frames (duration tempo &optional (frequency 50)) - "Returns a /fractional/ duration -- the conversion routine is -responsible for dealing with these fractions as it sees fit." - (let ((count (/ (/ (* frequency +seconds-per-minute+) - (/ tempo +beats-per-whole-note+)) - (duration-denominator duration)))) - ;; dots - (do ((dots (duration-dots duration) (1- dots)) - (extra (/ count 2) (/ extra 2))) - ((not (plusp dots))) - (incf count extra)) - ;; XXX staccato, ties - count)) diff --git a/src/classes.lisp b/src/classes.lisp new file mode 100644 index 0000000..5649ac6 --- /dev/null +++ b/src/classes.lisp @@ -0,0 +1,128 @@ +;;;; CLASSES AND DATA STRUCTURES. +;;; (and elementary helper functions associated with specific classes.) +;;; +;;; Julian Squires / 2004 + +(in-package :mumble) + +(defun make-duration (denom) + (when denom (/ 1 denom))) + + +(defclass music-command () + ((type :reader music-command-type) + (value :reader music-command-value))) + +(defun make-tempo-command (tempo) + (let ((cmd (make-instance 'music-command))) + (setf (slot-value cmd 'type) :tempo) + (setf (slot-value cmd 'value) tempo) + cmd)) + +(defun make-staccato-command (staccato) + (let ((cmd (make-instance 'music-command))) + (setf (slot-value cmd 'type) :staccato) + (setf (slot-value cmd 'value) staccato) + cmd)) + +;; This might become a special macro-command later. +(defun make-arpeggio-command (n) + (let ((cmd (make-instance 'music-command))) + (setf (slot-value cmd 'type) :arpeggio) + (setf (slot-value cmd 'value) n) + cmd)) + +;; This might become a special macro-command later. +(defun make-volume-envelope-command (n) + (let ((cmd (make-instance 'music-command))) + (setf (slot-value cmd 'type) :volume-envelope) + (setf (slot-value cmd 'value) n) + cmd)) + + +(defclass note (music-command) + ((tone :reader note-tone) + (duration :reader note-duration)) + (:documentation "Notes encapsulate an absolute pitch (the TONE slot) +and a relative length (the DURATION slot). DURATION is relative to +the current channel tempo.")) + +(defun make-note (tone duration) + (let ((note (make-instance 'note))) + (setf (slot-value note 'type) :note) + (setf (slot-value note 'tone) tone) + (setf (slot-value note 'duration) duration) + note)) + +(defmethod print-object ((obj note) stream) + (print-unreadable-object (obj stream :type t) + (princ (note-tone obj) stream) + (princ #\Space stream) + (princ (note-duration obj) stream))) + + +(defclass channel () + ((octave :accessor channel-octave) + (tempo :accessor channel-tempo) + (staccato :accessor channel-staccato) + (duration :accessor channel-default-duration) + (loop-point :accessor channel-loop-point) + ;; repeats is kind of an ugly kludge. + (repeats :accessor channel-repeats) + (data-stream :accessor channel-data-stream))) + +(defun make-channel () + (let ((channel (make-instance 'channel))) + (setf (channel-octave channel) *default-octave* + (channel-tempo channel) *default-tempo* + (channel-staccato channel) *default-staccato* + (channel-default-duration channel) *default-duration* + (channel-loop-point channel) nil + (channel-repeats channel) nil) + + (setf (channel-data-stream channel) + (make-array '(0) :adjustable t :fill-pointer 0)) + channel)) + +(defun channel-current-position (channel) + (fill-pointer (channel-data-stream channel))) + +(defun copy-and-append-channel-data (channel begin end) + (loop for x from begin to end + do (vector-push-extend (aref (channel-data-stream channel) x) + (channel-data-stream channel)))) + + +(defclass tune () + ((channels :accessor tune-channels) + (replay :accessor tune-replay) + (tables :accessor tune-tables) + (metadata :accessor tune-metadata))) + +(defun make-tune () + (let ((tune (make-instance 'tune))) + (setf (tune-metadata tune) nil) + (setf (tune-tables tune) nil) + tune)) + +(defun tune-get-table (tune table-sym) + (cdr (assoc table-sym (tune-tables tune)))) + +(defun (setf tune-get-table) (value tune table-sym) + (setf (cdr (assoc table-sym (tune-tables tune))) value)) + +(defun tune-add-table (tune table-sym) + (push (cons table-sym (make-array '(0) :initial-element nil + :adjustable t)) + (tune-tables tune))) + +(defun tune-add-to-table (tune table-sym index entry) + (let ((table (tune-get-table tune table-sym))) + (when (>= index (length table)) + (setf table (adjust-array table (list (1+ index)) + :initial-element nil))) + (when (aref table index) + (format t "~&WARNING: ~A entry ~A already exists; replacing." + table-sym index)) + (setf (aref table index) entry) + (setf (tune-get-table tune table-sym) table))) diff --git a/src/music-parser.lisp b/src/music-parser.lisp new file mode 100644 index 0000000..7d5214b --- /dev/null +++ b/src/music-parser.lisp @@ -0,0 +1,433 @@ +;;; +;;; Several of these functions are very flaky WRT EOF, and that should +;;; eventually be fixed. This is all just a quick hack. Most of this +;;; could be converted to a very data-driven style of programming. +;;; +;;; Other things that should be checked/fixed: +;;; - durations should get tweaked (say, by parse-music-section) if +;;; we're inside a triplet or tuplet figure. +;;; - haven't figured out yet who should deal with specifying an +;;; initial tempo if we don't find one before the first note. I +;;; have a feeling I should just have this code insert a tempo +;;; set event on any channel where we get a duration-dependant +;;; event before any tempo is set. +;;; +;;; (an abashed) Julian Squires / 2004 +;;; + +(in-package :mumble) + +;;;; CONSTANTS AND PARAMETERS. + +(defparameter *channel-select-characters* "ABCDEFGHIJ") +(defparameter *duration-digits* "0123456789") +(defparameter *note-characters* "c_d_ef_g_a_b") +(defparameter *whitespace-characters* #(#\Space #\Newline #\Tab)) +(defparameter *ws-and-barline-characters* #(#\Space #\Newline #\Tab #\|)) + +(defconstant +octave-size+ 12) + +(defparameter *staccato-base-division* 1/8) +(defparameter *default-duration* (make-duration 4)) +(defparameter *default-octave* 4) +(defparameter *default-staccato* 1) +(defparameter *default-tempo* 120) + + +;;;; LOW-LEVEL PARSE/LEX ROUTINES. + +(defun digit-to-int (char) + (- (char-code char) (char-code #\0))) + +(defun expect-int (stream) + ;; if the next character is a digit, read digits until the next + ;; character is not a digit. + (do ((next-char #1=(peek-char nil stream) #1#) + (int nil)) + ((not (find next-char *duration-digits*)) int) + (let ((digit (digit-to-int (read-char stream)))) + (if int + (setf int (+ (* int 10) digit)) + (setf int digit))))) + +(defun expect-duration (stream) + (let ((duration (make-duration (expect-int stream))) + ;; if the next character is a dot, read dots until the next + ;; character is not a dot. + (dots (do ((next-char #1=(peek-char nil stream) #1#) + (number-of-dots 0 (1+ number-of-dots))) + ((char/= next-char #\.) number-of-dots) + (read-char stream)))) + + (when (and (plusp dots) (null duration)) + (error "Bad duration (relative dots are not allowed).")) + (do ((i 0 (1+ i)) + (orig duration (/ orig 2))) + ((>= i dots)) + (incf duration (/ orig 2))) + + ;; tie. + (unless (null duration) + (do ((next-char #2=(peek-char nil stream) #2#)) + ((char/= next-char #\^)) + (read-char stream) + (incf duration (make-duration (expect-int stream))))) + + duration)) + +(defun read-accidentals (stream) + (do ((next-char #1=(peek-char nil stream) #1#) + (accidentals 0)) + ((char/= next-char #\+ #\-) accidentals) + (if (char= (read-char stream) #\+) + (incf accidentals) + (decf accidentals)))) + +(defun expect-note (stream) + (let* ((note-char (read-char stream)) + (accidentals (read-accidentals stream)) + (duration (expect-duration stream))) + + ;; this function should always be called when we know there's a + ;; note character next. + (assert (find note-char *note-characters*)) + + (values note-char accidentals duration))) + +(defun expect-rest (stream) + (let ((rest-char (read-char stream)) + (duration (expect-duration stream))) + + (if (char= rest-char #\r) + (values :rest duration) + (values :wait duration)))) + +(defun expect-channels (stream) + (do ((next-char #1=(peek-char nil stream) #1#) + (channels)) + ((not (find next-char *channel-select-characters*)) channels) + ;; XXX dumb hack + (push (- (char-code (read-char stream)) + (char-code (char *channel-select-characters* 0))) + channels))) + +(defun eat-whitespace (stream &optional (characters *whitespace-characters*)) + (do ((next-char #1=(peek-char nil stream) #1#)) + ((not (find next-char characters))) + (read-char stream))) + +(defun expect-= (stream) + (eat-whitespace stream) + (assert (char= (read-char stream) #\=)) + (eat-whitespace stream)) + +(defun read-numbers-and-loop-macro (stream) + (assert (char= (read-char stream) #\{)) + (eat-whitespace stream) + (do ((next-char #1=(peek-char nil stream) #1#) + list) + ((char= next-char #\}) (progn (read-char stream) + (reverse list))) + (cond ((char= next-char #\|) + (read-char stream) + (push :loop list)) + ((find next-char "0123456789-") + (push (read stream) list)) + (t + (read-char stream) + (format t "~&Warning: ignored ~A in macro definition." + next-char))) + (eat-whitespace stream))) + +(defun read-symbols-macro (stream) + (assert (char= (read-char stream) #\{)) + (eat-whitespace stream) + (do ((symbol (read stream) (read stream)) + list) + ((eql symbol '}) (reverse list)) + (push symbol list))) + +(defparameter *macro-table-mapping* + '((#\a :arpeggio read-numbers-and-loop-macro) + (#\v :volume-envelope read-numbers-and-loop-macro) + (#\i :instrument read-symbols-macro) + (#\~ :vibrato read-symbols-macro))) + +(defun read-macro-definition (stream) + (assert (char= (read-char stream) #\@)) + (let* ((dispatch (read-char stream)) + (index (expect-int stream)) + (mapping (find dispatch *macro-table-mapping* :test #'equal + :key #'first))) + (expect-= stream) + (values (second mapping) index (funcall (third mapping) stream)))) + + +;;;; HIGH-LEVEL PARSE ROUTINES. + +;;; We should really just create a readtable for the use of all the +;;; following routines. Basically, what's in parse-header-section, +;;; but with the other CL standard macro characters disabled (parens, +;;; single/back quote, comma). +(defun parse-mumble-file (stream) + (let ((*read-eval* nil) + (tune (make-tune))) + ;; Any preamble that occurs before the first section is ignored. + (parse-comment-section stream) + (handler-case + (do ((section (read stream) (read stream))) + (nil) + ;; Note that the section handler is always responsible for + ;; eating the # sign so we don't see it. + (ecase section + (COMMENT (parse-comment-section stream)) + (MACROS (parse-macro-section stream tune)) + (HEADER (parse-header-section stream tune)) + (MUSIC (parse-music-section stream (tune-channels tune))))) + (end-of-file () tune)))) + + +(defun parse-comment-section (stream) + (do () ((char= (read-char stream) #\#)))) + +(defun parse-header-section (stream tune) + (let ((*readtable* (copy-readtable)) + done-p) + (set-macro-character #\# + (lambda (stream char) + (declare (ignore stream char)) + (setf done-p t))) + (do ((header (read stream) (read stream))) + (done-p) + (let ((argument (read stream))) + (case header + (REPLAY + ;; XXX genericize replay stuff + (assert (string= argument "YMamoto")) + (setf (tune-channels tune) (make-ymamoto-channels)) + (setf (tune-replay tune) argument)) + ((TITLE COMPOSER COPYRIGHT) + (push (list header argument) (tune-metadata tune)))))))) + + +(defun parse-macro-section (stream tune) + (do ((next-char #1=(peek-char nil stream) #1#)) + (nil) + (cond ((char= next-char #\@) + (multiple-value-bind (table index entry) + (read-macro-definition stream) + (assert (plusp index) () + "Bad index ~A (tables index from 1 -- 0 is the ~ + \"effect off\" index)." index) + (format t "~&got macro ~A ~A ~A" table index entry) + (unless (tune-get-table tune table) + (tune-add-table tune table)) + (tune-add-to-table tune table index entry))) + + ;; Section change. + ((char= next-char #\#) + (read-char stream) + (return)) + + ;; Comment. + ((char= next-char #\;) + (read-line stream)) + + ;; Something else? + (t (format t "~&Ignored character in macro section: ~A (~:*~S)" + (read-char stream)))) + (eat-whitespace stream))) + +;; possible ``dispatch table'' format for routine below? +#+nil '((#\o + ((octave (progn (read-char stream) (expect-int stream)))) + (setf (channel-octave channel) octave)) + (#\< + nil + (decf (channel-octave c))) + (*note-characters* + ((note-char accidentals duration) (expect-note stream)) + (push (make-note (calculate-tone note-char + accidentals + (channel-octave channel)) + (clarify-duration duration channel)) + (channel-data-stream channel)))) + + + +(defun parse-music-section (stream channels + &optional loop-channels in-loop-p) + "Reads a music section from stream; returns at EOF or if a section +change is detected. Writes data and property changes to channels. +Highly intolerant of malformed inputs." + (do ((current-channels (and in-loop-p loop-channels)) + (next-char #1=(peek-char nil stream) #1#)) + (nil) + ;; Channel selection characters. + (cond ((find next-char *channel-select-characters*) + (setf current-channels nil) + (dolist (c (expect-channels stream)) + (assert (< c (length channels)) + () "Invalid channel for this replay.") + (push (nth c channels) current-channels))) + + ;; Repeats (unrolled loops). + ((char= next-char #\[) + (assert current-channels () "Command outside channels.") + (read-char stream) + (dolist (c current-channels) + (push (channel-current-position c) + (channel-repeats c))) + (parse-music-section stream channels current-channels t)) + + ((char= next-char #\]) + (assert (and in-loop-p + current-channels)) + (read-char stream) + (let ((count (expect-int stream))) + (dolist (c current-channels) + (let ((begin (pop (channel-repeats c))) + (end (1- (channel-current-position c)))) + (dotimes (i (1- count)) + (copy-and-append-channel-data c begin end))))) + (return)) + + ;; Octave changes. + ((char= next-char #\o) + (assert current-channels () "Command outside channels.") + (read-char stream) + (let ((octave (expect-int stream))) + (dolist (c current-channels) + (setf (channel-octave c) octave)))) + + ((char= next-char #\<) + (assert current-channels () "Command outside channels.") + (read-char stream) + (dolist (c current-channels) + (decf (channel-octave c)))) + + ((char= next-char #\>) + (assert current-channels () "Command outside channels.") + (read-char stream) + (dolist (c current-channels) + (incf (channel-octave c)))) + + ;; Notes and rests. + ((find next-char *note-characters*) + (assert current-channels () "Command outside channels.") + (multiple-value-bind (note-char accidentals duration) + (expect-note stream) + (dolist (c current-channels) + (vector-push-extend (make-note + (calculate-tone note-char + accidentals + (channel-octave c)) + (clarify-duration duration c)) + (channel-data-stream c))))) + + ((or (char= next-char #\r) (char= next-char #\w)) + (assert current-channels () "Command outside channels.") + (multiple-value-bind (note-type duration) + (expect-rest stream) + (dolist (c current-channels) + (vector-push-extend (make-note note-type + (clarify-duration duration c)) + (channel-data-stream c))))) + + ;; Tempo change. + ((char= next-char #\t) + (assert current-channels () "Command outside channels.") + (read-char stream) + (let ((tempo (expect-int stream))) + (dolist (c current-channels) + (vector-push-extend (make-tempo-command tempo) + (channel-data-stream c)) + (setf (channel-tempo c) tempo)))) + + ;; Section change. + ;; XXX: add something to complain about unfinished loops. + ((char= next-char #\#) + (read-char stream) + (when in-loop-p + (format t "WARNING: changing sections during a [] repeat. ~ + This probably won't work.")) + (return)) + + ;; Staccato. + ((char= next-char #\q) + (assert current-channels () "Command outside channels.") + (read-char stream) + (let ((staccato (* *staccato-base-division* (expect-int stream)))) + (dolist (c current-channels) + (vector-push-extend (make-staccato-command staccato) + (channel-data-stream c)) + (setf (channel-staccato c) staccato)))) + + ;; Macro invocation. + ((char= next-char #\@) + (assert current-channels () "Command outside channels.") + (parse-macro-invocation stream current-channels)) + + ;; Structural dispatch character. + ((char= next-char #\!) + (assert current-channels () "Command outside channels.") + (parse-bang-invocation stream current-channels)) + + ;; Replay-special invocation. + ((char= next-char #\%) + (assert current-channels () "Command outside channels.") + (read-char stream) + ;; XXX genericize replay stuff + (ymamoto-special-handler stream channels)) + + ;; Comment. + ((char= next-char #\;) + (read-line stream)) + + ;; Something else? + (t (format t "~&Ignored character in music section: ~A (~:*~S)" + (read-char stream)))) + (eat-whitespace stream *ws-and-barline-characters*))) + + +(defun parse-macro-invocation (stream channels) + (read-char stream) + (let ((next-char (peek-char nil stream))) + ;; Arpeggio. + (cond ((char= next-char #\a) + (read-char stream) + (let ((arp-num (expect-int stream))) + (dolist (c channels) + (vector-push-extend (make-arpeggio-command arp-num) + (channel-data-stream c))))) + ;; Volume envelope. + ((char= next-char #\v) + (read-char stream) + (let ((venv-num (expect-int stream))) + (dolist (c channels) + (vector-push-extend (make-volume-envelope-command venv-num) + (channel-data-stream c))))) + + ;; Vibrato. + ((char= next-char #\~) + (read-char stream) + (let ((vibrato-num (expect-int stream))) + ;; XXX unimplemented + vibrato-num)) + + ;; Something else? + (t (format t "~&Ignored macro invocator: @~A (~:*~S)" + (read-char stream)))))) + + +(defun parse-bang-invocation (stream channels) + (let ((symbol (read stream))) + (case symbol + (LOOP + (dolist (c channels) + (setf (channel-loop-point c) (channel-current-position c)))) + (END + ;;; XXX how to handle this nicely? + #+nil(dolist (c channels) + (vector-push-extend (make-track-end-command) + (channel-data-stream c))))))) diff --git a/src/music-utilities.lisp b/src/music-utilities.lisp new file mode 100644 index 0000000..6f15959 --- /dev/null +++ b/src/music-utilities.lisp @@ -0,0 +1,29 @@ + +(in-package :mumble) + +;; 60 seconds in a minute, 4 beats per whole note. +(defconstant +seconds-per-minute+ 60) +(defconstant +beats-per-whole-note+ 4) + +(defun duration-to-frames (duration tempo &optional (frequency 50)) + "Returns a /fractional/ duration -- the conversion routine is +responsible for dealing with these fractions as it sees fit." + (let ((count (* (/ (* frequency +seconds-per-minute+) + (/ tempo +beats-per-whole-note+)) + duration))) + count)) + +(defun clarify-duration (duration channel) + (if duration + (setf (channel-default-duration channel) duration) + (channel-default-duration channel))) + +(defun calculate-tone (char accidentals octave) + (let ((tone-value (* +octave-size+ octave))) + (incf tone-value + (do ((i 0 (1+ i))) + ((char= char (schar *note-characters* i)) i) + (assert (< i (length *note-characters*))))) + (incf tone-value accidentals) + tone-value)) + diff --git a/package.lisp b/src/package.lisp similarity index 100% rename from package.lisp rename to src/package.lisp diff --git a/src/replay-xm.lisp b/src/replay-xm.lisp new file mode 100644 index 0000000..bba6f38 --- /dev/null +++ b/src/replay-xm.lisp @@ -0,0 +1,18 @@ +;;; +;;; Code to support outputting simple FastTracker XMs from mumble. +;;; +;;; Julian Squires / 2004 +;;; + +(in-package :mumble) + +;;; converting: +;;; +;;; default to 1/16th note per row, read in all note data, allocating +;;; patterns accordingly. (have temporary patterns, containing rows +;;; with simultaneous notes together) +;;; +;;; go back through patterns; when strange/fast timings occur, try to +;;; frob tempo appropriately to accomidate. finally, pack patterns. +;;; +;;; load instruments from XI diff --git a/src/replay-ymamoto.lisp b/src/replay-ymamoto.lisp new file mode 100644 index 0000000..96f1e0b --- /dev/null +++ b/src/replay-ymamoto.lisp @@ -0,0 +1,157 @@ +;;; +;;; YMamoto conversion functions for mumble output. These functions +;;; produce hisoft-style assembly output, which can be assembled into +;;; a binary playable by the ymamoto playroutine. +;;; +;;; Julian Squires / 2004 +;;; + +(in-package :mumble) + +(defparameter *ymamoto-frequency* 50) +(defvar *channel-delta* 0) +(defvar *total-frames* 0) + +;;;; UTILITIES + +(defun find-and-remove-loop (list) + "Finds :loop in the list, and returns two values, the list with the +:loop removed, and the position of the loop. Does not support +multiple loops." + (aif (position :loop list) + (values (remove :loop list) it) + (values list 0))) + + +;;;; INPUT-RELATED FUNCTIONS + +(defun make-ymamoto-channels () + (list + (make-channel) + (make-channel) + (make-channel))) + + +(defun ymamoto-special-handler (stream channels) + (read-char stream) + (let ((next-char (read-char stream))) + (cond ((char= next-char #\e) + ;; env follow + (format t "~&guilty env follow")) + ;; Something else? + (t (format t "~&Ignored special invocator: @~A" next-char))))) + + +;;;; OUTPUT FUNCTIONS + +(defun ymamoto-output-note-helper (note-word frames stream + &optional (comma nil)) + (incf *channel-delta* frames) + (multiple-value-bind (frames leftovers) (floor *channel-delta*) + (setf *channel-delta* leftovers) + (setf (ldb (byte 7 8) note-word) (1- frames)) + + (when (plusp frames) + (incf *total-frames* frames) + (format stream (if comma ", $~X" "~&~8TDC.W $~X") note-word)))) + + +(defun ymamoto-output-note (note channel stream) + (let ((note-word 0) + (frames (duration-to-frames (note-duration note) + (channel-tempo channel) + *ymamoto-frequency*)) + (staccato-frames 0)) + + (cond ((eql (note-tone note) :rest) + (setf (ldb (byte 7 0) note-word) 127)) + ((eql (note-tone note) :wait) + (setf (ldb (byte 7 0) note-word) 126)) + (t + (when (/= (channel-staccato channel) 1) + (setf staccato-frames (- frames (* frames + (channel-staccato channel)))) + (when (< (- frames staccato-frames) 1) + (decf staccato-frames)) + (setf frames (- frames staccato-frames))) + + (setf (ldb (byte 7 0) note-word) (note-tone note)))) + + (ymamoto-output-note-helper note-word frames stream) + (when (plusp staccato-frames) + (ymamoto-output-note-helper 127 staccato-frames stream t)))) + + +(defun ymamoto-output-note-stream (notes stream) + "Traverse a note-stream, keeping track of tempo and staccato + settings, and output assembly directives for this note stream." + (let ((channel (make-channel))) + (setf *channel-delta* 0) + (setf *total-frames* 0) + (loop for note across notes + do (case (music-command-type note) + (:note (ymamoto-note-output note channel stream)) + (:arpeggio + (format stream "~&~8TDC.W $~X" + (logior (ash #b11000000 8) (music-command-value note)))) + (:tempo + (setf (channel-tempo channel) (music-command-value note))) + (:staccato + (setf (channel-staccato channel) (music-command-value note))))) + (format t "~&frames: ~A" *total-frames*))) + + +(defun output-ymamoto-header (stream) + (format stream ";;; test song, in assembler form + + ORG 0 +song_header: + DC.L arpeggio_table ; pointer to arpeggio table + DC.L venv_table ; pointer to volume envelope table + DC.B 1 ; number of tracks")) + + +(defun ymamoto-output-length-loop-list-table (stream name table) + ;; note that the zeroth element of the table is skipped. + (format stream "~&~A:~%~8TDC.B ~D" name (max 0 (1- (length table)))) + (do ((i 1 (1+ i))) + ((>= i (length table))) + (multiple-value-bind (list loop) (find-and-remove-loop (aref table i)) + (format stream "~&~8TDC.B ~A, ~A~{, ~D~}" (length list) loop list)))) + + +;;;; HIGH-LEVEL + +(defun mbl-to-ymamoto-file (mbl-file out-file) + (let (tune) + (with-open-file (stream mbl-file) + (setf tune (parse-mumble-file stream))) + (with-open-file (stream out-file + :direction :output + :if-exists :supersede) + ;; simple header + (output-ymamoto-header stream) + ;; for n tracks + (let ((track-num 1)) + (format stream "~&~8TDC.L track_~D" track-num)) + (ymamoto-output-length-loop-list-table + stream "arpeggio_table" (tune-get-table tune :arpeggio)) + (ymamoto-output-length-loop-list-table + stream "venv_table" (tune-get-table tune :volume-envelope)) + ;; for n tracks + (let ((track-num 1)) + ;; I bet the following could all be reduced to one big format + ;; statement. Yuck. + (format stream "~&track_~D:" track-num) + (do ((c (tune-channels tune) (cdr c)) + (ctr (char-code #\a) (1+ ctr))) + ((null c)) + (format stream "~&~8TDC.L channel_~A" (code-char ctr))) + (do ((c (tune-channels tune) (cdr c)) + (ctr (char-code #\a) (1+ ctr))) + ((null c)) + (format stream "~&channel_~A:" (code-char ctr)) + (ymamoto-output-note-stream (channel-data-stream (car c)) stream) + (if (channel-loop-point (car c)) + (format stream "~&~8TDC.W $8001") + (format stream "~&~8TDC.W $8000"))))))) diff --git a/tools/dot-s-to-sc68.sh b/tools/dot-s-to-sc68.sh new file mode 100644 index 0000000..966aa86 --- /dev/null +++ b/tools/dot-s-to-sc68.sh @@ -0,0 +1,17 @@ +#!/bin/sh + +# $1 should end in .s +if [ X`echo $1 | sed -e s/\.s$//` = X$1 ]; then + echo "The argument to this script ($1) should end in \".s\"." + exit 1 +fi + +as68 $1 || exit 1 +debug68 < / 2004 -;;; - -(in-package :mumble) - -(defparameter *ymamoto-frequency* 50) -(defvar *channel-delta* 0) -(defvar *total-frames* 0) - -(defun make-ymamoto-channels () - (list - (make-channel) - (make-channel) - (make-channel))) - - -(defun ymamoto-note-output (note channel stream) - (let ((note-word 0) - (frames (duration-to-frames (note-duration note) - (channel-tempo channel) - *ymamoto-frequency*)) - (staccato-frames 0)) - - (cond ((eql (note-tone note) :rest) - (setf (ldb (byte 7 0) note-word) 127)) - ((eql (note-tone note) :wait) - (setf (ldb (byte 7 0) note-word) 126)) - (t - (when (/= (channel-staccato channel) 1) - (setf staccato-frames (- frames (* frames - (channel-staccato channel)))) - (when (< (- frames staccato-frames) 1) - (decf staccato-frames)) - (setf frames (- frames staccato-frames))) - - (setf (ldb (byte 7 0) note-word) (note-tone note)))) - - (output-note note-word frames stream) - (when (>= staccato-frames 1) - (output-note 127 staccato-frames stream t)))) - -(defun output-note (note-word frames stream &optional (comma nil)) - (incf *channel-delta* frames) - (multiple-value-bind (frames leftovers) (floor *channel-delta*) - (setf *channel-delta* leftovers) - (setf (ldb (byte 7 8) note-word) (1- (floor frames))) - - (unless (< frames 1) - (incf *total-frames* (floor frames)) - (format stream (if comma ", $~X" "~& DC.W $~X") note-word)))) - - -(defun output-ymamoto-notes (notes stream) - ;; Traverse a note-stream, keeping track of tempo and staccato - ;; settings, and output assembly directives for this note stream. - (let ((channel (make-channel))) - (setf *channel-delta* 0) - (setf *total-frames* 0) - (dolist (note notes) - (cond ((eql (music-command-type note) :note) - (ymamoto-note-output note channel stream)) - ((eql (music-command-type note) :arpeggio) - (format stream "~& DC.W $~X" - (logior (ash #b11000000 8) - (music-command-value note)))) - ((eql (music-command-type note) :tempo) - (setf (channel-tempo channel) (music-command-value note))) - ((eql (music-command-type note) :staccato) - (setf (channel-staccato channel) - (music-command-value note))))) - (format t "frames: ~A~%" *total-frames*))) - - -(defun mml-to-ymamoto-file (mml-file out-file) - (let ((channels (make-ymamoto-channels))) - (with-open-file (stream mml-file) - (parse-music-section stream channels)) - - (with-open-file (stream out-file - :direction :output - :if-exists :supersede) - (format stream ";;; test song, in assembler form - - ORG 0 -song_header: - DC.L arpeggio_table ; pointer to arpeggio table - DC.L venv_table ; pointer to volume envelope table - DC.B 1 ; number of tracks - DC.L track_1 ; pointer to track - -arpeggio_table: - DC.B 9 ; number of arpeggios - ; length, loop point, data... -arp_entry_1: - DC.B 4, 1, 0, 3, 9, -12 -arp_entry_2: - DC.B 4, 1, 0, 5, 7, -12 -arp_entry_3: - DC.B 4, 1, 0, 3, 4, -7 -arp_entry_4: - DC.B 4, 1, 0, 5, 4, -9 -arp_entry_5: - DC.B 4, 1, 0, 5, 3, -8 -arp_entry_6: - DC.B 4, 1, 0, 2, 3, -5 -arp_entry_7: - DC.B 4, 1, 0, 6, 3, -9 -arp_entry_8: - DC.B 4, 1, 0, 4, 3, -7 -arp_entry_9: - DC.B 4, 1, 0, 4, 8, -12 - -venv_table: - DC.B 0 - -track_1: - ;; channel pointers - DC.L channel_a, channel_b, channel_c - DC.B 0 ; initial tempo -") - (do ((c channels (cdr c)) - (ctr (char-code #\a) (1+ ctr))) - ((null c)) - (format stream "~&channel_~A:" (code-char ctr)) - (output-ymamoto-notes (channel-data-stream (car c)) stream) - (format stream "~& DC.W $8000"))))) - - -- 2.11.4.GIT