1 unit status;
2 { Keep track of duration, octave, slur and beam status. }
3
4 interface
5
6 procedure initStatus;
7 procedure saveStatus(voice: integer);
8
9 procedure resetDuration (voice: integer; dur: char);
durationnull10 function duration(voice: integer): char;
11
slurLevelnull12 function slurLevel(voice: integer): integer;
beamLevelnull13 function beamLevel(voice: integer): integer;
noBeamMelismanull14 function noBeamMelisma(voice: integer): boolean;
noSlurMelismanull15 function noSlurMelisma(voice, history: integer): boolean;
afterSlurnull16 function afterSlur(voice: integer): integer;
17 procedure setUnbeamed(voice: integer);
18 procedure setUnslurred(voice: integer);
19 procedure beginBeam(voice: integer; var note: string);
20 procedure endBeam(voice: integer);
21 procedure beginSlur(voice: integer; var note: string);
22 procedure endSlur(voice: integer; var note: string);
23 procedure activateBeamsAndSlurs(voice: integer);
24
25 procedure setOctave(voice: integer);
26 procedure resetOctave(voice: integer);
octavenull27 function octave(voice: integer): char;
28 procedure newOctave(voice: integer; dir: char);
29 procedure initOctaves(octaves: string);
30
31 procedure renewPitch (voice: integer; var note: string);
chordPitchnull32 function chordPitch(voice: integer): integer;
33 procedure renewChordPitch (voice: integer; note: string);
34 procedure rememberDurations;
35 procedure restoreDurations;
36 procedure chordTie(voice: integer; var lab: char);
37 type int5 = array[1..5] of integer;
38 procedure getChordTies(voice: integer; var pitches: int5; var labels: string);
39
40 implementation uses globals, strings, mtxline, control, utility, notes;
41
42 const
43 init_oct: string = '';
44 lowest_pitch = -9;
45 highest_pitch = 61;
46
47 type
48 line_status = record
49 pitch, chord_pitch, octave_adjust, beam_level, slur_level, after_slur: integer;
50 octave, lastnote, chord_lastnote, duration, slurID, tieID: char;
51 beamnext, beamed, slurnext, slurred, no_beam_melisma: boolean;
52 no_slur_melisma: array[1..12] of boolean;
53 chord_tie_pitch: int5;
54 chord_tie_label: string[5];
55 end;
56
57 var current: array[voice_index] of line_status;
58 lastdur: array[voice_index] of char;
59
60 procedure chordTie(voice: integer; var lab: char);
61 var n: integer;
62 begin with current[voice] do
63 begin n:=length(chord_tie_label);
64 if n=5 then error3(voice,'Only five slur ties allowed per voice');
65 if n=0 then lab:='T' else lab:=chord_tie_label[n];
66 inc(lab); chord_tie_label:=chord_tie_label+lab;
67 inc(n); chord_tie_pitch[n]:=chord_pitch
68 end
69 end;
70
71 procedure getChordTies(voice: integer; var pitches: int5; var labels: string);
72 begin with current[voice] do
73 begin pitches:=chord_tie_pitch; labels:=chord_tie_label; chord_tie_label:='' end
74 end;
75
76 procedure rememberDurations;
77 var v: voice_index;
78 begin for v:=1 to nvoices do lastdur[v]:=duration(v) end;
79
80 procedure restoreDurations;
81 var v: voice_index;
82 begin for v:=1 to nvoices do resetDuration(v,lastdur[v]) end;
83
durationnull84 function duration(voice: integer): char;
85 begin duration := current[voice].duration; end;
86
87 procedure resetDuration(voice: integer; dur: char);
88 begin if pos1(dur,durations)=0 then
89 begin write('Trying to set duration to ',dur,'; ');
90 error3(voice,'M-Tx system error: resetDuration');
91 end;
92 current[voice].duration := dur
93 end;
94
95
96 procedure activateBeamsAndSlurs(voice: integer);
97 begin with current[voice] do
98 begin
99 if beamnext then begin beamed:=true; beamnext:=false; end;
100 if slurnext then begin slurred:=true; slurnext:=false; end;
101 if slurred then inc(after_slur);
102 end
103 end;
104
105 procedure saveStatus(voice: integer);
106 begin with current[voice] do
107 begin chord_pitch := pitch; chord_lastnote := lastnote; end;
108 end;
109
noBeamMelismanull110 function noBeamMelisma(voice: integer): boolean;
111 begin noBeamMelisma := current[voice].no_beam_melisma; end;
112
afterSlurnull113 function afterSlur(voice: integer): integer;
114 begin with current[voice] do
115 begin afterSlur := after_slur; if (after_slur>0) and (slur_level<1) then
116 error3(voice,'M-Tx system error: afterSlur and slur_level incompatible)')
117 end
118 end;
119
octavenull120 function octave(voice: integer): char;
121 begin octave := current[voice].octave; end;
122
123 procedure resetOctave(voice: integer);
124 begin current[voice].octave := ' '; end;
125
126 procedure initOctaves(octaves: string);
127 var i: integer;
128 begin init_oct:=octaves;
129 i:=1;
130 while i<=length(init_oct) do
131 if init_oct[i]=' ' then delete1(init_oct,i) else inc(i);
132 end;
133
initOctavenull134 function initOctave(voice_stave: stave_index): char;
135 begin
136 if voice_stave>length(init_oct) then
137 if pos1(clef[voice_stave],'Gt08')>0
138 then initOctave:='4' else initOctave:='3'
139 else initOctave:=init_oct[voice_stave];
140 end;
141
142 procedure setOctave(voice: integer);
143 begin current[voice].octave:=initOctave(voiceStave(voice)); end;
144
145 procedure newOctave(voice: integer; dir: char);
146 begin with current[voice] do case dir of
147 '+': inc(octave);
148 '-': dec(octave);
149 end;
150 end;
151
newPitchnull152 function newPitch (voice: integer; note: string; pitch: integer;
153 lastnote: char): integer;
154 var interval, npitch: integer;
155 oct: char;
156 begin {if debugMode then
157 write('New pitch for note ',note,' relative to ',lastnote,
158 ' at pitch ',pitch);}
159 oct:=octaveCode(note);
160 if oct='=' then oct:=initOctave(voiceStave(voice));
161 if (oct>='0') and (oct<='9') then
162 begin pitch:=7*(ord(oct)-ord('0'))-3; lastnote:='f';
163 removeOctaveCode(oct,note); oct:=octaveCode(note)
164 end;
165 interval := ord(note[1])-ord(lastnote);
166 if interval>3 then dec(interval,7);
167 if interval<-3 then inc(interval,7);
168 npitch:=pitch+interval; {if debugMode then write(' was ',npitch);}
169 while oct<>' ' do
170 begin if oct='+' then inc(npitch,7) else if oct='-' then dec(npitch,7);
171 removeOctaveCode(oct,note); oct:=octaveCode(note)
172 end;
173 {if debugMode then writeln(' is ',npitch);}
174 newPitch:=npitch
175 end;
176
177 procedure repitch(var note: string; diff: integer);
178 procedure delins(var note: string; c1, c2: char; l: integer);
179 var i, n: integer;
180 begin n:=length(note); i:=pos1(c1,note); if i=0 then i:=n+1;
181 while (l>0) and (i<=n) do begin delete1(note,i); dec(n); dec(l); end;
182 i:=pos1(c2,note);
183 if i=0 then if length(note)<2 then error('M-Tx program error',print)
184 else i:=3;
185 while l>0 do begin insertchar(c2,note,i); dec(l); end;
186 end;
187 begin diff:=diff div 7;
188 if diff>0 then delins(note, '-','+',diff)
189 else delins(note, '+','-',-diff);
190 end;
191
192 procedure setUnbeamed(voice: integer);
193 begin current[voice].beamed:=false end;
194
195 procedure setUnslurred(voice: integer);
196 begin with current[voice] do
197 begin slurred:=false; after_slur:=0; end;
198 end;
199
200 procedure beginBeam(voice: integer; var note: string);
201 begin with current[voice] do
202 begin if beamed then
203 error3(voice, 'Starting a forced beam while another is open');
204 if beam_level>0 then error3(voice,
205 'Starting a forced beam while another is open (beamlevel>0)');
206 inc(beam_level);
207 beamnext := true; no_beam_melisma:=startsWith(note,'[[');
208 if no_beam_melisma then predelete(note,1);
209 end;
210 end;
211
212 procedure endBeam(voice: integer);
213 begin with current[voice] do
214 begin if beam_level<1 then error3(voice, 'Closing a beam that was never opened');
215 dec(beam_level)
216 end;
217 setUnbeamed(voice)
218 end;
219
slurLevelnull220 function slurLevel(voice: integer): integer;
221 begin slurLevel := current[voice].slur_level; end;
222
beamLevelnull223 function beamLevel(voice: integer): integer;
224 begin beamLevel := current[voice].beam_level; end;
225
noSlurMelismanull226 function noSlurMelisma(voice, history: integer): boolean;
227 begin with current[voice] do
228 noSlurMelisma := no_slur_melisma[slur_level+history];
229 end;
230
slurLabelnull231 function slurLabel(voice: integer; note: string): string;
232 var sl: char;
233 begin if note='' then begin slurLabel:=''; exit end;
234 if length(note)<2 then begin slurLabel:=' '; exit end;
235 if (note[2]>='0') and (note[2]<='Z') then sl:=note[2] else sl:=' ';
236 if (sl>='I') and (sl<='T') then
237 warning3(voice,'Slur label in the range I..T may cause conflict');
238 slurLabel:=sl
239 end;
240
241 procedure labelSlur(voice: integer; var note: string);
242 var sl: char;
243 begin if note='' then exit;
244 with current[voice] do
245 begin
246 if note[1]=')' then inc(slurID,2) else if note[1]='}' then inc(tieID,2);
247 if (note[1]='(') or (note[1]=')') then sl:=slurID else sl:=tieID;
248 insertchar(sl,note,2);
249 if note[1]='(' then dec(slurID,2) else if note[1]='{' then dec(tieID,2);
250 if slurID<'I' then warning3(voice,'Too many nested slurs may cause conflict');
251 if tieID<'I' then warning3(voice,'Too many nested ties may cause conflict')
252 end
253 end;
254
255 procedure beginSlur(voice: integer; var note: string);
256 var posblind: integer;
257 begin
258 with current[voice] do
259 begin
260 inc(slur_level); if slur_level>12 then Error3(voice,'Too many open slurs');
261 no_slur_melisma[slur_level] := startsWith(note,'((') or startsWith(note,'{{');
262 if no_slur_melisma[slur_level] then predelete(note,1);
263 if slurLabel(voice,note)='0' then delete1(note,2) else
264 if slurLabel(voice,note)=' ' then labelSlur(voice,note);
265 posblind:=pos1('~',note); if posblind>0 then
266 if hideBlindSlurs then note:='' else delete1(note,posblind);
267 slurnext := true;
268 end;
269 end;
270
271 procedure endSlur(voice: integer; var note: string);
272 var poscontinue, posblind: integer;
273 contslur: string;
274 begin with current[voice] do
275 begin contslur:='';
276 if slur_level<1 then Error3(voice,'Ending a slur that was never started');
277 if note[1]=')' then poscontinue:=pos1('(',note)
278 else if note[1]='}' then poscontinue:=pos1('{',note);
279 if poscontinue=0 then dec(slur_level) else
280 begin dec(poscontinue); contslur:=note; predelete(contslur,poscontinue);
281 shorten(note,poscontinue);
282 end;
283 if slur_level=0 then setUnslurred(voice);
284 if slurLabel(voice,note)='0' then delete1(note,2) else
285 if slurLabel(voice,note)=' ' then labelSlur(voice,note);
286 if slurLabel(voice,contslur)='0' then delete1(contslur,2) else
287 if slurLabel(voice,contslur)=' ' then labelSlur(voice,contslur);
288 if poscontinue>0 then
289 begin if note[1]='}' then note:=note+'t'; note[1]:='s';
290 if contslur[1]='{' then contslur:=contslur+'t'; contslur[1]:='s';
291 end;
292 posblind:=pos1('~',note); if posblind>0 then
293 if hideBlindSlurs then note:='' else delete1(note,posblind);
294 if (note<>'') and (contslur<>'') then note := note + ' ' + contslur;
295 end;
296 end;
297
298 procedure renewPitch (voice: integer; var note: string);
299 var pstat: integer;
300 begin with current[voice] do
301 begin pstat:=newPitch (voice, note, chord_pitch, chord_lastnote);
302 if debugMode then write('Current pitch in voice ',voice,' is ',pitch,
303 ', last note was ',lastnote,', this note is ',note);
304 pitch := newPitch (voice, note, pitch, lastnote);
305 if pitch<>pstat then repitch(note,pitch-pstat);
306 if (pitch<lowest_pitch) and checkPitch then
307 begin write('Pitch of note ',note,' following ',lastnote,' reported as ',pitch);
308 error3(voice,'Pitch too low')
309 end;
310 if (pitch>highest_pitch) and checkPitch then
311 begin write('Pitch of note ',note,' following ',lastnote,' reported as ',pitch);
312 error3(voice,'Pitch too high')
313 end;
314 lastnote:=note[1];
315 if debugMode then writeln(', repitched to ',pitch);
316 if debugMode and (pitch<>pstat) then
317 writeln('Pitch from melodic line = ',pitch,
318 ' from last chordal note = ', pstat);
319 end;
320 end;
321
chordPitchnull322 function chordPitch(voice: integer): integer;
323 begin chordPitch:=current[voice].chord_pitch end;
324
325 procedure renewChordPitch (voice: integer; note: string);
326 begin with current[voice] do
327 begin chord_pitch:=newPitch(voice,note,chord_pitch,chord_lastnote);
328 if chord_pitch<lowest_pitch then error3(voice,'Pitch in chord too low');
329 if chord_pitch>highest_pitch then error3(voice,'Pitch in chord too high');
330 chord_lastnote:=note[1];
331 end
332 end;
333
334 procedure initStatus;
335 var voice: integer;
336 begin for voice:=1 to nvoices do with current[voice] do
337 begin duration:=default_duration;
338 octave_adjust:=0; slur_level:=0; beam_level:=0;
339 beamed:=false; beamnext:=false;
340 slurred:=false; slurnext:=false; after_slur:=0;
341 octave:=initOctave(voiceStave(voice)); slurID:='S'; tieID:='T';
342 lastnote:='f'; pitch:=7*(ord(octave)-ord('0'))-3;
343 chord_tie_label:='';
344 saveStatus(voice);
345 end;
346 end;
347
348 end.
349