hdreclst.pas

RAY压缩是综合统计和字典方法

unit HdRecLst;

interface

uses
  SysUtils,Classes;

const
  hdeBase = $5444;
  hdePointerLongSize   = hdeBase + 0;
  hdeIndexOutOfBounds  = hdeBase + 1;
  hdeNilItem           = hdeBase + 2;
  hdeAtMaxCapacity     = hdeBase + 3;
  hdeCapacityTooLarge  = hdeBase + 4;
  hdeInvalidClassType  = hdeBase + 5;
  hdeListCannotDelete  = hdeBase + 6;
  hdeListCannotExamine = hdeBase + 7;
  hdeListInvalidIndex  = hdeBase + 8;
  hdeListIsNotSorted   = hdeBase + 9;
  hdeStackIsEmpty      = hdeBase + 10;
  hdeQueueIsEmpty      = hdeBase + 11;
  hdeInvalidNode       = hdeBase + 12;
  hdeTListIsNil        = hdeBase + 13;
  hdeTListInvalidRange = hdeBase + 14;
  hdeHashTblNoHashFunc = hdeBase + 15;
  hdeHashTblKeyNotFound= hdeBase + 16;
  hdeHashTblKeyExists  = hdeBase + 17;
  hdeHashTblIsFull     = hdeBase + 18;
  hdeHashTblNoCompare  = hdeBase + 19;
  hdeHashTblNoDir      = hdeBase + 20;
  hdeHashTblNoBuckets  = hdeBase + 21;
  hdeHashTblNoRecords  = hdeBase + 22;
  hdeHashTblDeletedBkt = hdeBase + 23;
  hdeHashTblDeletedRec = hdeBase + 24;
  hdeRSOutOfBounds     = hdeBase + 25;
  hdeRSAlreadyDeleted  = hdeBase + 26;
  hdeRSNoHeaderRec     = hdeBase + 27;
  hdeRSBadHeaderRec    = hdeBase + 28;
  hdeRSReadError       = hdeBase + 29;
  hdeRSSeekError       = hdeBase + 30;
  hdeRSWriteError      = hdeBase + 31;
  hdeRSRecIsDeleted    = hdeBase + 32;
  hdeRSFlushError      = hdeBase + 33;
  hdeRandRangeError    = hdeBase + 34;
  hdeSkpLstDupItem     = hdeBase + 35;
  hdeSkpLstItemMissing = hdeBase + 36;
  hdeSkpLstNoCompare   = hdeBase + 37;
  hdeBinTree2Children  = hdeBase + 38;
  hdeBinTreeHasChild   = hdeBase + 39;
  hdeBinTreeItemMissing= hdeBase + 40;
  hdeBinTreeDupItem    = hdeBase + 41;
  hdePriQueueNoCompare = hdeBase + 42;
  hdeLZNoAction        = hdeBase + 43;
  hdeLZEncodeBadMethod = hdeBase + 44;
  hdeLZDecodeBadMethod = hdeBase + 45;
  hdeLZSWBadWrite      = hdeBase + 46;
  hdeLZBadEncodedStream= hdeBase + 47;
  hdeLZProblemReading  = hdeBase + 48;
  hdeLZProblemWriting  = hdeBase + 49;
  hdeInStreamWrite     = hdeBase + 50;
  hdeInStreamRead      = hdeBase + 51;
  hdeOutStreamRead     = hdeBase + 52;
  hdeOutStreamWrite    = hdeBase + 53;
  hdeStreamBadOrigin   = hdeBase + 54;
  hdeOutStreamSeek     = hdeBase + 55;
  hdeInBitStreamRead   = hdeBase + 56;
  hdeOutBitStreamWrite = hdeBase + 57;
  hdeHuffBadEncodedStrm= hdeBase + 58;
  hdeSplyBadEncodedStrm= hdeBase + 59;
  hdeStateMisMatchQuote= hdeBase + 60;
  hdeStateBadCSV       = hdeBase + 61;
  hdeDequeIsEmpty      = hdeBase + 62;
  hdeRegexParseError   = hdeBase + 63;
  hdeNoStream          = hdeBase + 64;

type
  THdCompareFunc = function (aData1, aData2 : pointer) : integer;

