{-------------------------------------------------------------------------
 Module:    Harpoon Classic .RES container (Shared)

 Comment:   Reads and writes the Harpoon Classic .RES container: an
            optional BBFT prefix, a self-describing offset table, 5- or
            7-byte resource headers, and 0x1A empty slots.  LZH bodies are
            decoded on demand by uCICHCLzh.

            Extracted from the Stratsims HC Platform Editor (HCPE,
            hcpe.container) and relicensed under MIT for StratsimsOSS.

            Layout:
              [optional 8-byte prefix]  char[4] "BBFT"; u32 structure version
              [offset table]            u32 offset[N]; N = offset[0] / 4;
                                        offsets are relative to the END of
                                        the BBFT prefix and include the table
              [sections]                per slot, back to back, no padding:
                                          populated -> header + body
                                          empty     -> one byte 0x1A
            Resource header, chosen BY FILE NAME (never by the bytes):
              old (5): u8 type; u8 videoType; u8 compressed; u16 datasize
              new (7): u8 type; u8 videoType; u8 compressed; u32 datasize
            datasize is the UNcompressed size; a body's stored length comes
            from offset arithmetic (next section boundary).

            FPC/Lazarus only.

 License:   MIT.  Copyright (c) 2026 TGP Enterprises, Inc.
            Permission is hereby granted, free of charge, to any person
            obtaining a copy of this software and associated documentation
            files (the "Software"), to deal in the Software without
            restriction, including without limitation the rights to use,
            copy, modify, merge, publish, distribute, sublicense, and/or sell
            copies of the Software, and to permit persons to whom the
            Software is furnished to do so, subject to the following
            conditions: The above copyright notice and this permission
            notice shall be included in all copies or substantial portions
            of the Software.  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT
            WARRANTY OF ANY KIND.
-------------------------------------------------------------------------}
unit uCICHCResContainer;

{$mode objfpc}{$H+}

interface

uses
  SysUtils, Generics.Collections;

const
  HCRES_BBFT_MAGIC = 'BBFT';
  HCRES_STRUCTURE_VERSION = 5;
  HCRES_MAX_RES = 77;
  HCRES_OLD_HEADER_SIZE = 5;
  HCRES_NEW_HEADER_SIZE = 7;
  HCRES_TYPE_STD_DATA = 0;
  HCRES_TYPE_EMPTY = 26;
  HCRES_COMPRESS_NONE = 0;
  HCRES_COMPRESS_NONE_RANDOM = 1;
  HCRES_COMPRESS_LZH = 8;
  HCRES_COMPRESS_LZH_RANDOM = 9;

  // Selected RES1_* resource ids (HC Harpoon.h).
  HCRES1_TEXT = 0;
  HCRES1_MAG_RECS = 21;
  HCRES1_BS_STRINGS = 22;
  HCRES1_TEXT_INDEX = 23;
  HCRES1_CLASS_NAME_INDEX = 25;
  /// <summary>Scenario index: (u32 offset, u16 length) pairs into HCRES1_SCENARIO_TEXT; entry 0 is the battleset's own description.</summary>
  HCRES1_SCENARIO_INDEX = 26;
  /// <summary>Scenario text pool.</summary>
  HCRES1_SCENARIO_TEXT = 27;
  HCRES1_BS_SHIP_NAMES = 29;
  HCRES1_DATABASE_VERSION = 65;
  HCRES1_VIC_TYPES = 75;

