{-------------------------------------------------------------------------
 Module:    Harpoon Classic LZH decoder (Shared)

 Comment:   LZHUF decode (LZSS + adaptive Huffman, Yoshizaki 1988) as used
            by Harpoon Classic .RES/.RSR containers for battleset text, map
            and ship-name resources.  Decode only.

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

            Stream format in one paragraph: a sequence of Huffman symbols
            over 314 values: 0-255 is a literal byte, 256-313 a match of
            length (symbol - 253) = 3..60 followed by a position code.
            Matches point into a 4096-byte ring of everything already
            emitted, prefilled with spaces and starting at N - F.  The
            Huffman code is adaptive: every symbol updates the tree, so a
            decoder that updates even slightly wrong produces plausible
            garbage rather than an error.  Bits are read MSB-first through a
            16-bit buffer.  LZH (8) and LZH_RANDOM (9) are the same stream.

            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 uCICHCLzh;

{$mode objfpc}{$H+}

interface

uses
  SysUtils;

type
  /// <summary>Raised for a truncated or corrupt LZH stream.</summary>
  ECICLzhError = class(Exception);

/// <summary>
/// Decodes a raw LZHUF stream (no 4-byte size prefix) to exactly
/// <paramref name="Size"/> bytes, as a container body is decoded with its
/// resource header's datasize.
/// </summary>
/// <param name="Stream">The stored (compressed) bytes.</param>
/// <param name="Size">The uncompressed size.</param>
/// <returns>Exactly Size bytes; '' when Size is 0.</returns>
/// <remarks>
/// Raises <see cref="ECICLzhError"/> on truncated or corrupt input; never
/// loops forever.  An LZH_RANDOM body may legitimately hold more than Size
/// bytes' worth of stream; decoding stops at Size.
/// </remarks>
function CICLzhDecode(const Stream: RawByteString; Size: Integer): RawByteString;

implementation

uses
  Classes; // EListError, for the defensive catch in CICLzhDecode

const
  cWindow    = 4096;               // N: ring buffer size, and a match's reach
  cLookahead = 60;                 // F: longest match
  cThreshold = 2;                  // a match must beat this to be worth coding
  cRingFill  = $20;                // the ring starts full of spaces

  cNChar    = 256 - cThreshold + cLookahead; // 314: 256 literals + 58 lengths
  cTreeSize = cNChar * 2 - 1;                // 627: T
  cRoot     = cTreeSize - 1;                 // 626
  cMaxFreq  = $8000;
  // The bit buffer may top itself up to 2 bytes past the last symbol.
  cMaxEofOverrun = 2;

{ The static position code: (length, how many values get it),
  1+3+8+12+24+16 = 64 values, canonical over the 64 upper-6-bit values. }

type
  TPosLenEntry = record
    Len, Cnt: Integer;
  end;

const
  PositionCodeLengths: array[0..5] of TPosLenEntry = (
    (Len: 3; Cnt: 1),
    (Len: 4; Cnt: 3),
    (Len: 5; Cnt: 8),
    (Len: 6; Cnt: 12),
    (Len: 7; Cnt: 24),
    (Len: 8; Cnt: 16)
  );

var
  PosValue: array[0..255] of Byte;
  PosBits: array[0..255] of Byte;
  PositionTablesReady: Boolean = False;

{ Decode lookups indexed by the next 8 bits of the stream: the upper-6-bit
  value that byte's prefix names, and how many bits that prefix used. Derived
  from PositionCodeLengths by the ordinary canonical rule, once. }
procedure BuildPositionTables;
var
  codes, lens: array[0..63] of Integer;
  idx, code, len_, prevLen, i, upper, span, start: Integer;
begin
  idx := 0;
  code := 0;
  prevLen := -1;
  for i := 0 to High(PositionCodeLengths) do
  begin
    len_ := PositionCodeLengths[i].Len;
    if prevLen <> -1 then
      code := code shl (len_ - prevLen);
    for upper := 1 to PositionCodeLengths[i].Cnt do
    begin
      codes[idx] := code;
      lens[idx] := len_;
      Inc(code);
      Inc(idx);
    end;
    prevLen := len_;
  end;
  for upper := 0 to 63 do
  begin
    len_ := lens[upper];
    code := codes[upper];
    span := 1 shl (8 - len_);
    start := code shl (8 - len_);
    for i := start to start + span - 1 do
    begin
      PosValue[i] := upper;
      PosBits[i] := len_;
    end;
  end;
  PositionTablesReady := True;
end;

{ The decode loop over a stream expected to hold at least TextSize bytes'
  worth of symbols (or that raises trying). }
function LzhDecodeStream(const Stream: RawByteString; TextSize: Integer): RawByteString;
var
  n, mask: Integer;
  pos, overrun: Integer;
  buf, have: Integer;
  freq: array[0..cTreeSize] of Integer;
  parent: array[0..cTreeSize + cNChar - 1] of Integer;
  child: array[0..cTreeSize - 1] of Integer;
  ring: array[0..cWindow - 1] of Byte;
  r, remaining, outPos: Integer;

  { ---- bit reader: MSB-first through a 16-bit buffer ---- }

  function NextByte: Integer;
  begin
    if pos < n then
    begin
      Result := Ord(Stream[pos + 1]);
      Inc(pos);
    end
    else
    begin
      Inc(overrun);
      if overrun > cMaxEofOverrun then
        raise ECICLzhError.CreateFmt(
          'truncated LZH stream: ran out of input before decoding %d bytes',
          [TextSize]);
      Result := 0;
    end;
  end;

  function ReadBit: Integer;
  begin
    while have <= 8 do
    begin
      buf := buf or (NextByte shl (8 - have));
      Inc(have, 8);
    end;
    if (buf and $8000) <> 0 then
      Result := 1
    else
      Result := 0;
    buf := (buf shl 1) and $FFFF;
    Dec(have);
  end;

  function ReadByte: Integer;
  begin
    while have <= 8 do
    begin
      buf := buf or (NextByte shl (8 - have));
      Inc(have, 8);
    end;
    Result := (buf shr 8) and $FF;
    buf := (buf shl 8) and $FFFF;
    Dec(have, 8);
  end;

  { ---- adaptive Huffman tree: arrays with the sibling property ---- }

  { Halve every leaf frequency and rebuild, when the root hits cMaxFreq. }
  procedure Rebuild;
  var
    outIdx, i, first, node, at, total, c: Integer;
  begin
    outIdx := 0;
    for i := 0 to cTreeSize - 1 do
      if child[i] >= cTreeSize then // a leaf
      begin
        freq[outIdx] := (freq[i] + 1) div 2;
        child[outIdx] := child[i];
        Inc(outIdx);
      end;
    first := 0;
    node := cNChar;
    while node < cTreeSize do
    begin
      total := freq[first] + freq[first + 1];
      at := node - 1;
      while total < freq[at] do
        Dec(at);
      Inc(at);
      for i := node downto at + 1 do
      begin
        freq[i] := freq[i - 1];
        child[i] := child[i - 1];
      end;
      freq[at] := total;
      child[at] := first;
      Inc(first, 2);
      Inc(node);
    end;
    for i := 0 to cTreeSize - 1 do
    begin
      c := child[i];
      parent[c] := i;
      if c < cTreeSize then // internal: its sibling shares the parent
        parent[c + 1] := i;
    end;
  end;

  { Charge one occurrence of Symbol to the tree, walking to the root. }
  procedure UpdateTree(Symbol: Integer);
  var
    node, weight, higher, moved, displaced: Integer;
  begin
    if freq[cRoot] = cMaxFreq then
      Rebuild;
    node := parent[Symbol + cTreeSize];
    while True do
    begin
      Inc(freq[node]);
      weight := freq[node];
      higher := node + 1;
      if weight > freq[higher] then
      begin
        while weight > freq[higher] do
          Inc(higher);
        Dec(higher);
        freq[node] := freq[higher];
        freq[higher] := weight;

        moved := child[node];
        parent[moved] := higher;
        if moved < cTreeSize then
          parent[moved + 1] := higher;
        displaced := child[higher];
        child[higher] := moved;
        parent[displaced] := node;
        if displaced < cTreeSize then
          parent[displaced + 1] := node;
        child[node] := displaced;
        node := higher;
      end;
      node := parent[node];
      if node = 0 then // stepped off the root
        Break;
    end;
  end;

  { Walk the tree one bit at a time.  A corrupt stream can only steer which
    sibling is picked, so the one place that can run off the end of child[]
    is guarded explicitly rather than left to a range check a release build
    may not have. }
  function ReadSymbol: Integer;
  var
    c: Integer;
  begin
    c := child[cRoot];
    while c < cTreeSize do
    begin
      c := c + ReadBit;
      if (c < 0) or (c >= cTreeSize) then
        raise ECICLzhError.Create('corrupt LZH stream: bad internal index');
      c := child[c];
    end;
    c := c - cTreeSize;
    UpdateTree(c);
    Result := c;
  end;

  { Distance - 1: an 8-bit lookahead names the upper 6 bits and says how many
    of those 8 bits it used; the rest of the low 6 bits follow. }
  function ReadPosition: Integer;
  var
    i, k, bits: Integer;
  begin
    i := ReadByte;
    bits := PosBits[i];
    Result := PosValue[i] shl 6;
    for k := 1 to bits - 2 do
      i := (i shl 1) + ReadBit;
    Result := Result or (i and $3F);
  end;

var
  i, left, node: Integer;
  symbol, start, len_, k, b: Integer;
begin
  if not PositionTablesReady then
    BuildPositionTables;

  n := Length(Stream);
  mask := cWindow - 1;
  pos := 0;
  overrun := 0;
  buf := 0;
  have := 0;

  { Every symbol starts equally likely; internal nodes pair adjacent nodes,
    which satisfies the sibling property by construction. }
  for i := 0 to cNChar - 1 do
  begin
    freq[i] := 1;
    child[i] := i + cTreeSize;
    parent[i + cTreeSize] := i;
  end;
  left := 0;
  node := cNChar;
  while node <= cRoot do
  begin
    freq[node] := freq[left] + freq[left + 1];
    child[node] := left;
    parent[left] := node;
    parent[left + 1] := node;
    Inc(left, 2);
    Inc(node);
  end;
  freq[cTreeSize] := $FFFF; // sentinel: no real frequency ever reaches it
  parent[cRoot] := 0;

  for i := 0 to cWindow - 1 do
    ring[i] := cRingFill;
  r := cWindow - cLookahead;

  remaining := TextSize;
  SetLength(Result, TextSize);
  outPos := 0;

  while remaining > 0 do
  begin
    symbol := ReadSymbol;
    if symbol < 256 then
    begin
      Inc(outPos);
      Result[outPos] := AnsiChar(symbol);
      Dec(remaining);
      ring[r] := Byte(symbol);
      r := (r + 1) and mask;
    end
    else
    begin
      start := (r - ReadPosition - 1) and mask;
      len_ := symbol - 255 + cThreshold;
      { A well-formed stream never overruns remaining here; stopping at it
        anyway means a corrupt one cannot write past the caller's size. }
      for k := 0 to len_ - 1 do
      begin
        if remaining = 0 then
          Break;
        b := ring[(start + k) and mask];
        Inc(outPos);
        Result[outPos] := AnsiChar(b);
        Dec(remaining);
        ring[r] := Byte(b);
        r := (r + 1) and mask;
      end;
    end;
  end;
end;

function CICLzhDecode(const Stream: RawByteString; Size: Integer): RawByteString;
begin
  if Size = 0 then
  begin
    Result := '';
    Exit;
  end;
  if Size < 0 then
    raise ECICLzhError.CreateFmt('invalid LZH uncompressed size: %d', [Size]);
  try
    Result := LzhDecodeStream(Stream, Size);
  except
    on E: ECICLzhError do
      raise;
    on E: ERangeError do
      raise ECICLzhError.CreateFmt('corrupt LZH stream: bad internal index (%s)',
        [E.Message]);
    on E: EListError do
      raise ECICLzhError.CreateFmt('corrupt LZH stream: bad internal index (%s)',
        [E.Message]);
  end;
end;

end.