summaryrefslogtreecommitdiff
path: root/Build/source/utils/m-tx/mtx-src/mtx.pas
blob: 7fc12ec554c460dd18541f1bc471a1c6fe669585 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
unit mtx;
{ Details of M-Tx -> PMX translation }

interface uses globals;

procedure scanMusic(voice: voice_index; var left_over: integer);
procedure markDebeamed(voice: voice_index; var note: string);
procedure checkOctave(voice: voice_index; var note: string);
function rests (len, meterdenom: integer; blind: boolean): string;
procedure initMTX;

implementation  uses control, mtxline, strings, status, notes;

const flagged = '8136';

type sticky = array['a'..'z'] of boolean;

var note_attrib, rest_attrib: array[voice_index] of sticky;

function logTwo(denom: integer): integer;
  var l: integer;
begin  l:=0; while denom>1 do begin inc(l); denom:=denom div 2; end;
  logtwo:=l;
end;

{ RESTS should have a third parameter OFFSET.  At present we in effect
  assume OFFSET+LENGTH to be a multiple of METERDENOM. }
function rests (len, meterdenom: integer; blind: boolean): string;
  var r, bl: string;
  function dotted(n: integer): boolean;
  begin  dotted:=false;  if n=0 then exit;
    if n<>3*(n div 3) then exit;
    n:=n div 3;  while n mod 2 = 0 do n:=n div 2;
    dotted := n=1;
  end;
  begin  if blind then bl:='b' else bl:='';
    if len=0 then rests:='' else
    if len=128*meterdenom then rests:='r9'+bl+' ' else
    if dotted(len) then
    begin r:=rests(len-len div 3,meterdenom,false);
      r[3]:='d'; rests:=r+bl+' ';
    end
    else if len>=64 div meterdenom then
      rests:=rests(len-64 div meterdenom,meterdenom,blind)+'r'
        +durations[whole+logtwo(meterdenom)]+bl+' '
    else rests:=rests(len,meterdenom*2,blind);
  end;

procedure checkSticky(var note: string; var attrib: sticky);
  var i,l: integer;
      c: char;
      a: string;
  function attribs(note: string): string;
    var a: string;
        i,l: integer;
        n: char;
  begin  a:='';  i:=2;  l:=length(note);
    while i<=l do
    begin  n:=note[i];
      if n='x' then i:=l else if (n>='a') and (n<='z') then a:=a+n;
      inc(i);
    end;
    attribs:=a;
  end;
begin  if note='' then exit;
  l:=length(note); i:=2;
  while i<=l do
  begin c:=note[i];
    if (c>='a') and (c<='z') then
      if (i<l) and (note[i+1]=':') then
        begin delete1(note,i+1); dec(l); attrib[c]:=not attrib[c]; end
      else attrib[c]:=false;
    inc(i);
  end;
  a:=attribs(note);
  for c:='z' downto 'a' do
  if attrib[c] and (pos1(c,a)=0) then insertchar(c,note,3);
end;

{ Routine was patched by Hiroaki Morimoto, revised 2003/08/15.  
  Rewritten by DPL 2004/05/16 to be more understandable. 
  octaveCode returns octave adjustments in the order 
  [absolute or =],[relative] }
procedure checkOctave(voice: voice_index; var note: string);
  var code: char;
begin  
  code:=octaveCode(note);   
  if code='=' then begin setOctave(voice); removeOctaveCode(code,note); end;
  if octave(voice)=blank then exit; 
  code:=octaveCode(note);
  if (code>='0') and (code<='9') then begin resetOctave(voice); exit end; 
  while (code='+') or (code='-') do
  begin 
    newOctave(voice,code); removeOctaveCode(code,note); code:=octaveCode(note)
  end;
  if code<>' ' then error3(voice,'You may have only one absolute octave assignment');
  insertOctaveCode(octave(voice),note); 
  checkRange(voice,note);
  resetOctave(voice)
end;

procedure markDebeamed(voice: voice_index; var note: string);
begin
  if isVocal(voice) and (afterSlur(voice)=0) and unbeamVocal
     and (pos1(duration(voice),flagged)>0) then insertchar('a',note,2);
end;

function barLength (meter: string): integer;
  var n1, n2, pn1, pn2: integer;
begin  
  getMeter(meter,n1,n2,pn1,pn2); barLength := n1*(64 div n2);
end;

function isMultiBarRest(rest: string): boolean;
begin  isMultibarRest:=false;  if length(rest)<3 then exit;
  if rest[2]<>'m' then exit;
  if multi_bar_rest<>'' then error(
    'Only one multibar rest allowed per line',print);
  multi_bar_rest := rest; isMultibarRest:=true;
end;

{ Double-length in xtuplet detected by a brute search for D anywhere.
  Could be more elegant. }

var macro_length: array[1..20] of integer;
const macro_ID: array[1..20] of string[2]=('1','2','3','4','5','6','7','8',
         '9','10','11','12','13','14','15','16','17','18','19','20');