type
  /// <summary>Raised for a malformed container or an out-of-range read.</summary>
  ECICResError = class(Exception);

  /// <summary>A u32 (offset or boundary) array.</summary>
  TCICU32Array = array of LongWord;

  /// <summary>The offset table: BBFT prefix (if any), the offsets verbatim, and
  /// the boundary set CICResSlotExtent needs (offsets plus EOF, sorted, unique).</summary>
  TCICResOffsetTable = record
    /// <summary>0 = no BBFT prefix.</summary>
    StructureVersion: LongWord;
    /// <summary>ResFileOffset: offsets are relative to here (0, or 8 past "BBFT"+u32).</summary>
    Rfo: Integer;
    Offsets: TCICU32Array;
    Boundaries: TCICU32Array;
  end;

  /// <summary>One container slot: a populated resource or the empty sentinel.</summary>
  TCICResResource = class
  public
    ResType: Byte;
    VideoType: Byte;
    Compressed: Byte;
    /// <summary>UNcompressed size, from/for the header.</summary>
    DataSize: LongWord;
    /// <summary>Raw stored bytes (may be LZH).</summary>
    Body: RawByteString;
    IsEmpty: Boolean;
    constructor CreateEmpty;
    constructor CreateOf(const ABody: RawByteString; AType, AVideoType, ACompressed: Byte);
    /// <summary>Logical content: Body LZH-decoded to exactly DataSize bytes when
    /// Compressed is 8 or 9, else Body.  '' for an empty slot.</summary>
    function Data: RawByteString;
    function Clone: TCICResResource;
    /// <summary>The bytes this slot occupies in a container: the empty sentinel,
    /// or the 5- or 7-byte header followed by Body.</summary>
    function SectionBytes(AHeaderSize: Integer): RawByteString;
  end;

  TCICResResourceList = specialize TObjectList<TCICResResource>;

  /// <summary>A whole .RES container.</summary>
  TCICResContainer = class
  public
    Resources: TCICResResourceList;
    /// <summary>0 = no BBFT prefix.</summary>
    StructureVersion: LongWord;
    HeaderSize: Integer;
    constructor Create;
    destructor Destroy; override;
    function SlotCount: Integer;
    /// <summary>Parses a container; raises ECICResError on a malformed table.</summary>
    class function FromBytes(const Data: RawByteString; AHeaderSize: Integer): TCICResContainer;
    /// <summary>Reads a .RES file, choosing the header size from its name.</summary>
    class function FromFile(const AFileName: String): TCICResContainer;
    function ToBytes: RawByteString;
  end;

/// <summary>New (7) vs old (5) resource header, decided by file name: commondb,
/// giukusni, wpacusni and hdsl..hdsu use the new one.</summary>
function CICResHeaderSizeForName(const FileName: string): Integer;

/// <summary>Parses the offset table shared by .RES and .RSR.  Raises
/// ECICResError on a truncated file or an offset[0] that is not a multiple of
/// 4 or would run the table past EOF.</summary>
function CICResReadOffsetTable(const Data: RawByteString): TCICResOffsetTable;

/// <summary>Distance from Offset to the next distinct higher boundary (or
/// EndRel): the stored size of the section starting there.</summary>
function CICResSlotExtent(Offset: LongWord; const Boundaries: TCICU32Array; EndRel: LongWord): Int64;

implementation

uses
  Classes, uCICHCLzh;

{ ---------------------------------------------------------------- helpers -- }

{ 0-based byte read, bounds-checked; never an access violation. }
function ByteAt0(const S: RawByteString; Idx0: Int64): Byte;
begin
  if (Idx0 < 0) or (Idx0 >= Length(S)) then
    raise ECICResError.CreateFmt(
      'HC .RES container: byte offset %d out of range (length %d)', [Idx0, Length(S)]);
  Result := Byte(S[Idx0 + 1]);
end;

function ReadU16LE0(const S: RawByteString; Idx0: Int64): Word;
begin
  Result := Word(ByteAt0(S, Idx0)) or (Word(ByteAt0(S, Idx0 + 1)) shl 8);
end;

function ReadU32LE0(const S: RawByteString; Idx0: Int64): LongWord;
begin
  Result := LongWord(ByteAt0(S, Idx0))
    or (LongWord(ByteAt0(S, Idx0 + 1)) shl 8)
    or (LongWord(ByteAt0(S, Idx0 + 2)) shl 16)
    or (LongWord(ByteAt0(S, Idx0 + 3)) shl 24);
end;

{ 0-based [Idx0, Idx0+Count) slice, bounds-checked. }
function CopyBytes0(const S: RawByteString; Idx0, Count: Int64): RawByteString;
begin
  if (Count < 0) or (Idx0 < 0) or (Idx0 + Count > Length(S)) then
    raise ECICResError.CreateFmt(
      'HC .RES container: slice [%d, %d) out of range (length %d)',
      [Idx0, Idx0 + Count, Length(S)]);
  if Count = 0 then
  begin
    Result := '';
    Exit;
  end;
  Result := Copy(S, Idx0 + 1, Count);
  SetCodePage(Result, CP_NONE, False);
end;

{ Write directly into an already-sized buffer (0-based byte offset).  Never
  concatenates: building a RawByteString via repeated "S := S + x" starting
  from S := '' is NOT safe -- an empty RawByteString's code page defaults to
  DefaultSystemCodePage, so the first "+" against a CP_NONE operand can
  silently convert through the stub widestring manager and yield '' (FPC
  3.2.2).  Every byte buffer here is built with one SetLength and direct
  writes/Move. }
