abdfpkmg.pas

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower Abbrevia
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1997-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* ABBREVIA: AbDfPkMg.pas 3.05                           *}
{*********************************************************}
{* Deflate package-merge algorithm                       *}
{*********************************************************}

unit AbDfPkMg;

{$I AbDefine.inc}

interface

uses
  SysUtils,
  AbDfBase;

procedure GenerateCodeLengths(aMaxCodeLen  : integer;
                        const aWeights     : array of integer;
                          var aCodeLengths : array of integer;
                              aStartInx    : integer;
                              aLog         : TAbLogger);

implementation

uses
  AbDfXlat;

type
  PPkgNode = ^TPkgNode;
  TPkgNode = packed record
    pnWeight : integer;
    pnCount  : integer;
    pnLeft   : PPkgNode;
    pnRight  : PPkgNode;
  end;

  PPkgNodeList = ^TPkgNodeList;
  TPkgNodeList = array [0..pred(286 * 2)] of PPkgNode;
  {Note: the "286" is the number of literal/length symbols, the
         maximum number of weights we'll be calculating the optimal
         code lengths for}


{===helper routines==================================================}
function IsCalcFeasible(aCount      : integer;
                        aMaxCodeLen : integer) : boolean;

begin
  {works out if length-limited codes can be calculated for a given
   number of symbols and the maximum code length}

  {return whether 2^aMaxCodeLen > aCount}
  Result := (1 shl aMaxCodeLen) > aCount;
end;
{--------}
procedure QSS(aList  : PPkgNodeList;
              aFirst : integer;
              aLast  : integer);
var
  L, R  : integer;
  Pivot : integer;
  Temp  : pointer;
begin
  {while there are at least two items to sort}
  while (aFirst < aLast) do begin
    {the pivot is the middle item}
    Pivot := aList^[(aFirst+aLast) div 2]^.pnWeight;
    {set indexes and partition}
    L := pred(aFirst);
    R := succ(aLast);
    while true do begin
      repeat dec(R); until (aList^[R]^.pnWeight <= Pivot);
      repeat inc(L); until (aList^[L]^.pnWeight >= Pivot);
      if (L >= R) then Break;
      Temp := aList^[L];
      aList^[L] := aList^[R];
      aList^[R] := Temp;
    end;
    {quicksort the first subfile}
    if (aFirst < R) then
      QSS(aList, aFirst, R);
    {quicksort the second subfile - recursion removal}
    aFirst := succ(R);
  end;
end;
{--------}
procedure SortList(aList : PPkgNodeList; aCount : integer);
begin
  QSS(aList, 0, pred(aCount));
end;
{--------}
procedure Accumulate(aNode : PPkgNode);
begin
  while (aNode^.pnLeft <> nil) do begin
    Accumulate(aNode^.pnLeft);
    aNode := aNode^.pnRight;
  end;
  inc(aNode^.pnCount);
end;
{====================================================================}


{===Interfaced routine===============================================}
procedure GenerateCodeLengths(aMaxCodeLen  : integer;
                        const aWeights     : array of integer;
                          var aCodeLengths : array of integer;
                              aStartInx    : integer;
                              aLog         : TAbLogger);
var
  i   : integer;
  Bit : integer;
  WeightCount    : integer;
  OrigList       : PPkgNodeList;
  OrigListCount  : integer;
  MergeList      : PPkgNodeList;
  MergeListCount : integer;
  PkgList        : PPkgNodeList;
  PkgListCount   : integer;
  OrigInx        : integer;
  PkgInx         : integer;
  Node           : PPkgNode;
  NodeMgr        : TAbNodeManager;
