Performanceproblem mit Firemonkey

[Peter666]

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;