Unit MidiDoos;
{
  http://www.sonicspot.com/guide/midifiles.html
}
INTERFACE

Uses SysUtils, Algemeen;

type
  Midi = class(TObject)
  private
    status : byte;
    procedure Check_MidiFile_Header(var OK : boolean);
    procedure Check_Track_Content(reeds,aantal : integer; var OK : boolean);
    procedure Skip_Midi_Event(var Reeds: integer);
    procedure Skip_System_Event(var Reeds: integer);
    procedure Skip_Meta_Event(var Reeds: integer);
    procedure Copy_Midi_Event(var Reeds: integer; var riedel : bytes);
    procedure Copy_System_Event(var Reeds: integer; var riedel : bytes);
    procedure Copy_Meta_Event(var Reeds: integer; var riedel : bytes);
    procedure Copy_Real_Time_Message(var Reeds: integer; var riedel : bytes);
    procedure Data_System_Event(var Reeds: integer; var riedel : bytes);
    procedure Data_Meta_Event(var Reeds: integer; var riedel : bytes);
    function too_far(Reeds : integer) : boolean;
  public
    invoer : bytes;

    procedure Skip_Delta_Time(var Reeds: integer);
    function Get_Delta_Time(var Reeds : integer) : integer;
    procedure Skip_Any_Event(var Reeds: integer);
    procedure Copy_Any_Event(var Reeds: integer; var riedel : bytes);
    procedure Data_Any_Event(var Reeds: integer; var riedel : bytes);

    procedure Read_MidiFile(bron : string);
    procedure Write_MidiFile(doel : string);
    procedure Check_Structure(var OK : boolean);
    procedure Check_Track_Header(var reeds,aantal : integer; var OK : boolean);

    function Type01 : integer;
    procedure set_Type01(nr : integer);
    function Tracks : integer;
    procedure set_Tracks(nr : integer);
    function Ticks : integer;
    procedure set_Ticks(nr : integer);

    procedure Put_Midi_Header(soort,sporen,tikken : integer);
    procedure Put_Track_Header(Hoeveel,punt : integer);
    procedure Put_Delta_Time(del : integer; var punt : integer);
    procedure Put_Any_Event(riedel : bytes; var punt : integer);
    procedure Put_Dummy_Event(var punt : integer);
  end;

IMPLEMENTATION

procedure Midi.Read_MidiFile(bron : string);
{
  Read MidiFile into Memory
}
var
  deze : file;
  veel : integer;
begin
  SetLength(invoer,0);
  if not FileExists(bron) then Exit;
  AssignFile(deze,bron);
  Reset(deze,1);
  veel := FileSize(deze);
  if veel = 0 then
  begin
    Close(deze); Exit;
  end;
  SetLength(invoer,veel);
  BlockRead(deze,invoer[0],veel);
  Close(deze);
{ Clear Running Status }
  status := 0;
end;

procedure Midi.Write_MidiFile(doel : string);
{
  Write MidiFile from Memory
}
var
  deze : file;
begin
  if Length(invoer) = 0 then Exit;
  AssignFile(deze,doel);
  Rewrite(deze, 1);
  BlockWrite(deze, invoer[0], Length(invoer));
  Close(deze);
end;

function Midi.Type01 : integer;
var
  nr : integer;
begin
  nr := integer(invoer[8]);
  type01 := (nr shl 8) + integer(invoer[9]);
end;
{
  Type 0 files hold a single track of sequence data
  Type 1 files hold chunks of data representing parallel tracks
  Type 2 files handle sets of independant sequences by treating each track
  chunk as a separate sequence: [header chunk] [seq 1] [seq 2] [seq 3]
}
procedure Midi.set_Type01(nr : integer);
begin
  invoer[8] := (nr shr 8);
  invoer[9] := (nr and $FF);
end;

function Midi.Tracks : integer;
var
  nr : integer;
begin
  nr := integer(invoer[10]);
  tracks := (nr shl 8) + integer(invoer[11]);