procedure scanMusic(voice: voice_index; var left_over: integer);
  var buf, note, enote, xnote: string;
      has_next, done, doublex, store_macro: boolean;
      bar, old_length, bar_length, count, l, mlen, ngrace, nmulti,
        macroID, playID: integer;
      dur1, lastdur, macro_type: char;
      nscan: music_word;

  procedure decmulti;
  begin if doublex then dec(nmulti,2) else dec(nmulti)
  end;

  procedure countIt;
    procedure incbar(nl: integer);
    begin inc(bar_length,nl);
      if (bar_length>bar) and (meternum>0)
        then error3(voice,'Bar end occurs in mid-note');
    end;
  begin
    if ngrace>0 then dec(ngrace) else
    if nmulti>0 then decmulti else
    begin  if (count mod 3<>0) and (
        (note[1]<>rest) and note_attrib[voice,'d'] or
        (note[1]=rest) and rest_attrib[voice,'d']) then
        inc(count,count div 2);
      incbar(count);
      l := pos1(multi_group,note);
      if l>0 then
      begin  predelete(note,l);  getNum(note,nmulti); decmulti;
      end;
    end
  end;

  procedure maybeGroup;
  begin if note[1]=grace_group then
    begin  if length(note)=1 then ngrace:=1
      else ngrace := pos1(note[2],digits);  (* bug if ngrace>9 *)
      if ngrace>0 then dec(ngrace);
    end;
  end;
  
  function identifyMacro(s: string): integer;
    var k: integer;
  begin predelete(s,2); for k:=1 to 20 do if s=macro_ID[k] then 
    begin identifyMacro:=k; exit end;
    identifyMacro:=0
  end; 

  procedure examineMacro;
  begin if not countMacro then exit;
    if debugMode then write(note,': '); if length(note)=1 then 
    begin 
      mlen:=bar_length-old_length; 
      if (macroID<1) or (macroID>20) then error3(voice,'Invalid macro ID');
      macro_length[macroID]:=mlen; 
      if debugMode then
      writeln('Ending macro ',macroID,' of type ',macro_type,', length=', mlen);
      if macro_type='S' then bar_length:=old_length; store_macro:=false
    end
    else begin playID:=identifyMacro(note);
      if (playID<1) or (playID>20) then error3(voice,'Invalid macro ID');
      if note[2]='P' then 
      begin if debugMode then
        writeln('Playing macro ',playID,' of length ', 
          macro_length[playID]); 
        inc(bar_length,macro_length[playID])
      end
      else if pos1(note[2],'SR')>0 then 
      begin old_length:=bar_length; macro_type:=note[2]; macroID:=playID;
        store_macro:=true;
        if debugMode then writeln('Defining macro ',macroID,' of type ',note[2]) 
      end
    end
  end;

begin
  terminators:='d.x';
  resetInfo(voice, buf);  has_next := false;  left_over:=0;  store_macro:=false;
  bar:=full_bar;  bar_length:=0;  ngrace:=0;  nmulti:=0;
  if meternum=0 then bar:=32000;
  dur1:=duration(voice);  lastdur:=dur1;
  done:=false;
  repeat  GetNextMusWord(buf,note,nscan);  if length(note)=0 then break; count:=0;
{    if isNoteOrRest(note) and not (isPause(note) or isMultibarRest(note))
      then note:=toStandard(note); }
    doublex := (pos1('D',note)>0) or (pos1('F',note)>0); 
    if nscan=mword then
    begin 
      if length(note)=0 then 
         Error3(voice,'You may not end a line with a meter change');
      if bar_length>0 then
      error3(voice,'Meter change only allowed at start of bar')
      else bar:=barLength(note);
    end
    else if nscan=rword then
      if not (isPause(note) or isMultiBarRest(note) 
        or (ngrace + nmulti > 0)) then  {0.63: allow rests in xtuples}
      begin
        processNote(note,xnote,dur1,lastdur,count);
        checkSticky(note,rest_attrib[voice]);
      end;
    if note<>'' then  appendNote(voice,nscan);
    enote := note;
    if (nscan=macro) or (nscan=endMacro) then examineMacro;
    if nscan=abcdefg then
      if (multi_bar_rest='') and (ngrace + nmulti = 0) then
      begin
        processNote(enote,xnote,dur1,lastdur,count);
        if xnote<>'' then
        begin
          checkSticky(enote,note_attrib[voice]);
          appendToLine(voice,enote);
          appendNote(voice,nscan); enote := xnote;
        end;
        checkSticky(enote,note_attrib[voice]);
      end;
    appendToLine(voice,enote);
    if note='' then done:=true;  { !!! else word_bound[here]:=length(line); }
    if note=barsym then
    if meternum=0 then
      error3(voice,'You may not use bar lines in barless music')
    else if bar_length=0 then markBar(voice)
    else if (numberOfBars(voice)=0) and (bar_length<bar) then
    begin  if has_next then
      has_next:=false  {TODO Should check whether pickups are equal}
      else if left_over>0 then error3(voice,'Bar is too short');
      left_over:=bar_length;  bar_length := 0;
    end;
    if nscan=nextvoice then
    begin  if bar_length>0 then error3(voice, 'Next voice before bar is full')
      else barForward(voice,-1);  has_next := true;
    end
    else  if isPause(note) then  inc(bar_length,bar)
    else  if multi_bar_rest<>'' then {do nothing}
    else if not done and isNoteOrRest(note) then countIt
      else maybeGroup;
    dur1:=lastdur; 
    if (bar_length>=bar) and (ngrace+nmulti=0) and not store_macro then
    begin if debugMode then writeln(voice,' ',bar_length);
      barForward(voice,bar_length div bar); bar_length:=bar_length mod bar
    end;
  until done;
  setExtraLength(voice,bar_length);
  resetDuration(voice,dur1);
  regroup(voice)
end;

procedure initMTX;
  var i: voice_index;  j: char;
begin  for i:=1 to maxvoices do  for j:='a' to 'z' do
  note_attrib[i,j] := false;
  rest_attrib := note_attrib;
end;

end.