procedure WriteU8At(var S: RawByteString; Idx0: Int64; V: Byte);
begin
  S[Idx0 + 1] := Chr(V);
end;

procedure WriteU16At(var S: RawByteString; Idx0: Int64; V: Word);
begin
  S[Idx0 + 1] := Chr(V and $FF);
  S[Idx0 + 2] := Chr((V shr 8) and $FF);
end;

procedure WriteU32At(var S: RawByteString; Idx0: Int64; V: LongWord);
begin
  S[Idx0 + 1] := Chr(V and $FF);
  S[Idx0 + 2] := Chr((V shr 8) and $FF);
  S[Idx0 + 3] := Chr((V shr 16) and $FF);
  S[Idx0 + 4] := Chr((V shr 24) and $FF);
end;

function EmptyByteStr: RawByteString;
begin
  SetLength(Result, 1);
  Result[1] := Chr(HCRES_TYPE_EMPTY);
  SetCodePage(Result, CP_NONE, False);
end;

{ Byte comparison, deliberately not a string-literal '=' (code-page pitfalls).
  Safe on data shorter than 4 bytes. }
function DataStartsWithBBFT(const Data: RawByteString): Boolean;
begin
  Result := (Length(Data) >= 4)
    and (Data[1] = 'B') and (Data[2] = 'B') and (Data[3] = 'F') and (Data[4] = 'T');
end;

function HasPrefix(const S, Prefix: string): Boolean;
begin
  Result := (Length(S) >= Length(Prefix)) and (Copy(S, 1, Length(Prefix)) = Prefix);
end;

{ Ascending, deduplicated.  Insertion sort: N is a handful to a few hundred. }
function SortUniqueU32(const Values: TCICU32Array): TCICU32Array;
var
  Tmp: TCICU32Array;
  i, j, n, w: Integer;
  v: LongWord;
begin
  n := Length(Values);
  SetLength(Tmp, n);
  for i := 0 to n - 1 do
    Tmp[i] := Values[i];
  for i := 1 to n - 1 do
  begin
    v := Tmp[i];
    j := i - 1;
    while (j >= 0) and (Tmp[j] > v) do
    begin
      Tmp[j + 1] := Tmp[j];
      Dec(j);
    end;
    Tmp[j + 1] := v;
  end;
  SetLength(Result, n);
  w := 0;
  for i := 0 to n - 1 do
  begin
    if (w = 0) or (Tmp[i] <> Result[w - 1]) then
    begin
      Result[w] := Tmp[i];
      Inc(w);
    end;
  end;
  SetLength(Result, w);
end;

{ ------------------------------------------------------ TCICResResource -- }

constructor TCICResResource.CreateEmpty;
begin
  inherited Create;
  ResType := HCRES_TYPE_EMPTY;
  IsEmpty := True;
end;

constructor TCICResResource.CreateOf(const ABody: RawByteString; AType, AVideoType, ACompressed: Byte);
begin
  inherited Create;
  Body := ABody;
  ResType := AType;
  VideoType := AVideoType;
  Compressed := ACompressed;
  DataSize := Length(ABody);
end;

function TCICResResource.Data: RawByteString;
begin
  if IsEmpty then
  begin
    Result := '';
    Exit;
  end;
  if (Compressed = HCRES_COMPRESS_LZH) or (Compressed = HCRES_COMPRESS_LZH_RANDOM) then
  begin
    if DataSize > LongWord(High(Integer)) then
      raise ECICResError.CreateFmt(
        'HC .RES container: datasize %u too large to decode', [DataSize]);
    Result := CICLzhDecode(Body, Integer(DataSize));
  end
  else
    Result := Body;
end;

function TCICResResource.Clone: TCICResResource;
begin
  Result := TCICResResource.Create;
  Result.ResType := ResType;
  Result.VideoType := VideoType;
  Result.Compressed := Compressed;
  Result.DataSize := DataSize;
  Result.Body := Body;
  Result.IsEmpty := IsEmpty;
end;

function TCICResResource.SectionBytes(AHeaderSize: Integer): RawByteString;
var
  BodyLen: Integer;
