AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren

Performanceproblem mit Firemonkey

Ein Thema von Peter666 · begonnen am 15. Okt 2019 · letzter Beitrag vom 21. Okt 2019
Antwort Antwort
Seite 1 von 2  1 2   
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#1

Performanceproblem mit Firemonkey

  Alt 15. Okt 2019, 18:23
Hi,

ich habe hier ein ziemliches Performanceproblem mit Canvas in Firemonkey. Für eine Anzeige erstelle ich ungefähr 20 eigene Tiles die aus 2 Bildern bestehen. Einmal, wenn die Komponente den Fokus hat und einmal, wenn sie keinen Fokus hat.
Die Erstellung der 40 Bilder dauert auf einem Androiden 10 Sekunden. Auch unter Windows ist das ganze schnarchend langsam. Der Code für die Darstellung befindet sich hier unten. Der komplette Beispielcode ist im Anhang. Ich glaube der Flaschenhals ist FillRect und die Textausgabe. Wie dem auch seih kann ich mir nicht vorstellen, dass man den DefaultRenderItem Code nicht irgendwie beschleunigen kann.In einem separaten Thread/Task kann ich das ganze nicht rendern.

Delphi-Quellcode:
procedure TForm3.DefaultRenderItem(const ACanvas: TCanvas; const ARect: TRectF;
  const AImage: TBitmap; const ASelected: Boolean);
var
  i: Integer;
  TH: single;
  ABoundsRect: TRectF;
  R: TRectF;
begin
  ABoundsRect := ARect;
  with ACanvas do
  begin
    BeginScene(nil);
    try
      // Shadow - there are much nicer ways to draw a shadow
      ClearRect(ARect);

      Stroke.Kind := TBrushkind.Solid;
      Stroke.Color := TAlphaColorRec.Black;
      for i := 0 to 5 do
      begin
        DrawRect(ABoundsRect, 5, 5, AllCorners, i / 100);;
        ABoundsRect := RectF(ABoundsRect.Left + 1, ABoundsRect.Top + 1,
          ABoundsRect.Right - 1, ABoundsRect.Bottom - 1);
      end;
      Stroke.Kind := TBrushkind.None;
      Fill.Kind := TBrushkind.Solid;
      Fill.Color := cCardBackgroundColor;
      FillRect(ABoundsRect, 0*5, 0*5, AllCorners, 1);

      TH := ABoundsRect.Height / 3;
      if assigned(AImage) then
      begin
        R := RectF(ABoundsRect.Left, 0, ABoundsRect.Right,
          ABoundsRect.Bottom - TH);

        Fill.Bitmap.Bitmap.Assign(AImage);
        Fill.Bitmap.WrapMode := TWrapMode.TileStretch;
        Fill.Kind := TBrushkind.Bitmap;
        FillRect(R, 5, 5, [TCorner.TopLeft, TCorner.TopRight], 1);
      end;

      R := RectF(ABoundsRect.Left, ABoundsRect.Bottom - TH, ABoundsRect.Right,
        ABoundsRect.Bottom);

      Fill.Kind := TBrushkind.Solid;
      if ASelected then
        Fill.Color := cCardDescription
      else
        Fill.Color := cCardDescriptionFocus;

      FillRect(R, 5, 5, [TCorner.BottomLeft, TCorner.BottomRight], 1);

      R := RectF(R.Left + 10, R.Top, R.Right - 10,
        R.Top + (R.Bottom - R.Top) / 2);

      Font.Family := cGridFont;
      Font.Size := FScreenScale * 15;
      Font.Style := [TFontStyle.fsBold];
      Fill.Color := TAlphaColorRec.White;

      if FTitle <> 'then
        FillText(R, FTitle, false, 1, [], TTextAlign.Leading,
          TTextAlign.Center);

      if FDescription <> 'then
      begin
        R.Offset(0, R.Height);
        Font.Style := [];
        FillText(R, FDescription, false, 0.8, [], TTextAlign.Leading,
          TTextAlign.Leading);
      end;
    finally
      EndScene;
    end;
  end;
end;
Angehängte Dateien
Dateityp: zip performance.zip (2,1 KB, 5x aufgerufen)
  Mit Zitat antworten Zitat
Rollo62

Registriert seit: 15. Mär 2007
3.882 Beiträge
 
Delphi 12 Athens
 
#2

AW: Performanceproblem mit Firemonkey

  Alt 15. Okt 2019, 19:10
Mir erschliesst sich nicht ganz was Du da machst.
Wozu die Schleife 1000 mal, und darin das Bitmal erzeugen löschen ?
Delphi-Quellcode:
    Image := TBitmap.Create;
    try
      Target.Free;

      ...


    finally
      Image.Free;
    end;
  Mit Zitat antworten Zitat
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#3

