unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, ExtCtrls, ComCtrls, StdCtrls,
BGRABitmap, BGRABitmapTypes, BGRAVirtualScreen;
const
MaxTests = 10; // Nombre total de test 0-9
type
{ TForm1 }
TForm1 = class(TForm)
BGRAVirtualScreen1: TBGRAVirtualScreen;
Button1: TButton;
Memo1: TMemo;
Timer1: TTimer;
procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
procedure DrawScene1(Bm: TBGRABitmap);
procedure DrawScene2(Bm: TBGRABitmap);
procedure DrawScene3(Bm: TBGRABitmap);
procedure DrawScene4(Bm: TBGRABitmap);
procedure DrawScene5(Bm: TBGRABitmap);
procedure DrawScene6(Bm: TBGRABitmap);
procedure DrawScene7(Bm: TBGRABitmap);
procedure DrawScene8(Bm: TBGRABitmap);
procedure DrawScene9(Bm: TBGRABitmap);
procedure DrawScene10(Bm: TBGRABitmap);
end;
var
Form1: TForm1;
Test : Integer;
TestElapsed: Integer;
LinesDrawn: Integer;
BenchElapsed: Integer;
implementation
{$R *.lfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
Test := -1;
TestElapsed := 0;
LinesDrawn := 0;
BenchElapsed := 0;
Timer1.Interval := 5;
Timer1.Enabled := False;
end;
procedure TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
begin
case Test of
0: DrawScene1(Bitmap);
1: DrawScene2(Bitmap);
2: DrawScene3(Bitmap);
3: DrawScene4(Bitmap);
4: DrawScene5(Bitmap);
5: DrawScene6(Bitmap);
6: DrawScene7(Bitmap);
7: DrawScene8(Bitmap);
8: DrawScene9(Bitmap);
9: DrawScene10(Bitmap);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
Test := 0;
TestElapsed := 0;
BenchElapsed := 0;
LinesDrawn := 0;
Timer1.Enabled := True;
BGRAVirtualScreen1.OnRedraw := @BGRAVirtualScreen1Redraw;
end;
// rnd lines
procedure TForm1.DrawScene1(Bm: TBGRABitmap);
var
T0: QWord;
x1, y1, x2, y2: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x1 := Random(Bm.Width);
y1 := Random(Bm.Height);
x2 := Random(Bm.Width);
y2 := Random(Bm.Height);
Bm.DrawLine(x1, y1, x2, y2, BGRA(Random(255), Random(255), Random(255)), False);
Inc(LinesDrawn);
end;
end;
// Hlines
procedure TForm1.DrawScene2(Bm: TBGRABitmap);
var
T0: QWord;
y: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
y := Random(Bm.Height);
Bm.DrawLine(0, y, Bm.Width, y, BGRA(Random(255), Random(255), Random(255)), False);
Inc(LinesDrawn);
end;
end;
// Vlines
procedure TForm1.DrawScene3(Bm: TBGRABitmap);
var
T0: QWord;
x: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x := Random(Bm.Width);
Bm.DrawLine(x, 0, x, Bm.Height, BGRA(Random(255), Random(255), Random(255)), False);
Inc(LinesDrawn);
end;
end;
// circles
procedure TForm1.DrawScene4(Bm: TBGRABitmap);
var
T0: QWord;
x, y, r: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x := Random(Bm.Width);
y := Random(Bm.Height);
r := Random(50) + 5;
Bm.EllipseAntialias(x, y, r, r, BGRA(Random(255), Random(255), Random(255)), 2);
Inc(LinesDrawn);
end;
end;
// rectangles
procedure TForm1.DrawScene5(Bm: TBGRABitmap);
var
T0: QWord;
x1, y1, x2, y2: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x1 := Random(Bm.Width);
y1 := Random(Bm.Height);
x2 := x1 + Random(100);
y2 := y1 + Random(100);
Bm.Rectangle(x1, y1, x2, y2, BGRA(Random(255), Random(255), Random(255)), dmDrawWithTransparency);
Inc(LinesDrawn);
end;
end;
// carrés
procedure TForm1.DrawScene6(Bm: TBGRABitmap);
var
T0: QWord;
x, y, size: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x := Random(Bm.Width);
y := Random(Bm.Height);
size := Random(80);
Bm.Rectangle(x, y, x + size, y + size, BGRA(Random(255), Random(255), Random(255)), dmDrawWithTransparency);
Inc(LinesDrawn);
end;
end;
// text
procedure TForm1.DrawScene7(Bm: TBGRABitmap);
var
T0: QWord;
x, y: Integer;
txt: string;
begin
Bm.Fill(BGRA(0, 0, 0));
Bm.FontHeight := 20;
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x := Random(Bm.Width - 100);
y := Random(Bm.Height - 30);
txt := 'TEST ' + IntToStr(Random(999));
Bm.TextOut(x, y, txt, BGRA(Random(255), Random(255), Random(255)));
Inc(LinesDrawn);
end;
end;
// rect plein
procedure TForm1.DrawScene8(Bm: TBGRABitmap);
var
T0: QWord;
x1, y1, x2, y2: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x1 := Random(Bm.Width);
y1 := Random(Bm.Height);
x2 := x1 + Random(100);
y2 := y1 + Random(100);
Bm.FillRect(x1, y1, x2, y2, BGRA(Random(255), Random(255), Random(255), 180));
Inc(LinesDrawn);
end;
end;
// carré plein !
procedure TForm1.DrawScene9(Bm: TBGRABitmap);
var
T0: QWord;
x, y, size: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x := Random(Bm.Width);
y := Random(Bm.Height);
size := Random(80);
Bm.FillRect(x, y, x + size, y + size, BGRA(Random(255), Random(255), Random(255), 180));
Inc(LinesDrawn);
end;
end;
// cercle plein
procedure TForm1.DrawScene10(Bm: TBGRABitmap);
var
T0: QWord;
x, y, r: Integer;
begin
Bm.Fill(BGRA(0, 0, 0));
T0 := GetTickCount64;
while (GetTickCount64 - T0 < 5) do
begin
x := Random(Bm.Width);
y := Random(Bm.Height);
r := Random(50) + 5;
Bm.FillEllipseAntialias(x, y, r, r, BGRA(Random(255), Random(255), Random(255), 180));
Inc(LinesDrawn);
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Inc(TestElapsed, Timer1.Interval);
BGRAVirtualScreen1.RedrawBitmap;
Inc(BenchElapsed, Timer1.Interval);
if BenchElapsed >= 1000 then
begin
Memo1.Lines.Add('Test :' + IntToStr(Test) + ' ' + IntToStr(LinesDrawn) + '/sec');
BenchElapsed := 0;
LinesDrawn := 0;
inc(Test);
end;
if Test >= MaxTests then
begin
Timer1.Enabled := False;
Memo1.Lines.Add('All Test Done !');
BGRAVirtualScreen1.OnRedraw := nil;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
end;
end.
Recent