begin
  if IsEmpty then
  begin
    Result := EmptyByteStr;
    Exit;
  end;
  BodyLen := Length(Body);
  SetLength(Result, AHeaderSize + BodyLen);
  WriteU8At(Result, 0, ResType);
  WriteU8At(Result, 1, VideoType);
  WriteU8At(Result, 2, Compressed);
  if AHeaderSize = HCRES_NEW_HEADER_SIZE then
    WriteU32At(Result, 3, DataSize)
  else
    WriteU16At(Result, 3, Word(DataSize and $FFFF));
  if BodyLen > 0 then
    Move(Body[1], Result[AHeaderSize + 1], BodyLen);
  SetCodePage(Result, CP_NONE, False);
end;

{ ------------------------------------------------------- offset table ---- }

function CICResReadOffsetTable(const Data: RawByteString): TCICResOffsetTable;
var
  Len: Int64;
  FirstOff: LongWord;
  N: Int64;
  i: Integer; // an Int64 loop counter is not allowed on 32-bit targets
  Offs, Combined: TCICU32Array;
  EndRel: Int64;
begin
  Len := Length(Data);
  if DataStartsWithBBFT(Data) then
  begin
    Result.StructureVersion := ReadU32LE0(Data, 4);
    Result.Rfo := 8;
  end
  else
  begin
    Result.StructureVersion := 0;
    Result.Rfo := 0;
  end;

  { Bounds-checked by ReadU32LE0/ByteAt0: a truncated file raises here. }
  FirstOff := ReadU32LE0(Data, Result.Rfo);
  if (FirstOff mod 4) <> 0 then
    raise ECICResError.CreateFmt(
      'HC .RES container: offset[0]=%u is not a multiple of 4', [FirstOff]);

  N := Int64(FirstOff) div 4;
  if Int64(Result.Rfo) + N * 4 > Len then
    raise ECICResError.CreateFmt(
      'HC .RES container: offset table of %d entries runs past EOF', [N]);

  SetLength(Offs, N);
  for i := 0 to N - 1 do
    Offs[i] := ReadU32LE0(Data, Result.Rfo + i * 4);
  Result.Offsets := Offs;

  EndRel := Len - Result.Rfo;
  SetLength(Combined, N + 1);
  for i := 0 to N - 1 do
    Combined[i] := Offs[i];
  Combined[N] := LongWord(EndRel);
  Result.Boundaries := SortUniqueU32(Combined);
end;

function CICResSlotExtent(Offset: LongWord; const Boundaries: TCICU32Array; EndRel: LongWord): Int64;
var
  i: Integer;
  Nxt: LongWord;
begin
  Nxt := EndRel;
  for i := 0 to High(Boundaries) do
    if Boundaries[i] > Offset then
    begin
      Nxt := Boundaries[i];
      Break;
    end;
  Result := Int64(Nxt) - Int64(Offset);
end;

function CICResHeaderSizeForName(const FileName: string): Integer;
var
  Stem: string;
begin
  Stem := LowerCase(ExtractFileName(FileName));
  if HasPrefix(Stem, 'commondb') or HasPrefix(Stem, 'giukusni') or HasPrefix(Stem, 'wpacusni') then
  begin
    Result := HCRES_NEW_HEADER_SIZE;
    Exit;
  end;
  if (Length(Stem) >= 4) and (Copy(Stem, 1, 3) = 'hds') and (Pos(Stem[4], 'lmnopqrstu') > 0) then
  begin
    Result := HCRES_NEW_HEADER_SIZE;
    Exit;
  end;
  Result := HCRES_OLD_HEADER_SIZE;
end;

{ ----------------------------------------------------- TCICResContainer -- }

constructor TCICResContainer.Create;
begin
  inherited Create;
  Resources := TCICResResourceList.Create(True);
  StructureVersion := HCRES_STRUCTURE_VERSION;
  HeaderSize := HCRES_NEW_HEADER_SIZE;
end;

destructor TCICResContainer.Destroy;
begin
  Resources.Free;
  inherited Destroy;
end;

function TCICResContainer.SlotCount: Integer;
begin
  Result := Resources.Count;
end;

class function TCICResContainer.FromBytes(const Data: RawByteString; AHeaderSize: Integer): TCICResContainer;
var
  Table: TCICResOffsetTable;
  EndRel: Int64;
  i: Integer;
  o: LongWord;
  Ab0: Int64;
  TypByte, Typ, Vid, Comp: Byte;
  DSize: LongWord;
  Extent, BodyLen: Int64;
  Body: RawByteString;
  Res: TCICResResource;
