Unit TextMidi;

INTERFACE

Uses Algemeen;

procedure MidiFile_Header(regel : string; 
                          var OK : boolean; var soort,tikken : integer);
function Event_At(regel : string) : integer;
function Verwerk_Event(regel : string) : bytes;
function Kreet(let : byte; greep : string) : bytes;
function Parse_Numbers(regel : string) : integers;

IMPLEMENTATION

function Parse_Numbers(regel : string) : integers;
var
  b : byte;
  r,i,ng : integer;
  sep,hex,haak,quote,base_10,base_16,min : boolean;
  getal : integers;
begin
  ng := -1;
  sep := true ; hex := false ; min := false ;
  haak := false ; quote := false ;
  r := Length(regel);
  SetLength(getal,r);
{ Main loop }
  for i := 1 to r do
  begin
  { Skip comments: }
    if regel[i] = '"' then quote := not quote;
    if regel[i] = '(' then haak := true;
    if regel[i] = ')' then haak := false;
    if (haak or quote) then Continue;
  { Possibly hexadecimal: }
    if regel[i] = '$' then
    begin
      sep := true ; hex := true ; min := false ; Continue;
    end;
    if regel[i] = '-' then
    begin
      sep := true ; hex := false ; min := true ; Continue;
    end;
  { No number information: }
    b := byte(regel[i]);
    base_10 := ((b >= 48) and (b <= 57));
    base_16 := is_hex(regel[i]);
    if not (base_16 and hex) and not base_10 then
    begin
      if min then getal[ng] := - getal[ng];
      sep := true ; hex := false ; min := false ; Continue ;
    end;
  { Separate: }
    if sep then
    begin
      sep := false ; ng := ng + 1; getal[ng] := 0;
    end;
  { Numbers: }
    if base_10 and (not hex) then
    begin
      getal[ng] := getal[ng]*10 + byte(regel[i]) - 48;
      Continue;
    end;
    if base_16 and hex then
    begin
      getal[ng] := getal[ng]*16 + hex2half(regel[i]);
      Continue;
    end;
  end;
  if min then getal[ng] := - getal[ng];
  SetLength(getal,ng+1);
  Parse_Numbers := getal;
end;

procedure MidiFile_Header(regel : string; 
                          var OK : boolean; var soort,tikken : integer);
var
  getal : integers;
  ng : integer;
begin
  SetLength(getal,0);
  if regel[1] <> 'F' then begin
    Writeln('NO MidiFile header');
    OK := false; Exit;
  end;
  getal := Parse_Numbers(regel);
  ng := Length(getal);
  if ng <> 2 then begin
    Writeln('Wrong header: NO #type #ticks');
    OK := false; Exit;
  end;
  soort := byte(getal[0]);
  if (soort < 0) or (soort > 2) then
  begin
    Writeln('Wrong #type of MidiFile');
    OK := false; Exit;
  end;
  tikken := word(getal[1]);
  if (tikken < 1) then
  begin
    Writeln('Wrong #ticks in header');
    OK := false; Exit;
  end;
end;

function Event_At(regel : string) : integer;
var
  b : byte;
  r,i,E : integer;
begin
  E := 0;
  r := Length(regel);
  for i := 1 to r do
  begin
    b := byte(regel[i]);
    if (b >= 65) and (b <= 90) then
    begin
      E := i; Break;
    end;
  end;
  Event_At := E;
end;

function Verwerk_Note(getal : integers) : bytes;
var
  klad : bytes;
  ng : integer;
begin
  ng := Length(getal);
  SetLength(klad,0);
{ Zero length on error }
  if ng = 3 then
  begin
    SetLength(klad,3);
    klad[0] := $90 or byte(getal[0]);
    klad[1] := byte(getal[1]);
    klad[2] := byte(getal[2]);
  end;
  Verwerk_Note := klad;
end;

function Verwerk_After(getal : integers) : bytes;
var
  st : byte;
  ng : integer;
  klad : bytes;
begin
  st := 0;
  Setlength(klad,0);
  ng := Length(getal);
  if (ng = 2) or (ng = 3) then
  begin
    if ng = 3 then st := $A0 or byte(getal[0]);
    if ng = 2 then st := $D0 or byte(getal[0]);
    SetLength(klad,2);
    klad[0] := st;
    klad[1] := byte(getal[1]);
    if ng = 3 then
    begin
      SetLength(klad,3);
      klad[2] := byte(getal[2]);
    end;
  end;
  Verwerk_After := klad;
end;