begin
  {calculate the number of weights}
  WeightCount := succ(high(aWeights));

  {check for dumb programming errors}
  Assert((0 < aMaxCodeLen) and (aMaxCodeLen <= 15),
         'GenerateCodeLengths: the maximum code length should be in the range 1..15');
  Assert((1 <= WeightCount) and (WeightCount <= 286),
         'GenerateCodeLengths: the weight array must have 1..286 elements');
  Assert(IsCalcFeasible(WeightCount, aMaxCodeLen),
         'GenerateCodeLengths: the package-merge algorithm should always be feasible');

  {clear the code lengths array}
  FillChar(aCodeLengths[aStartInx], WeightCount * sizeof(integer), 0);

  {prepare for the try..finally}
  OrigList := nil;
  MergeList := nil;
  PkgList := nil;
  NodeMgr := nil;
  try

    {create the node manager}
    NodeMgr := TAbNodeManager.Create(sizeof(TPkgNode));

    {create the original list of nodes}
    GetMem(OrigList, WeightCount * sizeof(PPkgNode));
    OrigListCount := 0;
    for i := 0 to pred(WeightCount) do
      if (aWeights[i] <> 0) then begin
        Node := NodeMgr.AllocNode;
        Node^.pnLeft := nil;           { this will indicate a leaf}
        Node^.pnRight := pointer(i);   { the index of the weight}
        Node^.pnWeight := aWeights[i]; { the weight itself}
        Node^.pnCount := 1;            { how many times used}
        OrigList^[OrigListCount] := Node;
        inc(OrigListCount);
      end;

    {we need at least 2 items, so make anything less a special case}
    if (OrigListCount <= 1) then begin

      {if there are no items at all in the original list, we need to
       pretend that there is one, since we shall eventually need to
       calculate a Count-1 value that cannot be negative}
      if (OrigListCount = 0) then begin
        aCodeLengths[aStartInx] := 1;
        Exit;
      end;

      {otherwise there is only one item: set its code length directly}
      for i := 0 to pred(WeightCount) do
        if (aWeights[i] <> 0) then begin
          aCodeLengths[aStartInx + i] := 1;
          Exit;
        end;
    end;

    {there are at least 2 items in the list; so sort the list}
    SortList(OrigList, OrigListCount);

    {create the merge and package lists}
    GetMem(MergeList, OrigListCount * 2 * sizeof(PPkgNode));
    GetMem(PkgList, OrigListCount * 2 * sizeof(PPkgNode));

    {initialize the merge list to have the same items as the
     original list}
    Move(OrigList^, MergeList^, OrigListCount * sizeof(PPkgNode));
    MergeListCount := OrigListCount;

    {do aMaxCodeLen - 2 times...}
    for Bit := 1 to pred(aMaxCodeLen) do begin

      {generate the package list from the merge list by grouping pairs
       from the merge list and adding them to the package list}
      PkgListCount := 0;
      for i := 0 to pred(MergeListCount div 2) do begin
        Node := NodeMgr.AllocNode;
        Node^.pnLeft := MergeList^[i * 2];
        Node^.pnRight := MergeList^[i * 2 + 1];
        Node^.pnWeight := Node^.pnLeft^.pnWeight +
                          Node^.pnRight^.pnWeight;
        {$IFOPT C+}
        Node^.pnCount := 0;
        {$ENDIF}
        PkgList^[PkgListCount] := Node;
        inc(PkgListCount);
      end;

      {merge the original list and the package list}
      MergeListCount := 0;
      OrigInx := 0;
      PkgInx := 0;
      {note the optimization here: the package list will *always* be
       last to empty in the merge process since it will have at least
       one item whose accumulated weight is greater than all of the
       items in the original list}
      while (OrigInx < OrigListCount) and (PkgInx < PkgListCount) do begin
        if (OrigList^[OrigInx]^.pnWeight <= PkgList^[PkgInx]^.pnWeight) then begin
          MergeList^[MergeListCount] := OrigList^[OrigInx];
          inc(OrigInx);
        end
        else begin
          MergeList^[MergeListCount] := PkgList^[PkgInx];
          inc(PkgInx);
        end;
        inc(MergeListCount);
      end;
      if (OrigInx < OrigListCount) then begin
        Move(OrigList^[OrigInx], MergeList^[MergeListCount],
             (OrigListCount - OrigInx) * sizeof(PPkgNode));
        inc(MergeListCount, (OrigListCount - OrigInx));
      end
      else begin
        Move(PkgList^[PkgInx], MergeList^[MergeListCount],
             (PkgListCount - PkgInx) * sizeof(PPkgNode));
        inc(MergeListCount, (PkgListCount - PkgInx));
      end;
    end;

    {calculate the code lengths}
    for i := 0 to (OrigListCount * 2) - 3 do begin
      Node := MergeList^[i];
      if (Node^.pnLeft <> nil) then
        Accumulate(Node);
    end;
    for i := 0 to pred(OrigListCount) do
      aCodeLengths[aStartInx + integer(OrigList^[i].pnRight)] :=
          OrigList^[i].pnCount;
  finally
    FreeMem(OrigList);
    FreeMem(MergeList);
    FreeMem(PkgList);
    NodeMgr.Free;
  end;
end;
{====================================================================}

end.