Delphi.cz

Český portál Delphi

Anonymní metody a TCustomCanvas

Anonymní metody jsou silně nedoceněnou vlastností nových Delphi.

Jen pro zajímavost jsem orientačně porovnával rychlost TDirect2DCanvas a TCanvas. Při té příležitosti jsem narazil na problém jehož řešení velmi zjednodušilo použití anonymních metod.

Laskavý čtenář si podrobnosti o obou tématech najde za pomoci tagu dole, já jen připomenu TDirect2DCanvas je od Delphi 2010 a anonymní metody od Delphi 2009.

TDirect2DCanvas a TCanvas jsou následníkem TCustomCanvas, kterážto třída obsahuje většinu metod (abstractních) dříve definovaných přímo v TCanvas. Bohužel neobsahuje TPen a některé další property, už jen z toho důvodu, že implementačně je to dost odlišné. Příslušné property obsahují následníci, čímž zachovávají rozhraní aspoň pro kompilaci. Než bych zduplikoval testovací metodu tak jsem raději použil anonymní metodu pro nastavení barvy pera.

Z mého hlediska to bylo těžší, jelikož jsem potřeboval mít stejnou metodu pro kreslení, kterou bych jednou provedl pro klasické GDI TCanvas a podruhé pro HW akcelerované TDirect2DCanvas. Připomínám, že druhé je dostupné na Windows 7 a pravděpodobně Vista - což mimochodem znamená, že jsem konečně přešel z Windows XP SP3 na Windows 7 64bit jako svůj primární OS (používám tam Delphi 5, Delphi 2007 s 64bit patchem - už se to zde probíralo - a Delphi XE).

TDirect2DCanvas

Společná testovací metoda (viz listing) je

procedure mPaint(c:TCustomCanvas; xMax, yMax: Integer; SetColor:TSetColorProc);

kde SetColor je anonymní metoda

type
  TSetColorProc = reference to procedure (color: TColor);

všimněte si prosím ve výpisu jak se mPaint volá

    mPaint(LD2DCanvas, ClientRect.Right, ClientRect.Bottom,
      procedure (c:TColor)
      begin
        LD2DCanvas.Pen.Color := c;
      end
      );

pro upřesnění: LD2DCanvas.Pen je platné v místě volání mPaint, ale už není platné v těle metody. Kompilátor to přeloží zhruba jako proceduru, kde budou absolutní odkazy do správné struktury a do volané procedury předá jen referenci na tuto "dočasnou" proceduru.

V těle metody mPaint se programátor odkazuje na anonymní metodu a vše je OK.

No a pro zajímavost výsledek testu:

  • kreslení GDI (tj. std. TCanvas) - cca 220ms silně závisející na rozlišení (100 - 700ms)
  • kreslení Direct2D (TDirect2DCanvas) - 16ms bez závislosti na rozlišení (první volání 200ms z IDE, bez IDE 40ms)

Tj. druhá možnost je řádově rychlejší bez závislosti na rozlišení. Zbytek programu jsou jen opičky kolem.

zdrojové kódy a přeložená aplikace (0.5M)

Výpis programu

unit Unit1;

interface

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

type
  TSetColorProc = reference to procedure (color: TColor);
  TModePaint = (mpNone, mpGDI, mpDirect2D);

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    GDI1: TMenuItem;
    Direct2D1: TMenuItem;
    procedure GDI1Click(Sender: TObject);
    procedure Direct2D1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    mp: TModePaint;
    procedure mPaint(c:TCustomCanvas; xMax, yMax: Integer; SetColor:TSetColorProc);
    procedure Draw2D;
    procedure DrawGDI;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
uses
  D2D1, Diagnostics;
{$R *.dfm}

procedure TForm1.Direct2D1Click(Sender: TObject);
begin
  mp := mpDirect2D;
  invalidate;
end;

procedure TForm1.Draw2D;
var
  LD2DCanvas: TDirect2DCanvas;
begin
  LD2DCanvas := TDirect2DCanvas.Create(Canvas, ClientRect);
  with LD2DCanvas do
  try
    Font.Name := Canvas.Font.Name;
    Font.Size := Canvas.Font.Size;
    Font.Style := Canvas.Font.Style;
    Font.Pitch := Canvas.Font.Pitch;
    Font.Orientation := Canvas.Font.Orientation;
    RenderTarget.BeginDraw;

    pen.Width := 1;
    Brush.Style := bsClear;
    LD2DCanvas.Brush.Style := bsSolid;
    LD2DCanvas.Brush.Color := clWhite;

    RenderTarget.Clear(D2D1ColorF(1.0,1.0,1.0,1.0));
//    RenderTarget.SetAntialiasMode(D2D1_ANTIALIAS_MODE_PER_PRIMITIVE);
      RenderTarget.SetAntialiasMode(D2D1_ANTIALIAS_MODE_ALIASED);

    mPaint(LD2DCanvas, ClientRect.Right, ClientRect.Bottom,
      procedure (c:TColor)
      begin
        LD2DCanvas.Pen.Color := c;
      end
      );
    RenderTarget.EndDraw;
  finally
    ld2dcanvas.free;
  end;
end;

procedure TForm1.DrawGDI;
begin
  with Canvas do
  try
    Font.Name := Canvas.Font.Name;
    Font.Size := Canvas.Font.Size;
    Font.Style := Canvas.Font.Style;
    Font.Pitch := Canvas.Font.Pitch;
    Font.Orientation := Canvas.Font.Orientation;

    Lock;

    pen.Width := 1;
    Brush.Style := bsClear;
    Brush.Style := bsSolid;
    Brush.Color := clWhite;

    mPaint(Canvas, ClientRect.Right, ClientRect.Bottom,
      procedure (c:TColor)
      begin
        Canvas.Pen.Color := c;
      end
      );
  finally
    Unlock;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if not TDirect2DCanvas.Supported then
  begin
     ShowMessage('Direct2D není podporován!');
  end;

  mp := mpNone;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  mp1: TModePaint;
begin
  mp1 := mp;
  mp := mpNone;
  case mp1 of
    mpNone: ;
    mpGDI: DrawGDI;
    mpDirect2D: Draw2D;
  end;
end;

procedure TForm1.GDI1Click(Sender: TObject);
begin
  mp := mpGDI;
  invalidate;
end;

procedure TForm1.mPaint(c: TCustomCanvas; xMax, yMax: Integer; SetColor:TSetColorProc);
var
  sw: TStopWatch;
  i: Integer;
begin
  sw:= TStopwatch.Create;
  sw.Start;
  RandSeed := 1000;
  for i := 0 to 10000 do
  begin
    SetColor(RGB(Random(255), Random(255), Random(255)));
    c.MoveTo(Random(xMax), Random(yMax));
    c.LineTo(Random(xMax), Random(yMax));
  end;
  sw.Stop;
  c.FillRect(Rect(100, 100, 100, 100));
  c.TextOut(100, 100, IntToStr(sw.ElapsedMilliseconds));

end;
end.

Datum: 2011-03-25 23:20:00 Tagy: Delphi 2010, VCL, Direct2D, grafika, anonymni metody

Novinky v Delphi