function Verwerk_Control(getal : integers) : bytes;
var
  ng : integer;
  st : byte;
  klad : bytes;
begin
  SetLength(klad,0);
  ng := Length(getal);
  if ng = 3 then
  begin
    st := $B0 or byte(getal[0]);
    SetLength(klad,3);
    klad[0] := st;
    klad[1] := byte(getal[1]);
    klad[2] := byte(getal[2]);
  end;
  Verwerk_Control := klad;
end;

function Verwerk_Program(getal : integers) : bytes;
var
  st : byte;
  ng : integer;
  klad : bytes;
begin
  SetLength(klad,0);
  ng := Length(getal);
  if ng = 2 then
  begin
    st := $C0 or byte(getal[0]);
    SetLength(klad,2);
    klad[0] := st;
    klad[1] := byte(getal[1]);
  end;
  Verwerk_Program := klad;
end;

function Verwerk_Bend(getal : integers) : bytes;
var
  ng : integer;
  L,H,st : byte;
  klad : bytes;
begin
  SetLength(klad,0);
  ng := Length(getal);
  if ng = 2 then
  begin
    st := $E0 or byte(getal[0]);
    getal[1] := getal[1] + 8192;
    H := byte(getal[1] shr 7);
    L := byte(getal[1] and $7F);
    SetLength(klad,3);
    klad[0] := st;
    klad[1] := byte(L);
    klad[2] := byte(H);
  end;
  Verwerk_Bend := klad;
end;

function Verwerk_Hex(getal : integers) : bytes;
var
  i,ng : integer;
  klad : bytes;
begin
  ng := Length(getal);
  SetLength(klad,ng+2);
  klad[0] := $F7;
  klad[1] := ng;
  for i := 0 to ng-1 do
    klad[i+2] := byte(getal[i]);
  Verwerk_Hex := klad;
end;

function Verwerk_Tekst(getal : integers; regel : string) : bytes;
var
  k,k1,k2 : integer;
  klad : bytes;
begin
  k1 := 1; k2 := 0;
  if Pos('"',regel) > 0 then
  begin
    k := 1;
    while regel[k] <> '"' do k := k + 1;
    k := k + 1;
    k1 := k;
    while regel[k] <> '"' do k := k + 1;
    k := k - 1;
    k2 := k;
  end;
  SetLength(klad,k2-k1+4);
  klad[0] := $FF;
  klad[1] := byte(getal[0]);
  klad[2] := k2-k1+1;
  if (k1 > 0) and (k2 > 0) then
    for k := k1 to k2 do
      klad[k-k1+3] := byte(regel[k]);
  Verwerk_Tekst := klad;
end;

function Verwerk_Lyriek(let : byte; regel : string) : bytes;
var
  L : integer;
  klad : bytes;
  W : lijst;
begin
  W := woorden(regel);
  SetLength(klad,3);
  klad[0] := $FF;
  klad[1] := let;
  klad[2] := $00;
  L := Length(W);
  if L = 3 then
    klad := Kreet(let,W[2]);
  Verwerk_Lyriek := klad;
end;

function Verwerk_SeqNum(getal : integers) : bytes;
var
  H, L : byte;
  klad : bytes;
begin
  SetLength(klad,5);
  klad[0] := $FF;
  klad[1] := byte(getal[0]);
  klad[2] := 2;
  H := byte(getal[1] shr 8);
  L := byte(getal[1] and $FF);
  klad[3] := H; klad[4] := L;
  Verwerk_SeqNum := klad;
end;

function Verwerk_Tempo(getal : integers) : bytes;
var
  b : byte;
  k : integer;
  L : integer;
  klad : bytes;
begin
  SetLength(klad,6);
  klad[0] := $FF;
  klad[1] := byte(getal[0]);
  klad[2] := 3;
  L := getal[1];
  for k := 0 to 2 do
  begin
    b := byte(L and $FF);
    klad[5-k] := b;
    L := L shr 8;
  end;
  Verwerk_Tempo := klad;
end;

function Verwerk_SMPTE(getal : integers) : bytes;
var
  k : integer;
  klad : bytes;
begin
  SetLength(klad,8);
  klad[0] := $FF;
  klad[1] := byte(getal[0]);
  klad[2] := 5;
  for k := 1 to 5 do
  begin
    klad[k+2] := byte(getal[k]);
  end;
  Verwerk_SMPTE := klad;
end;

function Verwerk_TimeSig(getal : integers) : bytes;
var
  h : integer;
  b : byte;
  klad : bytes;
