1 unit notes;
2
3 interface uses control;
4
5 const count64: array['0'..'9'] of integer =
6 ( 64, 4, 32, 2, 16, 0, 1, 0, 8, 128 );
7
8 procedure processNote(var note, xnote: string; dur1: char; var dur: char;
9 var count: integer);
durationCodenull10 function durationCode (note: string): char;
octaveCodenull11 function octaveCode (note: string): char;
12 procedure removeOctaveCode(code: char; var note: string);
13 procedure insertOctaveCode(code: char; var note: string);
14 procedure translateSolfa(var nt: char);
15
16 implementation uses strings, globals;
17
18 type
19
20 parsedNote = record
21 name: char;
22 duration: string[1];
23 octave: string[8];
24 accidental, whatever, dotgroup, xtuplet: string[16];
25 shortcut: string[32];
26 end;
27
28 procedure printNote(n: parsedNote);
29 begin with n do writeln(name,'|',duration,'|',octave,'|',accidental,'|',
30 whatever,'|',dotgroup,'|',xtuplet,'|',shortcut)
31 end;
32
33 { If rearrangeNote is TRUE, translate original note to the following form:
34 1. Note name.
35 2. Duration.
36 3. Octave adjustments.
37 4. Everything except the other six items.
38 5. Accidental with adjustments (rest: height adjustment)
39 6. Dot with adjustments.
40 7. Xtuplet group.
41 }
42
43 procedure translateSolfa(var nt: char);
44 var k: integer;
45 begin if solfaNoteNames then
46 begin k:=pos1(nt,solfa_names); if k>0 then nt:=has_duration[k]
47 end
48 end;
49
durationCodenull50 function durationCode (note: string): char;
51 var code: char;
52 begin durationCode:=unspecified; if length(note)>1 then
53 begin code:=note[2]; if pos1(code,durations)>0 then durationCode:=code
54 end
55 end;
56
halfnull57 function half ( dur: char ) : char;
58 var k: integer;
59 begin k:= pos1 (dur, durations ); half := dur;
60 if k=0 then error ('Invalid duration '+dur,print)
61 else if k>ndurs then error (dur+' is too short to halve',print)
62 else half := durations[k+1];
63 end;
64
65 procedure addDuration ( var note: string; dur: char);
66 begin if insertDuration then insertchar(dur,note,2); end;
67
68 { Extract procedures. All of these remove part of "note" (sometimes
69 the part is empty) and put it somewhere else. The part may be anywhere
70 in "note", except when otherwise specified.}
71
72 { Unconditionally extracts the first character. }
73
74 procedure extractFirst(var note: string; var first: char);
75 begin first:=note[1]; predelete(note,1)
76 end;
77
78 { Extracts at most one of the characters in "hits". }
79
80 procedure extractOneOf(var note: string; hits: string; var hit: string);
81 var i, l: integer;
82 begin l:=length(note); hit:='';
83 for i:=1 to l do if pos1(note[i],hits)>0 then
84 begin hit:=note[i]; delete1(note,i); exit;
85 end;
86 end;
87
88 { Extracts contiguous characters in "hits" until no more are found.
89 There may be more later. }
90
91 procedure extractContiguous(var note: string; hits: string; var hit: string);
92 var i, l, len: integer;
93 begin l:=length(note); len:=l; hit:='';
94 for i:=1 to l do if pos1(note[i],hits)>0 then
95 begin
96 repeat if pos1(note[i],hits)=0 then exit;
97 hit:=hit+note[i]; delete1(note,i); dec(len)
98 until len<i;
99 exit;
100 end;
101 end;
102
103 { Extracts the specified character and everything after it. }
104
105 procedure extractAfter(var note: string; delim: char; var tail: string);
106 var newlen: integer;
107 begin newlen:=pos1(delim,note); tail:=''; if newlen=0 then exit;
108 dec(newlen); tail:=note; predelete(tail,newlen); note[0]:=char(newlen);
109 end;
110
111 { Extracts the dot shortcut part of a note: comma shortcut is no problem
112 because a comma cannot be part of a number. }
113
114 procedure extractDotShortcut(var note: string; var tail: string);
115 var names, tail2: string;
116 l, lt: integer;
117 ch: char;
118 begin extractAfter(note,'.',tail); l:=1; lt:=length(tail);
119 if (l<lt) and (tail[2]='.') then l:=2;
120 if solfaNoteNames then names:=solfa_names else names:=has_duration;
121 if (l<lt) and (pos1(tail[l+1],names)>0) then
122 begin translateSolfa(tail[l+1]); exit end;
123 if l=2 then error('".." followed by non-note',print);
124 if l>=lt then begin note:=note+tail; tail:=''; exit end;
125 ch:=tail[1]; predelete(tail,1);
126 extractDotShortcut(tail,tail2); note:=note+ch+tail; tail:=tail2;
127 end;
128
129 { Extracts a signed number. }
130
131 procedure extractSignedNumber(var note, number: string);
132 var k: integer;
133 note0: string;
134 begin k:=pos1('+',note); if k=0 then k:=pos1('-',note);
135 number:=''; if k=0 then exit;
136 note0:=note;
137 repeat number:=number+note[k]; delete1(note,k)
138 until (k>length(note)) or (note[k]<>'0') and (pos1(note[k],digits)=0);
139 if length(number)=1 then begin note:=note0; number:='' end
140 end;
141
142 { Extracts a symbol followed by optional +- or <> shift indicators }
143
144 procedure extractGroup(var note: string; delim: char; var group: string);
145 var gl, k, k0: integer;
146 probe, nonumber: boolean;
147 tail: string;
148 procedure tryMore;
149 begin while (k<=gl) and (group[k]=group[1]) do inc(k) end;
150 procedure try(s: string);
151 begin probe:=(k<gl) and (pos1(group[k],s)>0); if probe then inc(k)
152 end;
153 procedure tryNumber;
154 var dot: boolean;
155 begin nonumber:=true; dot:=false;
156 while (k<=gl) and (pos1(group[k],digitsdot)>0) do
157 begin inc(k); if group[k]='.' then
158 if dot then error('Extra dot in number',print) else dot:=true
159 else nonumber:=false
160 end
161 end;
162 begin extractAfter(note,delim,group); if group='' then exit;
163 gl:=length(group); k:=2;
164 if (gl>1) and (group[2]=':') then k:=3 else
165 begin tryMore;
166 k0:=k; try('+-<>'); if probe then tryNumber; if nonumber then k:=k0;
167 k0:=k; try('+-<>'); if probe then tryNumber; if nonumber then k:=k0;
168 end;
169 tail:=group; dec(k); group[0]:=char(k); predelete(tail,k);
170 note:=note+tail
171 end;
172
173 procedure parseNote(note: string; var pnote: parsedNote);
174 var onlymidi: string;
175 begin with pnote do
176 begin
177 shortcut:=''; xtuplet:=''; accidental:=''; dotgroup:='';
178 duration:=''; octave:=''; onlymidi:='';
179 extractFirst(note,name);
180 extractAfter(note,'x',xtuplet);
181 extractAfter(note,',',shortcut);
182 if shortcut='' then extractDotShortcut(note,shortcut);
183 if name<>rest then
184 begin extractGroup(note,'s',accidental);
185 if accidental='' then extractGroup(note,'f',accidental);
186 if accidental='' then extractGroup(note,'n',accidental);
187 end;
188 { Look for 'i' or 'c' anywhere in what is left of note.}
189 if accidental<>'' then
190 begin extractOneOf(note,'ic',onlymidi); accidental:=accidental+onlymidi
191 end;
192 extractGroup(note,'d',dotgroup);
193 if name=rest then extractSignedNumber(note,accidental);
194 extractOneOf(note,durations,duration);
195 if note<>rest then extractContiguous(note,'=+-',octave);
196 if (length(note)>0) and (note[1]>='0') and (note[1]<='9')
197 then begin octave:=note[1]+octave; delete1(note,1) end;
198 whatever := note
199 end
200 end;
201
202 { On input: "note" is a note word; "dur1" is the default duration.
203 On output: "note" has possibly been modified;
204 possibly been split into two parts, the second being "shortcut";
205 "dur" is the suggested new default duration;
206 "count" is the count of the total of "note" and "shortcut" }
207 procedure processNote(var note, xnote: string; dur1: char; var dur: char;
208 var count: integer);
209 var sc, origdur: string[2];
210 multiplicity, l: integer;
211 pnote: parsedNote;
212 begin xnote:=''; dur:=dur1;
213 if (note='') or not isNoteOrRest(note) or isPause(note) then exit;
214 parseNote(note, pnote);
215 if debugMode then begin write(note,' => '); printNote(pnote) end;
216 with pnote do
217 begin
218 if pos1('.',whatever)>0 then warning('Suspicious dot in word '+note,print);
219 origdur := duration;
220 if duration='' then dur:=dur1 else dur:=duration[1];
221 count:=count64[dur]; if dotgroup<>'' then
222 begin inc(count,count div 2);
223 if startswith(dotgroup,'dd') then inc(count,count div 6)
224 end;
225 duration:=dur; if shortcut<>'' then
226 begin
227 if dotgroup<>'' then
228 error('You may not explicitly dot a note with a shortcut',print);
229 sc:=shortcut[1]; predelete(shortcut,1);
230 if sc='.' then
231 begin multiplicity:=1;
232 if shortcut[1]='.' then
233 begin inc(multiplicity); predelete(shortcut,1); sc:=sc+'.' end;
234 inc(count,count); dur1:=duration[1];
235 for l:=1 to multiplicity do
236 begin dotgroup:=dotgroup+dotcode; dur1:=half(dur1) end;
237 addDuration(shortcut,dur1);
238 end else
239 begin addDuration(shortcut,half(duration[1]));
240 inc(count,count div 2)
241 end
242 end;
243 if not insertDuration then duration := origdur;
244 if rearrangeNote
245 then note := name + duration + octave + whatever
246 + accidental + dotgroup + xtuplet
247 else shortcut:=' ';
248 if not insertDuration and (shortcut<>'') then shortcut:=sc+shortcut;
249 xnote:=shortcut
250 end
251 end;
252
octaveCodenull253 function octaveCode (note: string): char;
254 var pnote: parsedNote;
255 begin {if debugMode then write('Octave code in note "',note,'" is ');}
256 parseNote(note,pnote); with pnote do
257 begin {if debugMode then writeln('"',octave,'"');}
258 if octave='' then octaveCode:=' ' else octaveCode:=octave[1]; end
259 end;
260
261 procedure removeOctaveCode(code: char; var note: string);
262 var k, l: integer;
263 begin {if debugMode then writeln('remove ',code,' from ',note);} l:=length(note);
264 for k:=1 to l do if note[k]=code then
265 if (k=l) or (note[k+1]<'0') or (note[k+1]>'9') then
266 begin delete1(note,k); exit end;
267 fatalError('Code not found in note')
268 end;
269
270 procedure insertOctaveCode(code: char; var note: string);
271 var l: integer;
272 begin {if debugMode then writeln('insert ',code,' into ',note); }
273 l:=length(note);
274 if (l<2) or (note[2]<'0') or (note[2]>'9') then
275 fatalError('Trying to insert octave into note without duration');
276 if (l<=2) or (note[3]<'0') or (note[3]>'9') then insertChar(code,note,3)
277 else writeln('Not inserting "',code,'", note already has octave code"')
278 end;
279
280 end.
281