program kan2nul; uses SysUtils, Algemeen, MidiDoos, TextMidi; type strings = array[0..3] of string; var Bron,Doel : string; Octaves : integer; ITF : TextFile; alfabet : set of char; noten : verzameling; MF : Midi; procedure Some_Help; begin Writeln('KAN2NUL'); Writeln; Writeln('Converts PianoRoll / Klavar Ascii Notation to MidiFile type 0'); Writeln; Writeln('Syntax: [program] [ITF] [OMF] [OCT]'); Writeln; Writeln('ITF = name of Input TextFile'); Writeln('OMF = name of Output MidiFile'); Writeln('OCT = number of Octaves (optional)'); Writeln('Default number of Octaves is five'); Writeln; Writeln('Inverse of NUL2KAN; for the purpose of composing Midi Music'); end; procedure Read_Parameters(var OK : boolean); var woord : string; tel : integer; begin OK := true; tel := ParamCount; if (tel < 2) or (tel > 3) then begin Some_Help; OK := false; Exit; end; Bron := ParamStr(1); Doel := ParamStr(2); Octaves := 5; if tel = 3 then begin woord := ParamStr(3); Octaves := getnum(woord); OK := (0 < Octaves) and (Octaves < 12); if not OK then begin Some_Help; Exit; end; end; if not FileExists(Bron) then begin Writeln(Bron + ': does Not exist'); OK := false; end; AssignFile(ITF,Bron); end; procedure zang(regel : string; var punt : integer); var B,Z : string; L : integer; begin B := trim(regel); L := Pos('|',B); Z := ''; if Length(B) > L then begin Z := trim(Copy(B,L+1,Length(B)-L)); if Z[1] = '*' then Z := ''; { comment } end; if Length(Z) > 0 then begin MF.Put_Any_Event(Kreet(5,Z),punt); MF.Put_Delta_Time(0,punt); end; end; function PolyText(regel : string) : boolean; var B,Z : string; L : integer; begin B := trim(regel); L := Pos('|',B); Z := ''; if Length(B) > L then Z := trim(Copy(B,L+1,Length(B)-L)); L := 0; if Length(Z) > 0 then L := Pos('=',B); PolyText := (L > 0); end; procedure zangers(regel : string; var punt : integer); var B,tekst : string; P,k,L,M : integer; partij,i : byte; W : lijst; begin B := trim(regel); P := Pos('|',B); if P = 0 then Exit; B := Copy(B,P+1,Length(B)-P); B := trim(B); P := Pos('=',B); if P = 0 then Exit; L := Length(B); SetLength(W,0); if L > 0 then W := Woorden(B); M := Length(W); if M > 4 then Exit; for k := 0 to M-1 do begin partij := hex2half(W[k][1]); L := Length(W[k]); tekst := Copy(W[k],3,L-2); for i := 0 to 3 do begin if (partij and 1) = 1 then begin MF.Put_Any_Event(Kreet($10+i,tekst),punt); MF.Put_Delta_Time(0,punt); end; partij := partij shr 1; end; end; end; function is_balk(regel : string) : boolean; const zwart : set of byte = [1,3,6,8,10]; var OK : boolean; L,k,g : integer; begin L := 5 + 1 + Octaves*12; OK := Length(regel) > L; g := 0; if OK then for k := 1 to 5 do begin if regel[k] = ' ' then Continue; g := k ; Break; end; if OK then for k := g to 5 do begin if not (regel[k] in ['0'..'9']) then OK := false; end; OK := OK and (regel[6] = ' '); if OK then for k := 7 to L do begin if not (regel[k] in [':',' ','0'..'9','A'..'F']) then OK := false; end; if OK then for k := 1 to L-6 do begin if (regel[k+6] = ' ') and (((k-1) mod 12) in zwart) then OK := false; if (regel[k+6] = ':') and not (((k-1) mod 12) in zwart) then OK := false; end; is_balk := OK; end; function Estimate(regel : string): integer; var E : integer; function bits(c : char) : integer; const hex : string = '0123456789ABCDEF'; poly : array[1..16] of integer = ( 0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4 ); { 0 1 2 3 4 5 6 7 8 9 A B C D E F } begin bits := poly[Pos(c,hex)]; end; function klavar : integer; var E,M,P,L,tel,k : integer; begin M := Length(trim(Copy(regel,1,5))); E := (M+1) div 2; P := Pos('|',regel); L := P-1; if P = 0 then L := Length(regel); tel := 0; for k := 7 to L do if regel[k] in ['1'..'9','A'..'F'] then tel := tel + bits(regel[k]); E := E + 2*4*tel; if Length(regel) > P then E := E + (Length(regel)-P+3)*4; klavar := E; end; begin E := 3+1; case regel[1] of 'P' : E := 2+1; 'M' : E := Length(regel)+1; 'H' : E := items(regel) +2; 'T' : E := 8; 'F' : E := 14; ' ','0'..'9' : E := klavar; end; Estimate := E; end; function notenbalk(regel : string) : verzameling; var B : string; k,L,P,m : integer; een,twee : byte; V : verzameling; begin Schoonmaken(V); B := regel; P := Pos('|',B); L := P-1; if P = 0 then L := Length(B); B := Copy(B,7,L-6); L := Length(B); for k := 1 to L do begin if not is_hex(B[k]) then Continue; twee := k-1 + 36; een := hex2half(B[k]); for m := 0 to 3 do begin if (een and 1) = 1 then V[m] := V[m] + [ twee ]; een := (een shr 1); end; end; notenbalk := V; end; procedure PianoRol(regel : string; var noten : verzameling; var punt : integer); var huidig,aan,uit : verzameling; k,L,ch,p : integer; riedel,buffer : bytes; begin Schoonmaken(huidig); huidig := notenbalk(regel); SetLength(riedel,0); SetLength(buffer,3); p := punt; aan := Verschil(huidig,noten); if not Leeg(aan) then for ch := 0 to 3 do begin riedel := Akkoord(aan,ch); L := Length(riedel); if L = 0 then Continue; buffer[0] := $90 or ch; buffer[2] := 120; for k := 0 to L-1 do begin buffer[1] := riedel[k]; MF.Put_Any_Event(buffer,p); MF.Put_Delta_Time(0,p); end; end; uit := Verschil(noten,huidig); if not Leeg(uit) then for ch := 3 downto 0 do begin riedel := Akkoord(uit,ch); L := Length(riedel); if L = 0 then Continue; buffer[0] := $90 or ch; buffer[2] := 0; for k := L-1 downto 0 do begin buffer[1] := riedel[k]; MF.Put_Any_Event(buffer,p); MF.Put_Delta_Time(0,p); end; end; if p = punt then begin MF.Put_Dummy_Event(p); MF.Put_Delta_Time(0,p); end; noten := huidig; punt := p; end; procedure maak_alfabet; const ABC : string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; { 12345678901234567890123456 } var i : integer; begin alfabet := []; for i := 1 to 26 do alfabet := alfabet + [ ABC[i] ]; end; procedure Doormeten(var OK : boolean; var veel : integer); var regel : string; tel : integer; soort,tikken : integer; begin OK := true; maak_alfabet; Reset(ITF); tel := 1; Readln(ITF,regel); MidiFile_Header(regel,OK,soort,tikken); OK := OK and (soort = 0); veel := Estimate(regel); Readln(ITF,regel); if OK then while not EoF(ITF) do begin Readln(ITF,regel); veel := veel + Estimate(regel); tel := tel + 1; if regel[1] = '*'then Continue; if regel[1] in alfabet then Continue; if is_balk(regel) then Continue; OK := false; if not OK then begin Writeln('Error in KAN file at line ',tel); Writeln('Input = ',regel); Break; end; end; if not OK then CloseFile(ITF); end; procedure Doorwerken; var OK : boolean; regel : string; soort,tikken : integer; punt,delta : integer; riedel : bytes; begin maak_alfabet; Reset(ITF); Readln(ITF,regel); MidiFile_Header(regel,OK,soort,tikken); Readln(ITF,regel); MF.Put_Midi_Header(soort,1,tikken); punt := 14 + 8; SetLength(riedel,0); Schoonmaken(noten); MF.Put_Delta_Time(0,punt); while not EoF(ITF) do begin Readln(ITF,regel); if regel[1] = '*'then Continue; if regel[1] in alfabet then begin riedel := Verwerk_Event(regel); MF.Put_Any_Event(riedel,punt); MF.Put_Delta_Time(0,punt); end; if is_balk(regel) then begin if PolyText(regel) then zangers(regel,punt) else zang(regel,punt); PianoRol(regel,noten,punt); punt := punt - 1; delta := getnum(Copy(regel,1,5)); MF.Put_Delta_Time(delta,punt); end; end; punt := punt - 1; MF.Put_Track_Header(punt-14-8,14); SetLength(MF.invoer,punt); end; procedure HoofdRoutine; { Beginning of Main program } var OK : boolean; veel : integer; begin Read_Parameters(OK); if not OK then Exit; Doormeten(OK,veel); if not OK then Exit; MF := Midi.Create; SetLength(MF.invoer,veel); Doorwerken; CloseFile(ITF); MF.Write_MidiFile(Doel); end; BEGIN HoofdRoutine; END.