<<>> <> <> <> <> <> <> DIRECTORY FS USING [Error], IO, Real USING [ Round ], TuneParse USING [ Db, Hertz, Milliseconds, Tone, ToneList, ToneSpec, ToneSpecRec ], Rope ; TuneParseImpl: CEDAR PROGRAM IMPORTS Real, FS, IO, Rope EXPORTS TuneParse = { <<-------------------------------------------------------------->> <> <<-------------------------------------------------------------->> Db: TYPE ~ TuneParse.Db; -- These are only used in interfaces; they're all INTs. Hertz: TYPE ~ TuneParse.Hertz; Milliseconds: TYPE ~ TuneParse.Milliseconds; Note: TYPE = REF NoteRec; NoteRec: TYPE = RECORD [ twelfths, octave, duration, breakTime: INT¬0, initialized: BOOL¬FALSE ]; initialOctave: INT = 8; initialDuration: INT = 128; -- approximately an eighth-note, as default initialBreak: INT = 48; -- lower-case note gap, 3/64 by default scale: TYPE = CHARACTER ['A..'G]; twelfths: ARRAY scale OF INT = [12, 14, 3, 5, 7, 8, 10]; root: REAL = 1.0595; -- 12th root of 2 root96: ARRAY [0..8) OF REAL = -- 2­(n/96), for slides [1.0000, 1.0072, 1.0145, 1.0219, 1.0293, 1.0368, 1.0443, 1.0518]; freqA: INT = 1760; -- highest octave we'll bother with <> <> <" is encountered, all subsequent notes are an octave higher; a "<" lowers all subsequent notes by an octave. Going up more than 3 octaves is not permitted (additional ">"s are ignored), and notes near the top of the highest octave may not be struck accurately.>> <> <> <> <> <;" to give the note duration and/or ",;" for the lower-case implicit rest, where and are strings of digits representing milliseconds. The values will be constrained to the usual limits (e.g., will be forced between 16 and 1024 ms). Subsequent "*", "_", etc., have their usual effects.>> <<"!; sets the volume to n. 0 is loudest, and some integer > 0 is softest; experiment. This overrides the default specified in PlayString, but may not take effect until several notes after it appears, unless specified first.>> <> <> <> <> <> ParseTune: PUBLIC PROC [tune: Rope.ROPE, volume: Db] RETURNS[ tones: TuneParse.ToneSpec] ~ { tune2: Rope.ROPE; pos: INT = Rope.Find[tune, "&"]; IF pos>=0 THEN { tune2 ¬ Rope.Substr[tune, pos+1]; tune ¬ Rope.Substr[tune, 0, pos]; }; tones ¬ ParseStr[tune, volume]; IF tune2.Length[]#0 THEN { tones2: TuneParse.ToneSpec = ParseStr[tune2, 0]; tones ¬ MergeToneSpecs[tones, tones2]; }; }; ParseStr: PROC [tune: Rope.ROPE, volume: INT] RETURNS[tones: TuneParse.ToneSpec ¬ NIL]= { mS: IO.STREAM; note: Note; octave: INT ¬ initialOctave; duration: INT ¬ initialDuration; break: INT ¬ initialBreak; triplet: BOOLEAN ¬ FALSE; -- gets set to TRUE between parentheses lastTone: TuneParse.ToneList ¬ NIL; tone: TuneParse.Tone ¬ [f1: 0, f2: 0, on: 0, off: 0]; inProgress: BOOL¬FALSE; repeatIndefinitely: BOOL¬TRUE; <<>> Frequency: PROCEDURE [key: Note, tweak: INT ¬ 0 -- 96ths -- ] RETURNS [freq: INT] = { freqR: REAL¬0.0; twelfths: INT ¬ key.twelfths; octave: INT ¬ key.octave*32; IF octave = 0 OR twelfths = 0 THEN RETURN[twelfths]; <> freqR ¬ freqA*32; IF tweak >= 8 THEN twelfths ¬ twelfths + (tweak/8); THROUGH [0..twelfths/12) DO octave ¬ octave/2 ENDLOOP; THROUGH [0..twelfths MOD 12) DO freqR ¬ freqR*root ENDLOOP; IF tweak # 0 THEN freqR ¬ freqR*root96[tweak MOD 8]; freqR ¬ (freqR+octave/2)/octave; freq ¬ Real.Round[freqR]; }; AddTone: PROC [freq: INT, duration: INT] = { <> IF (freq#0 AND (freq#tone.f1 OR tone.off#0)) OR ~inProgress OR duration=0 THEN { <> IF inProgress AND tone.on#0 THEN { -- in progress is previous note or leading rest. toneEnt: TuneParse.ToneList; toneEnt ¬ LIST[tone]; IF lastTone=NIL THEN tones.tones¬lastTone¬toneEnt ELSE { lastTone.rest ¬ toneEnt; lastTone¬toneEnt }; -- Append tone.off ¬ 0; }; tone.f1 ¬ freq; tone.on ¬ duration; inProgress ¬ TRUE; } ELSE IF freq=0 THEN tone.off ¬ tone.off + duration ELSE tone.on ¬ tone.on + duration; <> }; DonePlaying: PROCEDURE = { AddTone[0, 0]; }; NextNote: PROCEDURE [] = { IF NOT note.initialized THEN RETURN; AddTone[Frequency[note], note.duration]; IF note.breakTime#0 THEN AddTone[0, note.breakTime]; note­ ¬ []; }; { ENABLE UNWIND => CONTINUE; mS ¬ IO.RIS[tune]; IF mS=NIL THEN RETURN; -- Should complain! tones ¬ NEW[TuneParse.ToneSpecRec ¬ []]; tones.asRope ¬ tune; note ¬ NEW[NoteRec¬[]]; WHILE NOT mS.EndOf[] DO char: CHAR ¬ mS.GetChar[]; SELECT char FROM IN ['A..'G] => { NextNote[]; note.twelfths ¬ twelfths[char]; note.octave ¬ octave; note.duration ¬ IF triplet THEN (duration*2 + 1)/3 ELSE duration; note.initialized ¬ TRUE; }; IN ['a..'g] => { <<-- this is where the "slop" mentioned for brackets comes in>> NextNote[]; note.twelfths ¬ twelfths[char + ('A - 'a)]; note.octave ¬ octave; note.duration ¬ MAX[(IF triplet THEN (duration*2 + 1)/3 ELSE duration), break] - break; note.breakTime ¬ break; note.initialized ¬ TRUE; }; '% => { NextNote[]; note.duration ¬ IF triplet THEN (duration*2 + 1)/3 ELSE duration; note.initialized ¬ TRUE; }; '# => IF note.initialized THEN note.twelfths ¬ note.twelfths + 1; --sharps 1/12 higher '+ => IF note.initialized THEN note.duration ¬ ((note.duration+note.breakTime)*3/2) - note.breakTime; '- => IF note.initialized THEN note.duration ¬ MAX[((note.duration+note.breakTime)/2), note.breakTime] - note.breakTime; '< => octave ¬ octave*2; '> => octave ¬ octave/2; '/ => duration ¬ MAX[duration/2, 8]; '* => duration ¬ duration*2; '_ => break ¬ MAX[break/2, 2]; '^ => break ¬ break*2; '(, ') => triplet ¬ ( char = '( ); ': => repeatIndefinitely ¬ NOT repeatIndefinitely; '@ => duration ¬ mS.GetInt[!IO.Error, FS.Error => CONTINUE]; -- Should complain! '! => volume ¬ -mS.GetInt[!IO.Error, FS.Error => CONTINUE]; -- Should complain! ', => break ¬ mS.GetInt[!IO.Error, FS.Error => CONTINUE]; -- Should complain! ENDCASE; ENDLOOP; NextNote[]; DonePlaying[]; tones.volume ¬ volume; tones.repeatIndefinitely ¬ repeatIndefinitely; }; }; MergeToneSpecs: PUBLIC PROC[t1, t2: TuneParse.ToneSpec, t2Divisor: INT¬1, t2Delay: INT¬0, volumeIncrement: INT¬0] RETURNS[ts: TuneParse.ToneSpec] = { tone: TuneParse.Tone ¬ [0,0,0,0, 0]; l1, l2: TuneParse.ToneList; lastTone: TuneParse.ToneList ¬ NIL; volume: INT ¬ volumeIncrement; SendTone: PROC = { IF tone.repetitions#0 THEN { newLast: TuneParse.ToneList ¬ LIST[tone]; IF lastTone=NIL THEN ts.tones ¬ newLast ELSE lastTone.rest ¬ newLast; lastTone ¬ newLast; tone ¬ [0,0,0,0, 0]; }; }; d, d1, d2: TuneParse.Milliseconds ¬ 0; IF t1=NIL THEN RETURN[t2]; -- aberrant call ts ¬ NEW[TuneParse.ToneSpecRec ¬ [ repeatIndefinitely: t1.repeatIndefinitely, volume: t1.volume+volumeIncrement]]; IF t2Delay#0 THEN l2 ¬ LIST[[0, 0, 0, t2Delay, 0]]; l1 ¬ t1.tones; IF t2#NIL THEN IF l2=NIL THEN l2 ¬ t2.tones ELSE l2.rest ¬ t2.tones; DO f1, f2: TuneParse.Milliseconds; [f1, d1, l1] ¬ Duration[l1, d, 1]; [f2, d2, l2] ¬ Duration[l2, d, t2Divisor]; d ¬ MIN[d1, d2]; IF d=0 THEN d ¬ MAX[d1, d2]; IF d=0 THEN EXIT; IF f1#0 OR f2#0 THEN { SendTone[]; tone.f1 ¬ f1; tone.f2 ¬ f2; tone.on ¬ d; } ELSE tone.off ¬ tone.off + d; tone.repetitions ¬ 1; ENDLOOP; SendTone[]; }; Duration: PROC[oldT: TuneParse.ToneList, reduction: INT, divisor: INT] RETURNS [f: TuneParse.Hertz, duration: TuneParse.Milliseconds, t: TuneParse.ToneList] = { newVal: INT; t ¬ oldT; IF t=NIL THEN RETURN[0, 0, NIL]; <> IF reduction#0 THEN { newVal ¬ LOOPHOLE[t.first.on, INT]-reduction; IF newVal>=0 THEN { IF newVal=0 AND t.first.off=0 THEN t ¬ t.rest ELSE { t ¬IF t.first.repetitions=0 THEN t ELSE CONS[[t.first.f1, 0, 0, t.first.off, 0], t.rest]; t.first.on ¬ newVal; }; } ELSE { IF newVal#(-reduction) THEN ERROR; newVal ¬ LOOPHOLE[t.first.off, INT]-reduction; IF newVal>0 THEN { IF t.first.repetitions=0 THEN t.first.off ¬ newVal ELSE t ¬ CONS[[0, 0, 0, newVal, 0], t.rest]; } ELSE IF newVal=0 THEN t ¬ t.rest ELSE ERROR; }; }; IF t=NIL THEN RETURN[0, 0, NIL]; IF t.first.on#0 THEN RETURN[t.first.f1/divisor, t.first.on, t] ELSE IF t.first.off#0 THEN RETURN[0, t.first.off, t] ELSE ERROR; }; }. <> <> <> <> <> <<>>