type
  THdRecordList = class
    private
      FActElemSize : integer;           //记录实际大小
      FArray       : PAnsiChar;
      FCount       : integer;           //数量
      FCapacity    : integer;           //容量
      FElementSize : integer;           //记录在列表中占有的空间大小
      FIsSorted    : boolean;           //是否排序的
      FMaxElemCount: integer;           //最大记录数量
      FName        : TComponentName;
    protected
      function rlGetItem(aIndex : integer) : pointer;
      procedure rlSetCapacity(aCapacity : integer);
      procedure rlSetCount(aCount : integer);

      function rlBinarySearch(aItem    : pointer;
                              aCompare : THdCompareFunc;
                          var aInx     : integer) : boolean;
      procedure rlError(aErrorCode : integer;
                  const aMethodName : string;
                        aIndex      : integer);virtual;
      procedure rlExpand;

      procedure QuickSort(L, R: Integer; SCompare: THdCompareFunc);
    public
      constructor Create(aElementSize : integer);
      destructor Destroy; override;

      function Add(aItem : pointer) : integer;
      procedure Clear;
      procedure Delete(aIndex : integer);
      procedure Exchange(aIndex1, aIndex2 : integer);
      function First : pointer;
      function IndexOf(aItem    : pointer;
                       aCompare : THdCompareFunc) : integer;
      procedure Insert(aIndex : integer; aItem : pointer);
      function InsertSorted(aItem : pointer;
                            aCompare : THdCompareFunc) : integer;
      function Last : pointer;
      procedure Move(aCurIndex, aNewIndex : integer);
      function Remove(aItem    : pointer; aCompare : THdCompareFunc) : integer;
      function CheckSort(aCompare : THdCompareFunc):Boolean; 
      procedure Sort(aCompare : THdCompareFunc);

      property Capacity : integer read FCapacity write rlSetCapacity;
      property Count : integer read FCount write rlSetCount;
      property ElementSize : integer read FActElemSize;
      property UseElementSize : Integer read FElementSize;
      property IsSorted : boolean read FIsSorted;
      property Items[aIndex : integer] : pointer read rlGetItem; default;
      property MaxCount : integer read FMaxElemCount;
      property Name : TComponentName read FName write FName;
  end;

implementation

const
  UnitName = 'HdRecLst';

{===THdRecordList===================================================}
constructor THdRecordList.Create(aElementSize : integer);
//创建对象,初始化
begin
  inherited Create;
  {记录实际记录大小}
  FActElemSize := aElementSize;
  {让记录尺寸是4的倍数}
  FElementSize := ((aElementSize + 3) shr 2) shl 2;
  {计算最大容量}
  FMaxElemCount := MaxInt div integer(FElementSize);
  FIsSorted := True;
end;

{--------}
destructor THdRecordList.Destroy;
//释放对象
begin
  Capacity := 0;
  inherited Destroy;
end;

{--------}
function THdRecordList.Add(aItem : pointer) : integer;
//增加记录到末尾
begin
  Result := Count;
  Insert(Count, aItem);
end;

{--------}
procedure THdRecordList.Clear;
//清除所有记录
begin
  Count := 0;
  FIsSorted := True;
end;

{--------}
procedure THdRecordList.Delete(aIndex : integer);
//删除一个记录
begin
  if (aIndex < 0) or (aIndex >= Count) then
    rlError(hdeIndexOutOfBounds, 'Delete', aIndex);
  dec(FCount);
  if (aIndex < Count) then
    System.Move((FArray + (succ(aIndex) * FElementSize))^,
                (FArray + (aIndex * FElementSize))^,
                (Count - aIndex) * FElementSize);
  if (Count <= 1) then
    FIsSorted := True;
end;

{--------}
procedure THdRecordList.Exchange(aIndex1, aIndex2 : integer);
//交换两个记录
var
  i       : integer;
  Temp    : longint;
  FromPtr : PAnsiChar;
  ToPtr   : PAnsiChar;