end;
{
  Number of Tracks
}
procedure Midi.set_Tracks(nr : integer);
begin
  invoer[10] := (nr shr 8);
  invoer[11] := (nr and $FF);
end;

function Midi.Ticks : integer;
var
  nr : integer;
begin
  nr := integer(invoer[12]);
  ticks := (nr shl 8) + integer(invoer[13]);
end;
{
  Number of Ticks
}
procedure Midi.set_Ticks(nr : integer);
begin
  invoer[12] := (nr shr 8);
  invoer[13] := (nr and $FF);
end;

procedure Midi.Check_MidiFile_Header(var OK : boolean);
{
  Check Main Header of MidiFile
}
var
  H : string[4];
  k,nr,soort : integer;
begin
  OK := (Length(invoer) > 13);
  if not OK then
  begin
    Writeln('MidiFile <= 14 bytes');
    Exit;
  end;

  H[0] := Char(4);
  for k := 0 to 3 do
    H[k+1] := char(invoer[k]);
  OK := (H = 'MThd');
  if not OK then
  begin
    Writeln(H,' <> "MThd" in MF header');
    Exit;
  end;

  for k := 4 to 6 do
    OK := OK and (integer(invoer[k]) = 0);
  OK := OK and (integer(invoer[7]) = 6);
  if not OK then
  begin
    Writeln('Header chunk size not 6');
    Exit;
  end;

  nr := integer(invoer[8]);
  nr := (nr shl 8) + integer(invoer[9]);
  OK := (nr < 3);
  if not OK then
  begin
    Writeln('Error in header: type MF = ',nr);
    Exit;
  end;
  soort := nr;

  nr := integer(invoer[10]);
  nr := (nr shl 8) + integer(invoer[11]);
  OK := ((soort = 0) and (nr = 1))
     or ((soort > 0) and (nr > 1));
  if not OK then
  begin
    Writeln('Type ',soort,' and # tracks ',nr,' incompatible');
    Exit;
  end;

  nr := integer(invoer[12]);
  nr := (nr shl 8) + integer(invoer[13]);
  OK := ((nr and $8000) = 0);
  if not OK then
  begin
    Writeln('Unsupported (SMPTE) # ticks');
    Exit;
  end;
  OK := (nr > 0);
  if not OK then
  begin
    Writeln('# ticks must be > 0');
    Exit;
  end;
end;

procedure Midi.Check_Track_Header(var reeds,aantal : integer; var OK : boolean);
{
  Check Track Header of MidiFile
}
var
  H : string[4];
  nr : integer;
  k : integer;
begin
  aantal := 0;
  H[0] := Char(4);
  for k := 1 to 4 do
  begin
    H[k] := Char(invoer[reeds]);
    reeds := reeds + 1;
  end;
  OK := (H = 'MTrk');
  if not OK then
  begin
    Writeln(H,' <> "MTrk" in Track header at byte ',reeds-4);
    Exit;
  end;
  nr := 0;
  for k := 5 to 8 do
  begin
    nr := (nr shl 8) + integer(invoer[reeds]);
    reeds := reeds + 1;
  end;
  aantal := nr
end;

procedure Midi.Check_Structure(var OK : boolean);
{
  Check MidiFile Structure
}
var
  t,tot : integer;
  punt,aantal,veel : integer;
begin
  OK := true;
  veel := Length(invoer);
  if veel = 0 then
  begin
    Writeln('No MidiFile Read yet');
    OK := false; Exit;
  end;
  Check_MidiFile_Header(OK);
  if not OK then Exit;
  punt := 14;
  tot := Tracks;
  for t := 0 to tot-1 do
  begin
    Check_Track_Header(punt,aantal,OK);
    if not OK then Break;
    punt := punt + aantal;
    if punt > veel then
    begin
      Writeln('# midi bytes (',punt,') > file size (',veel,')');
      OK := false; Break;
    end;
    Check_Track_Content(punt-aantal,aantal,OK);
    if not OK then Break;
  end;
  if not OK then Exit;
  if punt < veel then
    Writeln('# midi bytes (',punt,') < file size (',veel,')');
