Multithreaded Zeichnen

[TiGü]

Mangels iOS-Gerät kann ich es nicht testen und der folgende Quelltext ist nur ein Schuss ins Blaue, aber du kannst es ja mal versuchen.

Wesentliche Änderungen:

1. Erzeugung des Thread-Bitmaps im Execute und damit im Thread-Kontext (fühlt sich richtiger an - ob in FMX notwendig wissen andere besser).
2. Benachrichtigung der GUI durch übergebende Callback (flexibler, kein Zugriff auf globale Variablen [ja, ich weiß es es nur ein Testprojekt]).
3. Lesen und schreiben zwischen den Bitmaps mithilfe der Map-Methode und TBitmapData.Copy.

Vielleicht ist Punkt Nummer Drei die Lösung. Versuch macht klug!

Delphi-Quellcode:

unit ThreadBitmap.View;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects;

type
  TUpdateGui = TProc<TBitmap>;
  
  TPainter = class(TThread)
  private
    fBMP: TBitmap;
    fUpdateGui: TUpdateGui;
    procedure DoPainting(const ACanvas: TCanvas; const AWitdh, AHeight: Integer);
    procedure updateGui;
    procedure DoUpdateGui;

  protected
    procedure Execute; override;
  public
    constructor Create(const AUpdateGui: TUpdateGui);
    destructor Destroy; override;

  end;

  TForm16 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    FPainter: TPainter;
    procedure updateGui(ABitmap: TBitmap);
  public
    { Public declarations }
  end;

var
  Form16: TForm16;

implementation

{$R *.fmx}

{ TPainter }

constructor TPainter.Create(const AUpdateGui: TUpdateGui);
begin
  fUpdateGui := AUpdateGui;
  inherited Create(false);
end;

destructor TPainter.Destroy;
begin
  fUpdateGui := nil;
  inherited;
end;

procedure TPainter.DoPainting(const ACanvas: TCanvas; const AWitdh, AHeight: Integer);
var
  myPoint1: TPoint;
  myPoint2: TPoint;
  I: Integer;
begin
  myPoint1 := TPoint.Zero;
  if ACanvas.BeginScene then
  begin
    ACanvas.Clear(TAlphaColorRec.Null);
    ACanvas.Stroke.Thickness := 1;
    ACanvas.Stroke.Color := TAlphaColorRec.Black;
    try
      for I := 0 to 1000 - 1 do
      begin
        myPoint2 := TPoint.Create(Random(AWitdh), Random(AHeight));
        ACanvas.DrawLine(myPoint1, myPoint2, 1);
        myPoint1 := myPoint2;
      end;
    finally
      ACanvas.EndScene;
    end;
  end;
end;

procedure TPainter.Execute;
begin
  inherited;
  fBMP := TBitmap.Create(256, 256);
  try
    while not Terminated do
    begin
      DoPainting(fBMP.Canvas, fBMP.Width, fBMP.Height);
      updateGui;
      if not Terminated then
        Sleep(1000);
    end;
  finally
    fBMP.Free;
  end;
end;

procedure TPainter.DoUpdateGui;
begin
  fUpdateGui(fBMP);
end;

procedure TPainter.updateGui;
begin
  if Assigned(fUpdateGui) then
  begin
    Synchronize(DoUpdateGui);
  end;
end;

procedure TForm16.FormDestroy(Sender: TObject);
begin
  if Assigned(FPainter) then
    FPainter.Free;
end;

procedure TForm16.FormCreate(Sender: TObject);
begin
  FPainter := nil;
end;

procedure TForm16.Button1Click(Sender: TObject);
begin
  FPainter := TPainter.Create(updateGui);
end;

procedure TForm16.updateGui(ABitmap: TBitmap);
var
  LBitmap: TBitmap;
  LDataWrite, LDataRead: TBitmapData;
begin
  // Self.Image1.BeginUpdate;
  // try
  // Self.Image1.Bitmap.SetSize(ABitmap.Size);
  // Self.Image1.Bitmap.Assign(ABitmap);
  // finally
  // Self.Image1.EndUpdate;
  // Self.Image1.Repaint;
  // end;

  Self.Image1.BeginUpdate;
  try
    LBitmap := Self.Image1.Bitmap;
    LBitmap.SetSize(ABitmap.Size);
    if LBitmap.Map(TMapAccess.Write, LDataWrite) and ABitmap.Map(TMapAccess.Read, LDataRead) then
    begin
      try
        LDataWrite.Copy(LDataRead);
      finally
        ABitmap.Unmap(LDataRead);
        LBitmap.Unmap(LDataWrite);
      end;
    end;
  finally
    Self.Image1.EndUpdate;
    Self.Image1.Repaint;
  end;
end;

end.