begin
  if (aIndex1 < 0) or (aIndex1 > Count) then
    rlError(hdeIndexOutOfBounds, 'Exchange', aIndex1);
  if (aIndex2 < 0) or (aIndex2 > Count) then
    rlError(hdeIndexOutOfBounds, 'Exchange', aIndex2);
  FromPtr := FArray + (aIndex1 * FElementSize);
  ToPtr := FArray + (aIndex2 * FElementSize);
  for i := 0 to pred(FElementSize div 4) do begin
    Temp := PLongint(FromPtr)^;
    PLongint(FromPtr)^ := PLongint(ToPtr)^;
    PLongint(ToPtr)^ := Temp;
    inc(FromPtr, 4);
    inc(ToPtr, 4);
  end;
  FIsSorted := False;
end;

{--------}
function THdRecordList.First : pointer;
//第一条记录
begin
  Result := pointer(FArray);
end;

{--------}
function THdRecordList.IndexOf(aItem    : pointer;
                               aCompare : THdCompareFunc) : integer;
//索引
var
  ElementPtr : PAnsiChar;
  i          : integer;
begin
  {如果是排序的就用二分查找法,否则用顺序查找法}
  if IsSorted then begin
    if rlBinarySearch(aItem, aCompare, Result) then
      Exit;
  end
  else begin {do sequential search}
    ElementPtr := FArray;
    for i := 0 to pred(Count) do begin
      if (aCompare(aItem, ElementPtr) = 0) then begin
        Result := i;
        Exit;
      end;
      inc(ElementPtr, FElementSize);
    end;
  end;
  {未找到则索引为-1}
  Result := -1;
end;

{--------}
procedure THdRecordList.Insert(aIndex : integer; aItem : pointer);
//插入
begin
  if (aItem = nil) then
    rlError(hdeNilItem, 'Insert', aIndex);
  if (aIndex < 0) or (aIndex > Count) then
    rlError(hdeIndexOutOfBounds, 'Insert', aIndex);
  if (Count = Capacity) then
    rlExpand;
  if (aIndex < Count) then
    System.Move((FArray + (aIndex * FElementSize))^,
                (FArray + (succ(aIndex) * FElementSize))^,
                (Count - aIndex) * FElementSize);
  System.Move(aItem^,
              (FArray + (aIndex * FElementSize))^,
              FActElemSize);
  inc(FCount);
  FIsSorted := (Count = 1);
end;

{--------}
function THdRecordList.InsertSorted(aItem : pointer;
                                    aCompare : THdCompareFunc) : integer;
//排序插入
begin
  if not IsSorted then
    rlError(hdeListIsNotSorted, 'InsertSorted', 0);
  if not rlBinarySearch(aItem, aCompare, Result) then begin
    Insert(Result, aItem);
    FIsSorted := True;
  end;
end;

{--------}
function THdRecordList.Last : pointer;
//最后一条记录
begin
  Result := pointer(FArray + (pred(Count) * FElementSize));
end;

{--------}
procedure THdRecordList.Move(aCurIndex, aNewIndex : integer);
//移动记录
var
  Temp  : PByteArray;
begin
  if (aCurIndex < 0) or (aCurIndex >= Count) then
    rlError(hdeIndexOutOfBounds, 'Move', aCurIndex);
  if (aNewIndex < 0) or (aNewIndex >= Count) then
    rlError(hdeIndexOutOfBounds, 'Move', aNewIndex);
  if (aCurIndex <> aNewIndex) then begin
    {执行移动,步骤: (1) 保存当前记录, (2) 删除该记录
    (3)插入到新位置}
    GetMem(Temp, FElementSize);
    try
      System.Move((FArray + (aCurIndex * FElementSize))^,
                  Temp^,
                  FElementSize);
      Delete(aCurIndex);
      Insert(aNewIndex, Temp);
      FIsSorted := False;
    finally
      FreeMem(Temp, FElementSize);
    end;
  end;
end;

{--------}
function THdRecordList.rlBinarySearch(aItem    : pointer;
                                      aCompare : THdCompareFunc;
                                  var aInx     : integer) : boolean;
//二分查找
var
  L, R, M : integer;
  MPtr    : pointer;
  CompareResult : integer;
begin
  L := 0;
  R := pred(Count);
  while L <= R do begin
    M := (L + R) div 2;
    MPtr := pointer(FArray + (M * FElementSize));
    CompareResult := aCompare(MPtr, aItem);
    if (CompareResult < 0) then
      L := succ(M)
    else if (CompareResult > 0) then
      R := pred(M)
    else begin
      aInx := M;
      Result := True;
      Exit;
    end;
  end;
  aInx := L;
  Result := False;
