diff options
Diffstat (limited to 'Build/source/utils/m-tx/mtx-src/status.pas')
-rw-r--r-- | Build/source/utils/m-tx/mtx-src/status.pas | 396 |
1 files changed, 396 insertions, 0 deletions
diff --git a/Build/source/utils/m-tx/mtx-src/status.pas b/Build/source/utils/m-tx/mtx-src/status.pas new file mode 100644 index 00000000000..3048027a7bb --- /dev/null +++ b/Build/source/utils/m-tx/mtx-src/status.pas @@ -0,0 +1,396 @@ +unit status; +{ Keep track of duration, octave, slur and beam status. } + +interface + +procedure initStatus; +procedure saveStatus(voice: integer); + +procedure resetDuration (voice: integer; dur: char); +function duration(voice: integer): char; + +function slurLevel(voice: integer): integer; +function beamLevel(voice: integer): integer; +function noBeamMelisma(voice: integer): boolean; +function noSlurMelisma(voice, history: integer): boolean; +function afterSlur(voice: integer): integer; +procedure setUnbeamed(voice: integer); +procedure setUnslurred(voice: integer); +procedure beginBeam(voice: integer; var note: string); +procedure endBeam(voice: integer); +procedure beginSlur(voice: integer; var note: string); +procedure endSlur(voice: integer; var note: string); +procedure activateBeamsAndSlurs(voice: integer); + +procedure setOctave(voice: integer); +procedure resetOctave(voice: integer); +function octave(voice: integer): char; +procedure newOctave(voice: integer; dir: char); +procedure initOctaves(octaves: string); + +procedure renewPitch (voice: integer; var note: string); +function chordPitch(voice: integer): integer; +procedure renewChordPitch (voice: integer; note: string); +procedure defineRange(voice: integer; range: string); +procedure checkRange(voice: integer; note: string); +procedure rememberDurations; +procedure restoreDurations; +procedure chordTie(voice: integer; var lab: char); +type int5 = array[1..5] of integer; +procedure getChordTies(voice: integer; var pitches: int5; var labels: string); + +implementation uses globals, strings, mtxline, control, utility, notes; + +const + init_oct: string = ''; + lowest_pitch = -9; + highest_pitch = 61; + range_name: array[-6..49] of string = ( +'0c','0d','0e','0f','0g','0a','0b', +'1c','1d','1e','1f','1g','1a','1b', +'2c','2d','2e','2f','2g','2a','2b', +'3c','3d','3e','3f','3g','3a','3b', +'4c','4d','4e','4f','4g','4a','4b', +'5c','5d','5e','5f','5g','5a','5b', +'6c','6d','6e','6f','6g','6a','6b', +'7c','7d','7e','7f','7g','7a','7b'); + +type + line_status = record + pitch, chord_pitch, octave_adjust, beam_level, + slur_level, after_slur: integer; + octave, lastnote, chord_lastnote, duration, slurID, tieID: char; + beamnext, beamed, slurnext, slurred, no_beam_melisma: boolean; + no_slur_melisma: array[1..12] of boolean; + chord_tie_pitch: int5; + chord_tie_label: string[5]; + end; + +var current: array[voice_index] of line_status; + lastdur: array[voice_index] of char; + voice_range, range_low, range_high: array[voice_index] of string; + +{ Range limits are user-specified as e.g. 3c. To make comparisons +meaningful, a and b (which come after g) are translated to h and i. } + +procedure checkRange(voice: integer; note: string); +begin + if voice_range[voice]='' then exit; + if length(note)>2 { assume usual PMX form with octave } then + note := note[3]+note[1]; + if note[2]='a' then note[2]:='h'; + if note[2]='b' then note[2]:='i'; + if (note<range_low[voice]) or (note>range_high[voice]) then + error3(voice,note+' is out of range, specified as '+voice_range[voice]) +end; + +procedure defineRange(voice: integer; range: string); +begin + voice_range[voice] := range; + if range='' then exit; + if not ( + ('0'<=range[1]) and (range[1]<='7') + and ('a'<=range[2]) and (range[2]<='g') + and (range[3]='-') + and ('0'<=range[4]) and (range[4]<='7') + and ('a'<=range[5]) and (range[5]<='g') + ) then error('Badly formatted range "'+range+ + '" for voice '+voice_label[voice]+', must be e.g. 3c-4a',print); + if range[2]='a' then range[2]:='h'; + if range[2]='b' then range[2]:='i'; + if range[5]='a' then range[5]:='h'; + if range[5]='b' then range[5]:='i'; + range_low[voice]:=substr(range,1,2); + range_high[voice]:=substr(range,4,2); +end; + +procedure chordTie(voice: integer; var lab: char); + var n: integer; +begin with current[voice] do + begin n:=length(chord_tie_label); + if n=5 then error3(voice,'Only five slur ties allowed per voice'); + if n=0 then lab:='T' else lab:=chord_tie_label[n]; + inc(lab); chord_tie_label:=chord_tie_label+lab; + inc(n); chord_tie_pitch[n]:=chord_pitch + end +end; + +procedure getChordTies(voice: integer; var pitches: int5; var labels: string); +begin with current[voice] do + begin pitches:=chord_tie_pitch; labels:=chord_tie_label; chord_tie_label:='' end +end; + +procedure rememberDurations; + var v: voice_index; +begin for v:=1 to nvoices do lastdur[v]:=duration(v) end; + +procedure restoreDurations; + var v: voice_index; +begin for v:=1 to nvoices do resetDuration(v,lastdur[v]) end; + +function duration(voice: integer): char; +begin duration := current[voice].duration; end; + +procedure resetDuration(voice: integer; dur: char); +begin if pos1(dur,durations)=0 then + begin write('Trying to set duration to ',dur,'; '); + error3(voice,'M-Tx system error: resetDuration'); + end; + current[voice].duration := dur +end; + + +procedure activateBeamsAndSlurs(voice: integer); +begin with current[voice] do + begin + if beamnext then begin beamed:=true; beamnext:=false; end; + if slurnext then begin slurred:=true; slurnext:=false; end; + if slurred then inc(after_slur); + end +end; + +procedure saveStatus(voice: integer); +begin with current[voice] do + begin chord_pitch := pitch; chord_lastnote := lastnote; end; +end; + +function noBeamMelisma(voice: integer): boolean; +begin noBeamMelisma := current[voice].no_beam_melisma; end; + +function afterSlur(voice: integer): integer; +begin with current[voice] do + begin afterSlur := after_slur; if (after_slur>0) and (slur_level<1) then + error3(voice,'M-Tx system error: afterSlur and slur_level incompatible)') + end +end; + +function octave(voice: integer): char; +begin octave := current[voice].octave; end; + +procedure resetOctave(voice: integer); +begin current[voice].octave := ' '; end; + +procedure initOctaves(octaves: string); + var i: integer; +begin init_oct:=octaves; + i:=1; + while i<=length(init_oct) do + if init_oct[i]=' ' then delete1(init_oct,i) else inc(i); +end; + +function initOctave(voice_stave: stave_index): char; +begin + if voice_stave>length(init_oct) then + if pos1(clef[voice_stave],'Gt08')>0 + then initOctave:='4' else initOctave:='3' + else initOctave:=init_oct[voice_stave]; +end; + +procedure setOctave(voice: integer); +begin current[voice].octave:=initOctave(voiceStave(voice)); end; + +procedure newOctave(voice: integer; dir: char); +begin with current[voice] do case dir of + '+': inc(octave); + '-': dec(octave); + end; +end; + +function newPitch (voice: integer; note: string; pitch: integer; + lastnote: char): integer; + var interval, npitch: integer; + oct: char; +begin + oct:=octaveCode(note); + if oct='=' then oct:=initOctave(voiceStave(voice)); + if (oct>='0') and (oct<='9') then + begin pitch:=7*(ord(oct)-ord('0'))-3; lastnote:='f'; + removeOctaveCode(oct,note); oct:=octaveCode(note) + end; + interval := ord(note[1])-ord(lastnote); + if interval>3 then dec(interval,7); + if interval<-3 then inc(interval,7); + npitch:=pitch+interval; + while oct<>' ' do + begin if oct='+' then inc(npitch,7) else if oct='-' then dec(npitch,7); + removeOctaveCode(oct,note); oct:=octaveCode(note) + end; + newPitch:=npitch +end; + +procedure repitch(var note: string; diff: integer); + procedure delins(var note: string; c1, c2: char; l: integer); + var i, n: integer; + begin n:=length(note); i:=pos1(c1,note); if i=0 then i:=n+1; + while (l>0) and (i<=n) do begin delete1(note,i); dec(n); dec(l); end; + i:=pos1(c2,note); + if i=0 then if length(note)<2 then error('M-Tx program error',print) + else i:=3; + while l>0 do begin insertchar(c2,note,i); dec(l); end; + end; + begin diff:=diff div 7; + if diff>0 then delins(note, '-','+',diff) + else delins(note, '+','-',-diff); + end; + +procedure setUnbeamed(voice: integer); +begin current[voice].beamed:=false end; + +procedure setUnslurred(voice: integer); +begin with current[voice] do + begin slurred:=false; after_slur:=0; end; +end; + +procedure beginBeam(voice: integer; var note: string); +begin with current[voice] do + begin if beamed then + error3(voice, 'Starting a forced beam while another is open'); + if beam_level>0 then error3(voice, + 'Starting a forced beam while another is open (beamlevel>0)'); + inc(beam_level); + beamnext := true; no_beam_melisma:=startsWith(note,'[['); + if no_beam_melisma then predelete(note,1); + end; +end; + +procedure endBeam(voice: integer); +begin with current[voice] do + begin if beam_level<1 then error3(voice, 'Closing a beam that was never opened'); + dec(beam_level) + end; + setUnbeamed(voice) +end; + +function slurLevel(voice: integer): integer; +begin slurLevel := current[voice].slur_level; end; + +function beamLevel(voice: integer): integer; +begin beamLevel := current[voice].beam_level; end; + +function noSlurMelisma(voice, history: integer): boolean; +begin with current[voice] do + noSlurMelisma := no_slur_melisma[slur_level+history]; +end; + +function slurLabel(voice: integer; note: string): string; + var sl: char; +begin if note='' then begin slurLabel:=''; exit end; + if length(note)<2 then begin slurLabel:=' '; exit end; + if (note[2]>='0') and (note[2]<='Z') then sl:=note[2] else sl:=' '; + if (sl>='I') and (sl<='T') then + warning3(voice,'Slur label in the range I..T may cause conflict'); + slurLabel:=sl +end; + +procedure labelSlur(voice: integer; var note: string); + var sl: char; +begin if note='' then exit; + with current[voice] do + begin + if note[1]=')' then inc(slurID,2) else if note[1]='}' then inc(tieID,2); + {* CMO 0.60a: replace assigning tieID to sl by space charater + if (note[1]='(') or (note[1]=')') then sl:=slurID else sl:=tieID; } + if (note[1]='(') or (note[1]=')') then sl:=slurID else sl:=' '; + {* CMO 0.60d: omit insertchar in case of tie + insertchar(sl,note,2); } + if (note[1]='(') or (note[1]=')') then insertchar(sl,note,2); + if note[1]='(' then dec(slurID,2) else if note[1]='{' then dec(tieID,2); + if slurID<'I' then warning3(voice,'Too many nested slurs may cause conflict'); + if tieID<'I' then warning3(voice,'Too many nested ties may cause conflict') + end +end; + +procedure beginSlur(voice: integer; var note: string); + var posblind: integer; +begin + with current[voice] do + begin + inc(slur_level); if slur_level>12 then Error3(voice,'Too many open slurs'); + no_slur_melisma[slur_level] := startsWith(note,'((') or startsWith(note,'{{'); + if no_slur_melisma[slur_level] then predelete(note,1); + if slurLabel(voice,note)='0' then delete1(note,2) else + if slurLabel(voice,note)=' ' then labelSlur(voice,note); + posblind:=pos1('~',note); if posblind>0 then + if hideBlindSlurs then note:='' else delete1(note,posblind); + slurnext := true; + end; +end; + +procedure endSlur(voice: integer; var note: string); + var poscontinue, posblind: integer; + contslur: string; +begin with current[voice] do + begin contslur:=''; + if slur_level<1 then Error3(voice,'Ending a slur that was never started'); + if note[1]=')' then poscontinue:=pos1('(',note) + else if note[1]='}' then poscontinue:=pos1('{',note); + if poscontinue=0 then dec(slur_level) else + begin dec(poscontinue); contslur:=note; predelete(contslur,poscontinue); + shorten(note,poscontinue); + end; + if slur_level=0 then setUnslurred(voice); + if slurLabel(voice,note)='0' then delete1(note,2) else + if slurLabel(voice,note)=' ' then labelSlur(voice,note); + if slurLabel(voice,contslur)='0' then delete1(contslur,2) else + if slurLabel(voice,contslur)=' ' then labelSlur(voice,contslur); + if poscontinue>0 then + begin if note[1]='}' then note:=note+'t'; note[1]:='s'; + if contslur[1]='{' then contslur:=contslur+'t'; contslur[1]:='s'; + end; + posblind:=pos1('~',note); if posblind>0 then + if hideBlindSlurs then note:='' else delete1(note,posblind); + if (note<>'') and (contslur<>'') then note := note + ' ' + contslur; + end; +end; + +{ This is the routine called by prepmx.pas for every normal and chordal +note, immediately after checkOctave. It does two things: adjusts pitch +of notes following a C: chord to what it would have been without that +chord, and checks for pitch overruns. } +procedure renewPitch (voice: integer; var note: string); + var pstat: integer; +begin with current[voice] do + begin + pstat:=newPitch (voice, note, chord_pitch, chord_lastnote); + pitch := newPitch (voice, note, pitch, lastnote); + if pitch<>pstat then repitch(note,pitch-pstat); + checkRange(voice,range_name[pitch]); + if (pitch<lowest_pitch) and checkPitch then + begin write('Pitch of note ',note,' following ',lastnote,' reported as ',pitch); + error3(voice,'Pitch too low') + end; + if (pitch>highest_pitch) and checkPitch then + begin write('Pitch of note ',note,' following ',lastnote,' reported as ',pitch); + error3(voice,'Pitch too high') + end; + lastnote:=note[1]; + end; +end; + +function chordPitch(voice: integer): integer; +begin chordPitch:=current[voice].chord_pitch end; + +procedure renewChordPitch (voice: integer; note: string); +begin with current[voice] do + begin chord_pitch:=newPitch(voice,note,chord_pitch,chord_lastnote); + if chord_pitch<lowest_pitch then error3(voice,'Pitch in chord too low'); + if chord_pitch>highest_pitch then error3(voice,'Pitch in chord too high'); + chord_lastnote:=note[1]; + end +end; + +procedure initStatus; + var voice: integer; +begin for voice:=1 to nvoices do with current[voice] do + begin duration:=default_duration; + octave_adjust:=0; slur_level:=0; beam_level:=0; + beamed:=false; beamnext:=false; + slurred:=false; slurnext:=false; after_slur:=0; + octave:=initOctave(voiceStave(voice)); slurID:='S'; tieID:='T'; + lastnote:='f'; pitch:=7*(ord(octave)-ord('0'))-3; + chord_tie_label:=''; + saveStatus(voice); + end; +end; + +end. |