begin
  if (AHeaderSize <> HCRES_OLD_HEADER_SIZE) and (AHeaderSize <> HCRES_NEW_HEADER_SIZE) then
    raise ECICResError.CreateFmt(
      'HC .RES container: unsupported header size %d', [AHeaderSize]);

  Table := CICResReadOffsetTable(Data);
  EndRel := Int64(Length(Data)) - Table.Rfo;

  Result := TCICResContainer.Create;
  try
    Result.StructureVersion := Table.StructureVersion;
    Result.HeaderSize := AHeaderSize;

    for i := 0 to High(Table.Offsets) do
    begin
      o := Table.Offsets[i];
      Ab0 := Int64(Table.Rfo) + Int64(o);
      TypByte := ByteAt0(Data, Ab0);

      if TypByte = HCRES_TYPE_EMPTY then
      begin
        Result.Resources.Add(TCICResResource.CreateEmpty);
        Continue;
      end;

      Extent := CICResSlotExtent(o, Table.Boundaries, LongWord(EndRel));
      if Extent < AHeaderSize then
        raise ECICResError.CreateFmt(
          'HC .RES container: slot %d section is %d bytes, shorter than the %d-byte header',
          [i, Extent, AHeaderSize]);

      Typ := TypByte;
      Vid := ByteAt0(Data, Ab0 + 1);
      Comp := ByteAt0(Data, Ab0 + 2);
      if AHeaderSize = HCRES_NEW_HEADER_SIZE then
        DSize := ReadU32LE0(Data, Ab0 + 3)
      else
        DSize := ReadU16LE0(Data, Ab0 + 3);

      BodyLen := Extent - AHeaderSize;
      Body := CopyBytes0(Data, Ab0 + AHeaderSize, BodyLen);

      Res := TCICResResource.Create;
      Res.ResType := Typ;
      Res.VideoType := Vid;
      Res.Compressed := Comp;
      Res.DataSize := DSize;
      Res.Body := Body;
      Res.IsEmpty := False;
      Result.Resources.Add(Res);
    end;
  except
    Result.Free;
    raise;
  end;
end;

class function TCICResContainer.FromFile(const AFileName: String): TCICResContainer;
var
  FS: TFileStream;
  Data: RawByteString;
begin
  FS := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    SetLength(Data, FS.Size);
    if FS.Size > 0 then
      FS.ReadBuffer(Data[1], FS.Size);
  finally
    FS.Free;
  end;
  SetCodePage(Data, CP_NONE, False);
  Result := FromBytes(Data, CICResHeaderSizeForName(AFileName));
end;

function TCICResContainer.ToBytes: RawByteString;
var
  Sections: array of RawByteString;
  Offs: array of LongWord;
  N, i: Integer;
  Cur, PrefixLen, TotalLen, Pos: Int64;
begin
  N := Resources.Count;
  SetLength(Sections, N);
  for i := 0 to N - 1 do
    Sections[i] := Resources[i].SectionBytes(HeaderSize);

  { offset[0] (== the table's own size, N*4) starts the running offset. }
  SetLength(Offs, N);
  Cur := Int64(N) * 4;
  for i := 0 to N - 1 do
  begin
    Offs[i] := LongWord(Cur);
    Cur := Cur + Length(Sections[i]);
  end;

  if StructureVersion = 0 then
    PrefixLen := 0
  else
    PrefixLen := 8;

  TotalLen := PrefixLen + Int64(N) * 4;
  for i := 0 to N - 1 do
    TotalLen := TotalLen + Length(Sections[i]);

  { One allocation, direct writes (see WriteU32At). }
  SetLength(Result, TotalLen);
  Pos := 0;
  if PrefixLen > 0 then
  begin
    Result[1] := 'B';
    Result[2] := 'B';
    Result[3] := 'F';
    Result[4] := 'T';
    WriteU32At(Result, 4, StructureVersion);
    Pos := 8;
  end;
  for i := 0 to N - 1 do
  begin
    WriteU32At(Result, Pos, Offs[i]);
    Pos := Pos + 4;
  end;
  for i := 0 to N - 1 do
  begin
    if Length(Sections[i]) > 0 then
      Move(Sections[i][1], Result[Pos + 1], Length(Sections[i]));
    Pos := Pos + Length(Sections[i]);
  end;
  SetCodePage(Result, CP_NONE, False);
end;

end.