Westwood ADL v1, v2 and v3 music file reader

ADLRead.dpr

program ADLRead;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Classes;

var
  // ADL index v1 & v2
  Index8: Array[0..120-1] of Byte;
  // ADL index v3
  Index16: Array[0..250-1] of Word;
  // Offsets v1
  ofTrk1: Array[0..150-1] of Word;
  ofIns1: Array[0..150-1] of Word;
  // Offsets v2
  ofTrk2: Array[0..250-1] of Word;
  ofIns2: Array[0..250-1] of Word;
  // Offsets v3
  ofTrk3: Array[0..500-1] of Word;
  ofIns3: Array[0..500-1] of Word;

  F: TFileStream;
  Version: Byte;

function DetectVersion12(): Boolean;
var
  I: Integer;
begin
  Result := False;
  // Read track pointers for v1
  F.ReadBuffer(ofTrk1, SizeOf(ofTrk1));

  // Minimum offset 600 for v1
  for I := 0 to Length(ofTrk1) - 1 do
    if (ofTrk1[I] > 0) and (ofTrk1[I] < 600) then
    begin
      Writeln('Error: Wrong offset detected.');
      Exit; // This file isn't ADL v1 nor v2
    end;

  Result := True;

  for I := 0 to Length(ofTrk1) - 1 do
    if (ofTrk1[I] > 0) and (ofTrk1[I] < 1000) then
      Exit; // This is version 1

  // Minimum offset 1000 for v2
  Version := 2;
end;

function ProcessVersion1(): Boolean;
begin
  // Read instrument pointers
  F.ReadBuffer(ofIns1, SizeOf(ofIns1));
  Result := True;
end;

function ProcessVersion2(): Boolean;
begin
  Result := False;
  if F.Size < 1120 then
  begin
    Writeln('Error: File size is too small.');
    Exit;
  end;
  F.Seek(120, soFromBeginning);
  // Read track pointers
  F.ReadBuffer(ofTrk2, SizeOf(ofTrk2));
  // Read instrument pointers
  F.ReadBuffer(ofIns2, SizeOf(ofIns2));
  Result := True;
end;

function ProcessVersion3(): Boolean;
var
  I: Integer;
begin
  Result := False;
  if F.Size < 2500 then
  begin
    Writeln('Error: File size is too small.');
    Exit;
  end;
  F.Seek(0, soFromBeginning);
  // Read indexes
  F.ReadBuffer(Index16, SizeOf(Index16));
  // Read track pointers
  F.ReadBuffer(ofTrk3, SizeOf(ofTrk3));
  for I := 0 to Length(ofTrk3) - 1 do
    if (ofTrk3[I] > 0) and (ofTrk3[I] < 2000) then
    begin
      Writeln('Error: Wrong offset detected.');
      Exit; // This file isn't ADL v3
    end;
  // Read instrument pointers
  F.ReadBuffer(ofIns3, SizeOf(ofIns3));
  Result := True;
end;

function GetFirstTrack(): Word;
var
  I: Integer;
begin
  Result := $FFFF;
  case Version of
    1:
    begin
      for I := 0 to Length(ofTrk1) - 1 do
        if (ofTrk1[I] >= 600) and (ofTrk1[I] < $FFFF)
        and (ofTrk1[I] < Result) then
          Result := ofTrk1[I];
    end;
    2:
    begin
      for I := 0 to Length(ofTrk2) - 1 do
        if (ofTrk2[I] >= 1000) and (ofTrk2[I] < $FFFF)
        and (ofTrk2[I] < Result) then
          Result := ofTrk2[I];
    end;
    3:
    begin
      for I := 0 to Length(ofTrk3) - 1 do
        if (ofTrk3[I] >= 2000) and (ofTrk3[I] < $FFFF)
        and (ofTrk3[I] < Result) then
          Result := ofTrk3[I];
    end;
  end;
end;

function GetFirstInstr(): Word;
var
  I: Integer;
begin
  Result := $FFFF;
  case Version of
    1:
    begin
      for I := 0 to Length(ofIns1) - 1 do
        if (ofIns1[I] > 600) and (ofIns1[I] < $FFFF)
        and (ofIns1[I] < Result) then
          Result := ofIns1[I];
    end;
    2:
    begin
      for I := 0 to Length(ofIns2) - 1 do
        if (ofIns2[I] > 1000) and (ofIns2[I] < $FFFF)
        and (ofIns2[I] < Result) then
          Result := ofIns2[I];
    end;
    3:
    begin
      for I := 0 to Length(ofIns3) - 1 do
        if (ofIns3[I] > 2000) and (ofIns3[I] < $FFFF)
        and (ofIns3[I] < Result) then
          Result := ofIns3[I];
    end;
  end;