AW: Performanceproblem mit Firemonkey

  Alt 15. Okt 2019, 20:39
Eigentlich wird das erstellen der Grafik in jeder Tcomponent Klasse gemacht. Das hab ich jetzt so nur erstellt, weil ich die ganze Komponente nicht mit dazupacken wollte.
  Mit Zitat antworten Zitat
hoika

Registriert seit: 5. Jul 2006
Ort: Magdeburg
8.269 Beiträge
 
Delphi 10.4 Sydney
 
#4

AW: Performanceproblem mit Firemonkey

  Alt 15. Okt 2019, 21:13
Hallo,
ich würde so vorgehen.

1. Wie oft wird DefaultRenderItem aufgerufen, kann man die Aufrufe verringern?
2. Schrittweise Code aus DefaultRenderItem ausblenden und Testen.

0. Einen Profiler benutzen, um 1. rauszubekommen.
Heiko
  Mit Zitat antworten Zitat
Michael II
Online

Registriert seit: 1. Dez 2012
Ort: CH BE Eriswil
703 Beiträge
 
Delphi 11 Alexandria
 
#5

AW: Performanceproblem mit Firemonkey

  Alt 16. Okt 2019, 06:57
Ich habe deinen Code runtergeladen und auf meinem alten Notebook (Prozessor Intel(R) Core(TM) i7-3632QM CPU @ 2.20GHz, 2201 MHz, 4 Kern(e), 8 logische(r) Prozessor(en)) unter Win10 18362, Delphi 10.3.2 gestartet.

Es dauert immer ziemlich genau zwei Sekunden, d.h. pro

Delphi-Quellcode:
      Target := TBitmap.Create(180, 144);
      DefaultRenderItem(Target.Canvas, Target.BoundsF, Image, false);
      Target.Free;
rund 1 Millisekunde.

Welche Werte erwartest du?
Michael Gasser
  Mit Zitat antworten Zitat
Benutzerbild von Mavarik
Mavarik

Registriert seit: 9. Feb 2006
Ort: Stolberg (Rhld)
4.123 Beiträge
 
Delphi 10.3 Rio
 
#6

AW: Performanceproblem mit Firemonkey

  Alt 16. Okt 2019, 09:02
rund 1 Millisekunde.
Ohh gut, dann brauche ich es ja nicht zu testen. Hätte mich auch gewundert.
  Mit Zitat antworten Zitat
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#7

AW: Performanceproblem mit Firemonkey

  Alt 16. Okt 2019, 10:00
Unter Android dauert es knapp 10 Sekunden für 30 Tiles. Das ist definitiv inakzeptabel. Die beiden Grafiken werden beim OnPaint Event erstellt.

Delphi-Quellcode:
TTileItem = class(TControl)
  protected
    FScreenScale: Single;
    FLastUpdate: Cardinal;
    FZoomFactor: Single;
    FBackgroundColor: TAlphaColor;
    FNeedUpdate: Boolean;

    FOldPositionX: Single;
{$IFDEF BACKBUFFER}
{$IFDEF USEGPU}
    FSelected: TTexture;
    FNormal: TTexture;
{$ELSE}
    FSelected: TBitmap;
    FNormal: TBitmap;
{$ENDIF}
{$ELSE}
    FImage: TBitmap;
{$ENDIF}
    FActive: Boolean;

    FOnBeforePaint: TNotifyEvent;

    FTitle: String;
    FDescription: String;

    FImageFile: String;
    FUpdateImage: Boolean;
    FLocalImage: String;

{$IFDEF USEZIP}
    FZipFile: TZipFile;
{$ENDIF}
    procedure DoOnDownloadComplete(AFileName: string; AAvailable: Boolean);
    procedure Paint; override;
    procedure DoEnter; override;
    procedure DoExit; override;

    procedure SetZoomFactor(AValue: Single);
    procedure SetBackgroundColor(AValue: TAlphaColor);
    procedure SetString(Aindex: Integer; AValue: String);

    procedure DefaultRenderItem(ACanvas: TCanvas; ARect: TRectF;
      AImage: TBitmap; ASelected: Boolean); virtual;
    procedure Resize; override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function PerformUpdate: Boolean;
  published
    property BackgroundColor: TAlphaColor read FBackgroundColor
      write SetBackgroundColor;
    property ZoomFactor: Single read FZoomFactor write SetZoomFactor;
    property Title: String index 0 read FTitle write SetString;
    property Description: String index 1 read FDescription write SetString;
    property ImageFile: String index 2 read FImageFile write SetString;