end;

procedure Midi.Skip_Delta_Time(var Reeds: integer);
var
  n : byte;
begin
  if too_far(Reeds) then Exit;
  n := invoer[Reeds];
  Reeds := Reeds + 1;
{ Variable length quantity: }
  while n > 127 do
  begin
    n := invoer[Reeds];
    Reeds := Reeds + 1;
  end;
end;
{
http://253.ccarh.org/handout/vlv/

In theory, you could have a very long VLV number which was quite large;
however, in the standard MIDI file specification, the maximum length of
a VLV value is 5 bytes, and the number it represents can not be larger
than 4 bytes. 
}
procedure Midi.Skip_Midi_Event(var Reeds: integer);
var
  let : byte;
  C_or_D : boolean;
begin
  let := invoer[Reeds];
{ Running Status }
  if let > 127 then
  begin
    status := let;
    Reeds := Reeds + 1;
  end;
  Reeds := Reeds + 1;
  C_or_D := ((status shr 4) = 12)
         or ((status shr 4) = 13);
  if not C_or_D then Reeds := Reeds + 1;
end;

function Midi.Get_Delta_Time(var Reeds : integer) : integer;
var
  n : byte;
  d : integer;
begin
  Get_Delta_Time := 0;
  if too_far(Reeds) then Exit;
  n := invoer[Reeds];
  Reeds := Reeds + 1;
  d := integer(n and $7F);
{ Variable length quantity: }
  while n > 127 do
  begin
    n := invoer[Reeds];
    d := (d shl 7) or integer(n and $7F);
    Reeds := Reeds + 1;
  end;
  Get_Delta_Time := d;
end;

procedure Midi.Skip_Meta_Event(var Reeds : integer);
var
  tel : integer;
begin
  Reeds := Reeds + 2;
  tel := Get_Delta_Time(Reeds);
  Reeds := Reeds + tel;
{ Clear Running Status? No. }
{ status := 0; }
end;
{
  http://www.audio-forums.com/midi-file-parsing-problem-t54994.html
  http://www.protodesign-inc.com/source/midi.htm

  NOTE: We do not clear running status across SysEx or
  meta events even though the spec says to because there are
  actually files out there which contain that sequence of data.
}
procedure Midi.Skip_System_Event(var Reeds : integer);
var
  tel : integer;
begin
  Reeds := Reeds + 1;
  tel := Get_Delta_Time(Reeds);
  Reeds := Reeds + tel;
{ Clear Running Status? No. }
{ status := 0; }
end;

procedure Midi.Skip_Any_Event(var Reeds: integer);
var
  let : byte;
begin
  if too_far(Reeds) then Exit;
  let := invoer[Reeds];
  if (let <= $7F) and (status > 0)
    then Skip_Midi_Event(Reeds);
  if (let <= $7F) and (status = 0)
    then Reeds := Reeds + 1;
  if ($80 <= let) and (let <= $EF)
    then Skip_Midi_Event(Reeds);
  if ($F0 <= let) and (let <= $F7)
    then Skip_System_Event(Reeds);
  if ($F8 <= let) and (let <= $FE)
    then Reeds := Reeds + 1;
  if (let = $FF)
    then Skip_Meta_Event(Reeds);
end;

procedure Midi.Copy_Midi_Event(var Reeds: integer; var riedel : bytes);
var
  let : byte;
  C_or_D : boolean;
begin
  let := invoer[Reeds];
{ Running Status }
  if let > 127 then
  begin
    status := let;
    Reeds := Reeds + 1;
  end;
  C_or_D := ((status shr 4) = 12)
         or ((status shr 4) = 13);
  if not C_or_D then SetLength(riedel,3)
                else SetLength(riedel,2);
  riedel[0] := status;
  riedel[1] := invoer[Reeds];
  Reeds := Reeds + 1;
  if not C_or_D then
  begin
    riedel[2] := invoer[Reeds];
    Reeds := Reeds + 1;
  end;