end;

function GetTrackCount(): Word;
var
  I: Integer;
begin
  // Doesn't check for duplicate offsets
  Result := 0;
  case Version of
    1:
    begin
      for I := 0 to Length(ofTrk1) - 1 do
        if (ofTrk1[I] >= 600) and (ofTrk1[I] < $FFFF) then
          Inc(Result);
    end;
    2:
    begin
      for I := 0 to Length(ofTrk2) - 1 do
        if (ofTrk2[I] >= 1000) and (ofTrk2[I] < $FFFF) then
          Inc(Result);
    end;
    3:
    begin
      for I := 0 to Length(ofTrk3) - 1 do
        if (ofTrk3[I] >= 2000) and (ofTrk3[I] < $FFFF) then
          Inc(Result);
    end;
  end;
end;

function GetInstrCount(): Word;
var
  I: Integer;
begin
  // Doesn't check for duplicate offsets
  Result := 0;
  case Version of
    1:
    begin
      for I := 0 to Length(ofIns1) - 1 do
        if (ofIns1[I] > 600) and (ofIns1[I] < $FFFF) then
          Inc(Result);
    end;
    2:
    begin
      for I := 0 to Length(ofIns2) - 1 do
        if (ofIns2[I] > 1000) and (ofIns2[I] < $FFFF) then
          Inc(Result);
    end;
    3:
    begin
      for I := 0 to Length(ofIns3) - 1 do
        if (ofIns3[I] > 2000) and (ofIns3[I] < $FFFF) then
          Inc(Result);
    end;
  end;
end;

var
  I: Integer;
  B: Boolean;
  W, Idx: Word;

begin
  try
    { TODO -oUser -cConsole Main : Insert code here }

    F := TFileStream.Create(ParamStr(1), fmOpenRead or fmShareDenyWrite);
    Version := 0;

    if F.Size >= 720 then // Minimum file size for v1
    begin
      F.ReadBuffer(Index8, SizeOf(Index8));
      for I := 0 to Length(Index8) div 2 - 1 do
      begin
        // Check if we have 8-bit indexes
        W := Index8[I * 2] or (Index8[I * 2 + 1] shl 8);
        if (W >= 500) and (W < $FFFF) then
        begin
          Version := 1; // actually 1 or 2
          Break;
        end;
      end;
      if Version = 1 then
      begin
        B := DetectVersion12();
        if B then
          if Version = 1 then
            B := ProcessVersion1()
          else
            B := ProcessVersion2();
      end
      else
      begin
        Version := 3;
        B := ProcessVersion3();
      end;
    end
    else
    begin
      B := False;
      Writeln('Error: File size is too small.');
    end;

    if B then
    begin
      case Version of
        1, 2: Idx := SizeOf(Index8);
        else  Idx := SizeOf(Index16);
      end;
      Writeln('ADL Version ', Version);
      W := GetFirstTrack();
      Writeln('First track offset: 0x', IntToHex(W, 4),
        ' (absolute 0x', IntToHex(W + Idx, 4), ')');
      W := GetFirstInstr();
      Writeln('First instr offset: 0x', IntToHex(W, 4),
        ' (absolute 0x', IntToHex(W + Idx, 4), ')');
      W := GetTrackCount();
      Writeln('Track count: ', W);
      W := GetInstrCount();
      Writeln('Instr count: ', W);
      Writeln('Tracks in playback order:');
      case Version of
        1:
        for I := 0 to Length(Index8) - 1 do
          if (Index8[I] < 150) and
          (ofTrk1[Index8[I]] >= 600) and (ofTrk1[Index8[I]] < $FFFF) then
            Writeln(Index8[I], ': 0x', IntToHex(ofTrk1[Index8[I]], 4),
              ' (absolute 0x', IntToHex(ofTrk1[Index8[I]] + Idx, 4), ')');
        2:
        for I := 0 to Length(Index8) - 1 do
          if (Index8[I] < 250) and
          (ofTrk2[Index8[I]] >= 1000) and (ofTrk2[Index8[I]] < $FFFF) then
            Writeln(Index8[I], ': 0x', IntToHex(ofTrk2[Index8[I]], 4),
              ' (absolute 0x', IntToHex(ofTrk2[Index8[I]] + Idx, 4), ')');
        3:
        for I := 0 to Length(Index16) - 1 do
          if (Index16[I] < 500) and
          (ofTrk3[Index16[I]] >= 2000) and (ofTrk3[Index16[I]] < $FFFF) then
            Writeln(Index16[I], ': 0x', IntToHex(ofTrk3[Index16[I]], 4),
              ' (absolute 0x', IntToHex(ofTrk3[Index16[I]] + Idx, 4), ')');
      end;
    end;

    F.Free;

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.