begin
  SetLength(klad,7);
  klad[0] := $FF;
  klad[1] := byte(getal[0]);
  klad[2] := 4;
  klad[3] := byte(getal[1]);
  h := getal[2];
  b := 0;
  while h <> 0 do
  begin
    b := b + 1;
    h := h shr 1;
  end;
  klad[4] := byte(b-1);
  klad[5] := byte(getal[3]);
  klad[6] := byte(getal[4]);
  Verwerk_TimeSig := klad;
end;

function Verwerk_KeySig(getal : integers) : bytes;
var
  klad : bytes;
begin
  SetLength(klad,0);
  if (getal[1] < -7) or (getal[1] > +7) then Exit;
  SetLength(klad,5);
  klad[0] := $FF;
  klad[1] := byte(getal[0]);
  klad[2] := 2;
{ Two's complement: }
  if getal[1] < 0 then getal[1] := $FF+getal[1]+1;
  klad[3] := byte(getal[1]);
  klad[4] := byte(getal[2]);
  Verwerk_KeySig := klad;
end;

function Verwerk_MidiPort(getal : integers) : bytes;
var
  klad : bytes;
begin
  SetLength(klad,4);
  klad[0] := $FF;
  klad[1] := byte(getal[0]);
  klad[2] := 1;
  klad[3] := byte(getal[1]);
  Verwerk_MidiPort := klad;
end;

function Verwerk_EndTrack : bytes;
var
  klad : bytes;
begin
  SetLength(klad,3);
  klad[0] := $FF;
  klad[1] := $2F;
  klad[2] := $00;
  Verwerk_EndTrack := klad;
end;

function Verwerk_Meta(getal : integers; regel : string) : bytes;
var
  i,ng : integer;
  klad : bytes;
  klaar : boolean;
  let : byte;
begin
  ng := Length(getal);
  let := getal[0];
  Case let of
       $00 : klad := Verwerk_SeqNum(getal);
  $01..$04 : klad := Verwerk_Tekst(getal,regel);
       $05 : klad := Verwerk_Lyriek(let,regel);
  $06..$0F : klad := Verwerk_Tekst(getal,regel);
  $10..$1F : klad := Verwerk_Lyriek(let,regel);
       $21 : klad := Verwerk_MidiPort(getal);
       $2F : klad := Verwerk_EndTrack;
       $51 : klad := Verwerk_Tempo(getal);
       $54 : klad := Verwerk_SMPTE(getal);
       $58 : klad := Verwerk_TimeSig(getal);
       $59 : klad := Verwerk_KeySig(getal);
  end;
  klaar := (let = $00)
        or ((let > $00) and (let < $10))
        or ((let > $0F) and (let < $20))
        or (let = $21)
        or (let = $2F)
        or (let = $51)
        or (let = $54)
        or (let = $58)
        or (let = $59);
  if not klaar then
  begin
  { Unknown Meta Event: }
    SetLength(klad,ng+2);
    klad[0] := $FF;
    klad[1] := byte(let);
    klad[2] := ng-1;
    if ng > 1 then
    for i := 1 to ng-1 do
      klad[i+2] := byte(getal[i]);
  end;
  Verwerk_Meta := klad;
end;

function Verwerk_Event(regel : string) : bytes;
var
  werk : bytes;
  getal : integers;
  item : char;
begin
  SetLength(werk,0);
  getal := Parse_Numbers(regel);
  item := regel[1];
  Case item of
    'N' : werk := Verwerk_Note(getal);
    'A' : werk := Verwerk_After(getal);
    'C' : werk := Verwerk_Control(getal);
    'P' : werk := Verwerk_Program(getal);
    'B' : werk := Verwerk_Bend(getal);
    'H' : werk := Verwerk_Hex(getal);
    'M' : werk := Verwerk_Meta(getal,regel);
  end;
  if item in ['O','V'] then
  begin
    Setlength(werk,1);
    werk[0] := byte(getal[0]);
  end;
  Verwerk_Event := werk;
end;

function Kreet(let : byte; greep : string) : bytes;
var
  stuk,CRLF : string;
  tel,L,k : integer;
  buffer : bytes;
begin
  stuk := char($FF) + char(let);
  CRLF := char(13) + char(10);
  greep := vervang(greep,'/',CRLF);
  greep := vervang(greep,'\',CRLF);
  greep := vervang(greep,'_',' ');
  tel := Length(greep); 
  stuk := stuk + char(tel) + greep;
  L := Length(stuk);
  SetLength(buffer,L);
  for k := 1 to L do
    buffer[k-1] := byte(stuk[k]);
  Kreet := buffer;
end;

END.