end;

procedure Midi.Copy_System_Event(var Reeds: integer; var riedel : bytes);
var
  tel : integer;
  Start,Eind,k : integer;
begin
  Start := Reeds;
  Reeds := Reeds + 1;
  tel := Get_Delta_Time(Reeds);
  Reeds := Reeds + tel;
  Eind := Reeds;
  SetLength(riedel,Eind-Start);
  for k := Start to Eind-1 do
    riedel[k-Start] := invoer[k];
end;

procedure Midi.Data_System_Event(var Reeds: integer; var riedel : bytes);
var
  nul : byte;
  tel : integer;
  Start,k : integer;
begin
  nul := invoer[Reeds];
  Reeds := Reeds + 1;
  tel := Get_Delta_Time(Reeds);
  Start := Reeds;
  Reeds := Reeds + tel;
  SetLength(riedel,tel+1);
  riedel[0] := nul;
  for k := 0 to tel-1 do
    riedel[k+1] := invoer[Start+k];
end;

procedure Midi.Copy_Meta_Event(var Reeds: integer; var riedel : bytes);
var
  tel : integer;
  Start,Eind,k : integer;
begin
  Start := Reeds;
  Reeds := Reeds + 2;
  tel := Get_Delta_Time(Reeds);
  Reeds := Reeds + tel;
  Eind := Reeds;
  SetLength(riedel,Eind-Start);
  for k := Start to Eind-1 do
    riedel[k-Start] := invoer[k];
end;

procedure Midi.Data_Meta_Event(var Reeds: integer; var riedel : bytes);
var
  nul,een : byte;
  tel : integer;
  Start,k : integer;
begin
  nul := invoer[Reeds];
  Reeds := Reeds + 1;
  een := invoer[Reeds];
  Reeds := Reeds + 1;
  tel := Get_Delta_Time(Reeds);
  Start := Reeds;
  Reeds := Reeds + tel;
  SetLength(riedel,tel+2);
  riedel[0] := nul;
  riedel[1] := een;
  for k := 0 to tel-1 do
    riedel[k+2] := invoer[Start+k];
end;

procedure Midi.Copy_Real_Time_Message(var Reeds: integer; var riedel : bytes);
begin
  SetLength(riedel,1);
  riedel[0] := invoer[Reeds];
  Reeds := Reeds + 1;
end;

procedure Midi.Copy_Any_Event(var Reeds: integer; var riedel : bytes);
var
  let : byte;
begin
  SetLength(riedel,0);
  if too_far(Reeds) then Exit;
  let := invoer[Reeds];
  if (let <= $7F) and (status > 0)
    then Copy_Midi_Event(Reeds,riedel);
  if (let <= $7F) and (status = 0)
    then Reeds := Reeds + 1;
  if ($80 <= let) and (let <= $EF)
    then Copy_Midi_Event(Reeds,riedel);
  if ($F0 <= let) and (let <= $F7)
    then Copy_System_Event(Reeds,riedel);
  if ($F8 <= let) and (let <= $FE)
    then Copy_Real_Time_Message(Reeds,riedel);
  if (let = $FF)
    then Copy_Meta_Event(Reeds,riedel);
end;

procedure Midi.Data_Any_Event(var Reeds: integer; var riedel : bytes);
var
  let : byte;
begin
  SetLength(riedel,0);
  if too_far(Reeds) then Exit;
  let := invoer[Reeds];
  if (let <= $7F) and (status > 0)
    then Copy_Midi_Event(Reeds,riedel);
  if (let <= $7F) and (status = 0)
    then Reeds := Reeds + 1;
  if ($80 <= let) and (let <= $EF)
    then Copy_Midi_Event(Reeds,riedel);
  if ($F0 <= let) and (let <= $F7)
    then Data_System_Event(Reeds,riedel);
  if ($F8 <= let) and (let <= $FE)
    then Copy_Real_Time_Message(Reeds,riedel);
  if (let = $FF)
    then Data_Meta_Event(Reeds,riedel);
