customsimplelist.pas

Delphi中一直都没有能快速显示彩色文字信息的Memo控件而TRichEdit慢得无法在需要高速的场合使用

{*********************************************************}
{                 TCustomSimpleList v1.2                  }
{ Copyright (c) 2008 Zhang jin-song                       }
{ License : Free                                          }
{ www.ynu.edu.cn                                          }
{*********************************************************}

unit CustomSimpleList;
{$R-,T-,X+,H+,B-}

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TcsListCompare = function(Item1, Item2: Pointer): Integer of Object;

  TCustomSimpleList = class(TObject)
  private
    FPList: PPointerList;
    FCount: Integer;
    FCapacity: Integer;
    FMemoryGrowSize : Longint;    
    FCSLCompare : TcsListCompare;
    procedure Grow;
    procedure SetCount(NewCount: Integer);
    procedure SetCapacity(NewCapacity: Integer);
  protected
    procedure QuickSort(L, R: Integer); virtual;
    function  slAdd(Item: Pointer): Integer;
    function  slGet(Index: Integer): Pointer;
    procedure slPut(Index: Integer; Item: Pointer);
    procedure slInsert(Index: Integer; Item: Pointer);
    procedure slAssign(AList: TCustomSimpleList);
    procedure slClear;
    procedure slClearNilItem;
    procedure slSort;
    //
    procedure Delete(Index: Integer); virtual;
    function SortCompare(Item1, Item2: Pointer): Integer; virtual;
    property ICapacity : Integer write SetCapacity;
    property ICount : Integer read FCount write FCount;
    property IPList : PPointerList read FPList;
  public
    constructor Create(MemoryGrowSize: Longint; AOwner: TObject); virtual;
    destructor Destroy; override;
    class procedure Error(const Msg: string; Data: Integer); overload; virtual;
    class procedure Error(Msg: PResStringRec; Data: Integer); overload;
    property CSLCompare : TcsListCompare read FCSLCompare write FCSLCompare;
    property Count : Integer read FCount;
  end;

resourcestring
csListIndexError = 'CustomSimpleList index out of bounds (%d)';

implementation

resourcestring
csListCapacityError = 'CustomSimpleList capacity out of bounds (%d)';
csListCountError = 'CustomSimpleList count out of bounds (%d)';

const
CMinMemoryGrowSize = 10;
CMaxSimpleListSize = Maxint div 16;

class procedure TCustomSimpleList.Error(const Msg: string; Data: Integer);
 function ReturnAddr: Pointer;
 asm
  MOV EAX,[EBP+4]
 end;
begin
 raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr;
end;

class procedure TCustomSimpleList.Error(Msg: PResStringRec; Data: Integer);
begin
 TCustomSimpleList.Error(LoadResString(Msg), Data);
end;

procedure TCustomSimpleList.Grow;
begin
 SetCapacity(FCapacity + FMemoryGrowSize);
end;

procedure TCustomSimpleList.SetCapacity(NewCapacity: Integer);
begin
 if (NewCapacity < FCount) or (NewCapacity > CMaxSimpleListSize) then
  Error(@csListCapacityError, NewCapacity);
 if NewCapacity <> FCapacity then
 begin
  ReallocMem(FPList, NewCapacity * SizeOf(Pointer));
  FCapacity := NewCapacity;
 end;
end;

procedure TCustomSimpleList.SetCount(NewCount: Integer);
var
  I: Integer;
begin
 if (NewCount < 0) or (NewCount > CMaxSimpleListSize) then
  Error(@csListCountError, NewCount);
 if NewCount > FCapacity then SetCapacity(NewCount);
 if NewCount > FCount then
  FillChar(FPList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0)
 else
  for I := FCount - 1 downto NewCount do Delete(I);
 FCount := NewCount;
end;

function TCustomSimpleList.slGet(Index: Integer): Pointer;
begin
 if (Index < 0) or (Index >= FCount) then Error(@csListIndexError, Index);
 Result := FPList^[Index];
end;

procedure TCustomSimpleList.slPut(Index: Integer; Item: Pointer);
begin
 if (Index < 0) or (Index >= FCount) then Error(@csListIndexError, Index);
 FPList^[Index] := Item;
end;

procedure TCustomSimpleList.slAssign(AList: TCustomSimpleList);
var
I: Integer;
begin
 slClear;
 SetCapacity(AList.FCount);
 for I := 0 to AList.Count - 1 do slAdd(AList.slGet(I));
end;

procedure TCustomSimpleList.slClear;
begin
 SetCount(0);
 SetCapacity(0);
end;

procedure TCustomSimpleList.slClearNilItem;
var
I: Integer;
begin
 for I := FCount - 1 downto 0 do
  if slGet(I) = nil then Delete(I);
end;

function TCustomSimpleList.slAdd(Item: Pointer): Integer;
begin
 Result := FCount;
 if Result >= FCapacity then Grow;
 FPList^[Result] := Item;
 Inc(FCount);
end;

procedure TCustomSimpleList.slInsert(Index: Integer; Item: Pointer);
begin
 if (Index < 0) or (Index > FCount) then Error(@csListIndexError, Index);
 if FCount >= FCapacity then Grow;
 if Index < FCount then
  System.Move(FPList^[Index], FPList^[Index + 1],(FCount - Index) * SizeOf(Pointer));
 FPList^[Index] := Item;
 Inc(FCount);
end;

procedure TCustomSimpleList.Delete(Index: Integer);
var
Temp: Pointer;
begin
 if (Index < 0) or (Index >= FCount) then Error(@csListIndexError, Index);
 Temp := slGet(Index);
 //--------------------------------------------
 // free Temp pointer of class
 //--------------------------------------------
 Dec(FCount);
 if Index < FCount then
  System.Move(FPList^[Index + 1], FPList^[Index],(FCount - Index) * SizeOf(Pointer));
end;

// if Item1 < Item2 then Result > 0 (return positive)
// if Item1 = Item2 then Result = 0
// if Item1 > Item2 then Result < 0 (return negative)
function TCustomSimpleList.SortCompare(Item1, Item2: Pointer): Integer;
begin
 Result := 0;
end;

procedure TCustomSimpleList.QuickSort(L, R: Integer);
var
I,J: Integer;
P,T: Pointer;
begin
 repeat
  I := L;
  J := R;
  P := FPList^[(L + R) shr 1];
  repeat
   if Assigned(FCSLCompare) then
   begin
    while FCSLCompare(FPList^[I], P) < 0 do Inc(I);
    while FCSLCompare(FPList^[J], P) > 0 do Dec(J);
   end else begin
    while SortCompare(FPList^[I], P) < 0 do Inc(I);
    while SortCompare(FPList^[J], P) > 0 do Dec(J);
   end;
   if I <= J then
   begin
    T := FPList^[I];
    FPList^[I] := FPList^[J];
    FPList^[J] := T;
    Inc(I);
    Dec(J);
   end;
  until I > J;
  if L < J then QuickSort(L,J);
  L := I;
 until I >= R;
end;

procedure TCustomSimpleList.slSort;
begin
 if (FPList <> nil) and (Count > 1) then QuickSort(0,Count - 1);
end;

constructor TCustomSimpleList.Create(MemoryGrowSize: Longint; AOwner: TObject);
begin
 FCSLCompare := nil;
 if MemoryGrowSize < CMinMemoryGrowSize then
  FMemoryGrowSize := CMinMemoryGrowSize
 else
  FMemoryGrowSize := MemoryGrowSize;
 FCount := 0;
 FCapacity := 0;
end;

destructor TCustomSimpleList.Destroy;
begin
 slClear;
end;


end.