mainun.pas

俄罗斯出品的一个高效字符串操作的函数单元

unit MainUn;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, ExtCtrls;

type
  TMainForm = class(TForm)
    StatusBar: TStatusBar;
    btnClose: TButton;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    Button1_S: TButton;
    Button2_S: TButton;
    Button3_S: TButton;
    Button4_S: TButton;
    Button5_S: TButton;
    Button6_S: TButton;
    Button7_S: TButton;
    Button8_S: TButton;
    Bevel1: TBevel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Button1_R: TButton;
    Button2_R: TButton;
    Button3_R: TButton;
    Button4_R: TButton;
    Button5_R: TButton;
    Button6_R: TButton;
    Button7_R: TButton;
    Button8_R: TButton;
    procedure FormCreate(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure RadioButton1Click(Sender: TObject);
    procedure RadioButton2Click(Sender: TObject);
    procedure Button1_SClick(Sender: TObject);
    procedure Button2_SClick(Sender: TObject);
    procedure Button3_SClick(Sender: TObject);
    procedure Button4_SClick(Sender: TObject);
    procedure Button5_SClick(Sender: TObject);
    procedure Button6_SClick(Sender: TObject);
    procedure Button7_SClick(Sender: TObject);
    procedure Button8_SClick(Sender: TObject);
    procedure Button1_RClick(Sender: TObject);
    procedure Button2_RClick(Sender: TObject);
    procedure Button3_RClick(Sender: TObject);
    procedure Button4_RClick(Sender: TObject);
    procedure Button5_RClick(Sender: TObject);
    procedure Button6_RClick(Sender: TObject);
    procedure Button7_RClick(Sender: TObject);
    procedure Button8_RClick(Sender: TObject);
  private
    procedure AppIdle(Sender: TObject; var Done: Boolean);
    procedure Test1;
    procedure Test2;
    procedure Test3;
    procedure Test4;
    procedure Test5;
    procedure Test6;
    procedure Test7;
    procedure Test8;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

uses ShareMem, ShareQmm;

{$R *.DFM}

var
  A: array[1..1000] of Pointer;

  StdAllocSize: Integer;
  IsStdManager: Boolean = False;
  Sequential: Boolean;

procedure TMainForm.AppIdle(Sender: TObject; var Done: Boolean);
begin
  QMemDecommitOverstock;
  StatusBar.Panels[0].Text := 'QMemTotalAllocated = '+IntToStr(QMemTotalAllocated);
  StatusBar.Panels[1].Text := 'System.GetAllocMemSize = '+IntToStr(StdAllocSize);
end;

const
  StdManager: TMemoryManager = (
    GetMem: SysGetMem;
    FreeMem: SysFreeMem;
    ReallocMem: SysReallocMem);
var
  QMemManager: TMemoryManager;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  GetMemoryManager(QMemManager);
  StdAllocSize := GetAllocMemSize;
  Application.OnIdle := AppIdle;
  Randomize;
end;

procedure TMainForm.btnCloseClick(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.RadioButton1Click(Sender: TObject);
begin
  IsStdManager := False;
end;

procedure TMainForm.RadioButton2Click(Sender: TObject);
begin
  IsStdManager := True;
end;

procedure TMainForm.Test1;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(10)+1);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        K := Random(1000)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(10)+1);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 1000 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Test2;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(100)+1);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        K := Random(1000)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(100)+1);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 1000 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Test3;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(1000)+1);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        K := Random(1000)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(1000)+1);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 1000 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Test4;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(4096)+1);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        K := Random(1000)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(4096)+1);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 1000 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Test5;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(10000)+1);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        K := Random(1000)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(10000)+1);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 1000 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Test6;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(5903)+4097);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 1000 do
      begin
        K := Random(1000)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(5903)+4097);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 1000 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Test7;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 100 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(100000)+1);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 100 do
      begin
        K := Random(100)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(100000)+1);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 100 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Test8;
var
  I,J,K: Integer;
  D: LongWord;
begin
  if IsStdManager then
    SetMemoryManager(StdManager);
  FillChar(A,SizeOf(A),0);
  D := GetTickCount;
  if Sequential then
    for I := 1 to 1000 do
      for J := 1 to 30 do
      begin
        FreeMem(A[J]);
        GetMem(A[J],Random(1000000)+1);
      end
  else
    for I := 1 to 1000 do
      for J := 1 to 30 do
      begin
        K := Random(30)+1;
        FreeMem(A[K]);
        GetMem(A[K],Random(1000000)+1);
      end;
  D := GetTickCount-D;
  if IsStdManager then
  begin
    StdAllocSize := GetAllocMemSize;
    SetMemoryManager(QMemManager);
  end;
  ShowMessage('Array filled in '+IntToStr(D)+' ms');
  for J := 1 to 30 do
    FreeMem(A[J]);
  StdAllocSize := GetAllocMemSize;
end;

procedure TMainForm.Button1_SClick(Sender: TObject);
begin
  Sequential := True;
  Test1;
end;

procedure TMainForm.Button2_SClick(Sender: TObject);
begin
  Sequential := True;
  Test2;
end;

procedure TMainForm.Button3_SClick(Sender: TObject);
begin
  Sequential := True;
  Test3;
end;

procedure TMainForm.Button4_SClick(Sender: TObject);
begin
  Sequential := True;
  Test4;
end;

procedure TMainForm.Button5_SClick(Sender: TObject);
begin
  Sequential := True;
  Test5;
end;

procedure TMainForm.Button6_SClick(Sender: TObject);
begin
  Sequential := True;
  Test6;
end;

procedure TMainForm.Button7_SClick(Sender: TObject);
begin
  Sequential := True;
  Test7;
end;

procedure TMainForm.Button8_SClick(Sender: TObject);
begin
  Sequential := True;
  Test8;
end;

procedure TMainForm.Button1_RClick(Sender: TObject);
begin
  Sequential := False;
  Test1;
end;

procedure TMainForm.Button2_RClick(Sender: TObject);
begin
  Sequential := False;
  Test2;
end;

procedure TMainForm.Button3_RClick(Sender: TObject);
begin
  Sequential := False;
  Test3;
end;

procedure TMainForm.Button4_RClick(Sender: TObject);
begin
  Sequential := False;
  Test4;
end;

procedure TMainForm.Button5_RClick(Sender: TObject);
begin
  Sequential := False;
  Test5;
end;

procedure TMainForm.Button6_RClick(Sender: TObject);
begin
  Sequential := False;
  Test6;
end;

procedure TMainForm.Button7_RClick(Sender: TObject);
begin
  Sequential := False;
  Test7;
end;

procedure TMainForm.Button8_RClick(Sender: TObject);
begin
  Sequential := False;
  Test8;
end;

end.