{$IFDEF USEZIP}
    property ZipFile: TZipFile read FZipFile write FZipFile;
{$ENDIF}
    property OnBeforePaint: TNotifyEvent read FOnBeforePaint
      write FOnBeforePaint;
    property LastUpdate: Cardinal read FLastUpdate write FLastUpdate;
  end;
...
{ TTileItem }
constructor TTileItem.Create(AOwner: TComponent);
begin
  inherited;
  CanFocus := true;
  ZoomFactor := 0;
  FBackgroundColor := TAlphaColors.Gray;
{$IFDEF BACKBUFFER}
{$IFNDEF USEGPU}
  FSelected := TBitmap.Create;
  FNormal := TBitmap.Create;
{$ENDIF}
  FScreenScale := GetScreenScale;
{$ELSE}
  FScreenScale := 1;
{$ENDIF}
  FNeedUpdate := true;
end;

destructor TTileItem.Destroy;
begin
{$IFDEF BACKBUFFER}
  FreeAndNil(FSelected);
  FreeAndNil(FNormal);
{$ELSE}
  FreeAndNil(FImage);
{$ENDIF}
  inherited;
end;

procedure TTileItem.SetString(Aindex: Integer; AValue: String);
begin
  case Aindex of
    0:
      begin
        FNeedUpdate := FNeedUpdate or (FTitle <> AValue);
        FTitle := AValue;
      end;
    1:
      begin
        FNeedUpdate := FNeedUpdate or (FDescription <> AValue);
        FDescription := AValue;
      end;
    2:
      begin
        if FImageFile <> AValue then
        begin
          FUpdateImage := FImageFile <> AValue;
          FImageFile := AValue;
        end;
      end;
  end;
end;

procedure TTileItem.DoEnter;
var
  dx: Single;
begin
  inherited;
  FActive := true;
  BringToFront;

  dx := (Width - cZoomIn * Width) / 2;
  FOldPositionX := Position.X;
  TAnimator.AnimateFloat(self, 'ZoomFactor', cZoomOut, cZoomTime,
    TAnimationType.Out, TInterpolationType.Quadratic);

  TAnimator.AnimateFloat(self, 'Position.X', Position.X - dx, cZoomTime,
    TAnimationType.Out, TInterpolationType.Quadratic);

  if Owner is TTileRow then
    TTileRow(Owner).ScrollIntoView(self);
end;

procedure TTileItem.DoExit;
begin
  inherited;
  FActive := False;
  SendToBack;
  TAnimator.AnimateFloat(self, 'Position.X', FOldPositionX, cZoomTime,
    TAnimationType.Out, TInterpolationType.Quadratic);

  TAnimator.AnimateFloat(self, 'ZoomFactor', cZoomIn, cZoomTime, TAnimationType.
    In, TInterpolationType.Linear);
end;

procedure TTileItem.SetBackgroundColor(AValue: TAlphaColor);
begin
  if FBackgroundColor <> AValue then
  begin
    FBackgroundColor := AValue;
    repaint;
  end;
end;

procedure TTileItem.SetZoomFactor(AValue: Single);
begin
  if AValue < cZoomIn then
    AValue := cZoomIn;
  if AValue > cZoomOut then
    AValue := cZoomOut;

  if FZoomFactor <> AValue then
  begin
    FZoomFactor := AValue;
    repaint;
  end;
end;

procedure TTileItem.Resize;
begin
  inherited;
  FNeedUpdate := true;
end;

procedure TTileItem.DefaultRenderItem(ACanvas: TCanvas; ARect: TRectF;
  AImage: TBitmap; ASelected: Boolean);
var
  i: Integer;
  TH: Single;
  ABoundsRect: TRectF;
  R: TRectF;