end;

{--------}
procedure THdRecordList.rlError(aErrorCode  : integer;
                          const aMethodName : string;
                                aIndex      : integer);
//出错处理                                
begin
  if (Name = '') then
    Name := '-unnamed-';
  raise Exception.Create(Format('%d,%s:%s:%s:%s:%d',
    [aErrorCode,UnitName, ClassName, aMethodName, Name, aIndex]));
end;

{--------}
procedure THdRecordList.rlExpand;
//扩展容量
var
  NewCapacity : integer;
begin
  {如果当前容量为0,则设置新容量为4个记录的容量}
  if (Capacity = 0) then
    NewCapacity := 4
  {如果当前容量小于64,则增加16个记录}
  else if (Capacity < 64) then
    NewCapacity := Capacity + 16
  {如果当前容量大于64,则增加其四分之一}
  else
    NewCapacity := Capacity + (Capacity div 4);
  {检测是否超过最大容量}
  if (NewCapacity > FMaxElemCount) then begin
    NewCapacity := FMaxElemCount;
    if (NewCapacity = Capacity) then
      rlError(hdeAtMaxCapacity, 'rlExpand', 0);
  end;
  {设置新的容量}
  Capacity := NewCapacity;
end;

{--------}
function THdRecordList.rlGetItem(aIndex : integer) : pointer;
//获取元素
begin
  if (aIndex < 0) or (aIndex >= Count) then
    rlError(hdeIndexOutOfBounds, 'rlGetItem', aIndex);
  Result := pointer(FArray + (aIndex * FElementSize));
end;

{--------}
procedure THdRecordList.rlSetCapacity(aCapacity : integer);
//设置容量
begin
  if (aCapacity <> FCapacity) then begin
    {检查可能的最大记录数}
    if (aCapacity > FMaxElemCount) then
      rlError(hdeCapacityTooLarge, 'rlSetCapacity', 0);
    {分配数组,如果容量为0则释放}
    ReallocMem(FArray, aCapacity * FElementSize);
    {收缩容量}
    if (aCapacity < FCapacity) then begin
      if (Count > aCapacity) then
        Count := aCapacity;
    end;
    {保存新的容量数据}
    FCapacity := aCapacity;
  end;
end;

{--------}
procedure THdRecordList.rlSetCount(aCount : integer);
//设置数量
begin
  if (aCount <> FCount) then begin
    {如果新的数量大于容量,则增大容量}
    if (aCount > Capacity) then
      Capacity := aCount;
    {如果新数量大于旧数量,设置新记录为0}
    if (aCount > FCount) then begin
      FillChar((FArray + (FCount * FElementSize))^,
               (aCount - FCount) * FElementSize,
               0);
      FIsSorted := False;
    end;
    {保存新的数量}
    FCount := aCount;
  end;
end;

{--------}
function THdRecordList.Remove(aItem    : pointer;
                              aCompare : THdCompareFunc) : integer;
//移除对象
begin
  Result := IndexOf(aItem, aCompare);
  if (Result <> -1) then
    Delete(Result);
end;

{--------}
procedure THdRecordList.Sort(aCompare : THdCompareFunc);
//排序
begin
  QuickSort(0,Count-1,aCompare);
  FIsSorted:=True;
end;

procedure THdRecordList.QuickSort(L, R: Integer; SCompare: THdCompareFunc);
//快速排序
var
  I, J, P: Integer;
begin
  repeat
    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while SCompare(Items[I], Items[P]) < 0 do Inc(I);
      while SCompare(Items[J], Items[P]) > 0 do Dec(J);
      if I <= J then
      begin
        Exchange(I, J);
        if P = I then
          P := J
        else if P = J then
          P := I;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then QuickSort(L, J, SCompare);
    L := I;
  until I >= R;
end;

function THdRecordList.CheckSort(aCompare: THdCompareFunc): Boolean;
//检查是否排序的
var
  I:Integer;
begin
  FIsSorted:=True;
  Result:=True;
  for I:=0 to Count-2 do
  begin
    if aCompare(Items[I],Items[I+1])>0 then
    begin
      FIsSorted:=False;
      Result:=False;
      Break;
    end;
  end;
end;

{====================================================================}

end.