end;

procedure Midi.Check_Track_Content(reeds,aantal : integer; var OK : boolean);
var
  p : integer;
begin
  OK := true;
  p := reeds;
  while p < reeds+aantal do
  begin
    Skip_Delta_Time(p);
    if p > (reeds+aantal) then
    begin
      Writeln('Time > track size at : ',p);
      OK := false; Break;
    end;
    Skip_Any_Event(p);
    if p > (reeds+aantal) then
    begin
      Writeln('Event > track size at : ',p);
      OK := false; Break;
    end;
  end;
  OK := (p = reeds+aantal);
end;

procedure Midi.Put_Delta_Time(del : integer; var punt : integer);
var
  d,tel,k : integer;
begin
  d := del;
  tel := ByteCount(d);
  punt := punt + tel;
  invoer[punt-1] := byte(d and $0000007F);
  if tel = 1 then Exit;
  for k := 1 to tel-1 do
  begin
    d := d shr 7;
    invoer[punt-k-1] := byte(d and $0000007F) or $80;
  end;
end;

procedure Midi.Put_Midi_Header(soort,sporen,tikken : integer);
var
  i : integer;
begin
  invoer[0] := byte('M');
  invoer[1] := byte('T');
  invoer[2] := byte('h');
  invoer[3] := byte('d');
  for i := 4 to 13 do invoer[i] := 0;
  invoer[7] := 6;
  invoer[9] := soort;
  invoer[10] := byte(sporen shr 8);
  invoer[11] := byte(sporen and $00FF);
  invoer[12] := byte(tikken shr 8);
  invoer[13] := byte(tikken and $00FF);
end;

procedure Midi.Put_Track_Header(Hoeveel,punt : integer);
var
  nr : integer;
  H : string[4];
  k : byte;
begin
  H := 'MTrk';
  for k := 1 to 4 do
  begin
    invoer[punt+k-1] := byte(H[k]);
  end;
  punt := punt + 8;
  nr := Hoeveel;
  for k := 0 to 3 do
  begin
    invoer[punt-k-1] := byte(nr and $000000FF);
    nr := nr shr 8;
  end;
end;

procedure Midi.Put_Any_Event(riedel : bytes; var punt : integer);
var
  k,L,p : integer;
  geval : boolean;
begin
  L := Length(riedel);
  p := punt;

  geval := (riedel[0] > $7F)
       and (riedel[0] < $F0)
       and (status = riedel[0]);
  if geval then
  begin
    for k := 1 to L-1 do
    begin
      invoer[p] := riedel[k]; 
      p := p + 1;
    end;
  end;

  geval := (riedel[0] > $7F)
       and (riedel[0] < $F0)
       and not (status = riedel[0]);
  geval := geval or (riedel[0] > $EF);
  if geval then
  begin
    for k := 0 to L-1 do
    begin
      invoer[p] := riedel[k]; 
      p := p + 1;
    end;
    status := riedel[0];
  end;

  geval := (riedel[0] < $80);
  if geval then
  begin
    for k := 0 to L-1 do
    begin
      invoer[p] := riedel[k]; 
      p := p + 1;
    end;
  end;

  punt := p;
end;

function Midi.too_far(Reeds : integer) : boolean;
var
  OK : boolean;
begin
  OK := true;
  if Reeds > Length(invoer)-1 then
  begin
    Writeln('MidiFile size exceeded');
    OK := false;
  end;
  too_far := not OK;
end;

procedure Midi.Put_Dummy_Event(var punt : integer);
begin
  invoer[punt] := $FF; punt := punt + 1;
  invoer[punt] := $0F; punt := punt + 1;
  invoer[punt] := $00; punt := punt + 1;
end;

END.