begin
  ABoundsRect := ARect;
  with ACanvas do
  begin
    BeginScene(nil);
    try
      // Shadow - there are much nicer ways to draw a shadow
      ClearRect(ARect);

      Stroke.Kind := TBrushkind.Solid;
      Stroke.Color := TAlphaColorRec.Black;
      for i := 0 to 5 do
      begin
        DrawRect(ABoundsRect, 5, 5, AllCorners, i / 100);;
        ABoundsRect := RectF(ABoundsRect.Left + 1, ABoundsRect.Top + 1,
          ABoundsRect.Right - 1, ABoundsRect.Bottom - 1);
      end;
      Stroke.Kind := TBrushkind.None;
      Fill.Kind := TBrushkind.Solid;
      Fill.Color := cCardBackgroundColor;
      FillRect(ABoundsRect, 5, 5, AllCorners, 1);

      TH := ABoundsRect.Height / 3;
      if assigned(AImage) then
      begin
        R := RectF(ABoundsRect.Left, 0, ABoundsRect.Right,
          ABoundsRect.Bottom - TH);

        Fill.Bitmap.Bitmap.Assign(AImage);
        Fill.Bitmap.WrapMode := TWrapMode.TileStretch;
        Fill.Kind := TBrushkind.Bitmap;
        FillRect(R, 5, 5, [TCorner.TopLeft, TCorner.TopRight], 1);
      end;

      R := RectF(ABoundsRect.Left, ABoundsRect.Bottom - TH, ABoundsRect.Right,
        ABoundsRect.Bottom);

      Fill.Kind := TBrushkind.Solid;
      if ASelected then
        Fill.Color := cCardDescription
      else
        Fill.Color := cCardDescriptionFocus;

      FillRect(R, 5, 5, [TCorner.BottomLeft, TCorner.BottomRight], 1);

      R := RectF(R.Left + 10, R.Top, R.Right - 10,
        R.Top + (R.Bottom - R.Top) / 2);

      Font.Family := cGridFont;
      Font.Size := FScreenScale * 15;
      Font.Style := [TFontStyle.fsBold];
      Fill.Color := TAlphaColorRec.White;

      if Title <> 'then
        FillText(R, Title, False, 1, [], TTextAlign.Leading, TTextAlign.Center);

      if Description <> 'then
      begin
        R.Offset(0, R.Height);
        Font.Style := [];
        FillText(R, Description, False, 0.8, [], TTextAlign.Leading,
          TTextAlign.Leading);
      end;
    finally
      EndScene;
    end;
  end;
end;

procedure TTileItem.DoOnDownloadComplete(AFileName: string;
  AAvailable: Boolean);
begin
  if AAvailable then
  begin
    FLocalImage := AFileName;
    FNeedUpdate := true;
    FUpdateImage := False;
    PerformUpdate;
  end;
end;

function TTileItem.PerformUpdate: Boolean;
var
  Image: TBitmap;
{$IFDEF USEGPU}
  Bitmap: TBitmap;
  //Bmp: TTexture;
{$ENDIF}
  ImgWidth, ImgHeight: Integer;
begin
  Result := (FUpdateImage) or (FNeedUpdate);

  if FUpdateImage then
  begin
    FUpdateImage := False;
    RetrieveImage(FImageFile, {$IFDEF USEZIP}FZipFile {$ELSE} nil
{$ENDIF}, DoOnDownloadComplete);
    Exit;
  end;

  if FNeedUpdate then
  begin
    FNeedUpdate := False;
{$IFDEF BACKBUFFER}
    if FileExists(FLocalImage) then
      Image := TBitmap.CreateFromFile(FLocalImage)
    else
      Image := nil;
    ImgWidth := Trunc(FScreenScale * Width);
    ImgHeight := Trunc(FScreenScale * Height);

{$IFDEF USEGPU}
    FreeAndNil(FNormal);
    FreeAndNil(FSelected);
    Bitmap := TBitmap.Create;
    Bitmap.SetSize(ImgWidth, ImgHeight);
    DefaultRenderItem(Bitmap.Canvas, Bitmap.BoundsF, Image, False);
    FNormal := ALTransformBitmaptoTexture(Bitmap);

    Bitmap := TBitmap.Create;
    Bitmap.SetSize(ImgWidth, ImgHeight);
    DefaultRenderItem(Bitmap.Canvas, Bitmap.BoundsF, Image, true);
    FSelected := ALTransformBitmaptoTexture(Bitmap);
{$ELSE}
    FNormal.SetSize(ImgWidth, ImgHeight);
    FSelected.SetSize(ImgWidth, ImgHeight);

    DefaultRenderItem(FNormal.Canvas, FNormal.BoundsF, Image, False);
    DefaultRenderItem(FSelected.Canvas, FSelected.BoundsF, Image, true);
{$ENDIF}
    FreeAndNil(Image);
{$ELSE}
    try
      FreeAndNil(FImage);
      if FileExists(FLocalImage) then
        FImage := TBitmap.CreateFromFile(FLocalImage)
    except
      FreeAndNil(FImage);
    end;
{$ENDIF}
  end;

end;

procedure TTileItem.Paint;
var
  w, h: Single;
  R: TRectF;
{$IFDEF USEGPU}
  Bmp: TTexture;
{$ELSE}
  Bmp: TBitmap;
{$ENDIF}
begin
  if Locked then
    Exit;

  if assigned(FOnBeforePaint) then
    FOnBeforePaint(self);

  PerformUpdate;

  w := Width * FZoomFactor;
  h := Height * FZoomFactor;
  R := RectF((Width - w) / 2, (Height - h) / 2, w, h);

{$IFDEF BACKBUFFER}
  if FActive then
    Bmp := FSelected
  else
    Bmp := FNormal;

  if Bmp <> nil then
  begin
{$IFDEF USEGPU}
    TCustomCanvasGpu(Canvas).DrawTexture(R, TRectF.Create(0, 0, Bmp.Width,
      Bmp.Height), ALPrepareColor(TCustomCanvasGpu.ModulateColor,
      AbsoluteOpacity), // https://quality.embarcadero.com/browse/RSP-15432
      Bmp);
{$ELSE}
    Canvas.DrawBitmap(Bmp, TRectF.Create(0, 0, Bmp.Width, Bmp.Height), R,
      AbsoluteOpacity, true);

{$ENDIF}
  end;
{$ELSE}
  DefaultRenderItem(Canvas, R, FImage, FActive);
{$ENDIF}
end;

Geändert von Peter666 (16. Okt 2019 um 10:02 Uhr)
  Mit Zitat antworten Zitat
TiGü

Registriert seit: 6. Apr 2011
Ort: Berlin
3.058 Beiträge
 
Delphi 10.4 Sydney
 
#8

AW: Performanceproblem mit Firemonkey

  Alt 16. Okt 2019, 11:24
Delphi-Quellcode:
procedure TTileItem.Paint;
var
  w, h: Single;
  R: TRectF;
{$IFDEF USEGPU}
  Bmp: TTexture;
{$ELSE}
  Bmp: TBitmap;
{$ENDIF}
begin
  if Locked then
    Exit;

  if assigned(FOnBeforePaint) then
    FOnBeforePaint(self);

  PerformUpdate;

  w := Width * FZoomFactor;
  h := Height * FZoomFactor;
  R := RectF((Width - w) / 2, (Height - h) / 2, w, h);

{$IFDEF BACKBUFFER}
  if FActive then
    Bmp := FSelected
  else
    Bmp := FNormal;

  if Bmp <> nil then
  begin
{$IFDEF USEGPU}
    TCustomCanvasGpu(Canvas).DrawTexture(R, TRectF.Create(0, 0, Bmp.Width,
      Bmp.Height), ALPrepareColor(TCustomCanvasGpu.ModulateColor,
      AbsoluteOpacity), // https://quality.embarcadero.com/browse/RSP-15432
      Bmp);
{$ELSE}
    Canvas.DrawBitmap(Bmp, TRectF.Create(0, 0, Bmp.Width, Bmp.Height), R,
      AbsoluteOpacity, true);

{$ENDIF}
  end;
{$ELSE}

// Ich nehme an, dass hier wird dann zu oft aufgerufen, so dass du ein das Gefühl der Langsamkeit hast?! Wäre es nicht schlauer DefaultRenderItem(...) nur dann aufzurufen, wenn R oder FActive sich im Vergleich zum Letzten Paint-Aufruf geändert haben und ansonsten ein Offscreen-Bitmap/Backbuffer zu verwenden. So wie du es ein paar Zeilen höher machst, wenn BACKBUFFER definiert wäre?
  DefaultRenderItem(Canvas, R, FImage, FActive);
{$ENDIF}
end;
  Mit Zitat antworten Zitat
Peter666

Registriert seit: 11. Aug 2007
357 Beiträge
 
#9

AW: Performanceproblem mit Firemonkey

  Alt 16. Okt 2019, 11:32
Das wird nur aufgerufen, wenn Backbuffer als Conditional Define nicht aktiv ist. Aber ja, wenn du das direkt in die Canvas zeichnest wird es furchbar hakelig. Deswegen zeichne ich die beiden Modi ja in ein Bild das dann via Drawbitmap gezeichnet wird.
  Mit Zitat antworten Zitat
TiGü

Registriert seit: 6. Apr 2011
Ort: Berlin
3.058 Beiträge
 
Delphi 10.4 Sydney
 
#10

AW: Performanceproblem mit Firemonkey

  Alt 16. Okt 2019, 11:48
Falls es dir eine Hilfe ist: Hier 10 mal auf den Button geklickt und AQtime dabei laufen lassen:
Miniaturansicht angehängter Grafiken
button1click.png   defaultrenderitem1.png   defaultrenderitem2.png  
  Mit Zitat antworten Zitat
Antwort Antwort
Seite 1 von 2  1 2   

Themen-Optionen Thema durchsuchen
Thema durchsuchen:

Erweiterte Suche
Ansicht

Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 09:33 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz