Gauge in Firemonkey

[Sir Rufo]

@Union

Ich hätte da eher an ein Konstrukt gedacht, was zu bestimmten Vorgaben ein Bitmap liefert, was dann gezeichnet wird. Wie das Konstrukt an das Bitmap kommt ist also egal.

Intern geht das Konstrukt her und sagt sich, oh, das hatte ich eben doch schon mal gepinselt, dann kann ich das doch einfach wieder abliefern (war ja schlau und habe es mir gemerkt),
oder pinselt es eben in ein Bitmap (merkt sich das) und liefert das Bitmap ab.

AFAIK ändert sich die Auflösung auf einem Gerät nicht. Die Orientierung ja, und wenn die relevant ist, dann gehört die mit zu den Vorgaben.

[mkinzler]

Zum Thema Bitmap Caching
http://www.fmxexpress.com/speed-up-y...droid-and-ios/

[Union]

Eine kleinere Optimierung wäre vielleicht dies:

Delphi-Quellcode:

procedure TGauge.DrawDigit...
...
const
  //    01
  // 32   02
  //   64
  // 16   04
  //   08
  //
  Bitmasks : Array[0..9] of Byte =
    ( 63,
      6,
      91,
      79,
      102,
      109,
      124,
      7,
      127,
      103);
begin
  // Diese teuren Aufrufe ersetzen (weiter mit 2=2, 4=4 .. 64=64)
  // if (IsNumberAvailable(number, [0, 2, 3, 5, 6, 7, 8, 9])) then
  if Bitmasks[Number] and 1 = 1 then
end;

[CHackbart]

Ich habe das jetzt wie folgt abgeändert:

Delphi-Quellcode:

unit UGauge;

interface

uses System.Types, System.SysUtils, System.Classes, System.UITypes,
  FMX.Types, FMX.Graphics, FMX.Controls;

type
  TGauge = class(TControl)
  protected
    FScale: single;
    FBitmap: TBitmap;
    FBackColor: TAlphaColor;
    FDialColor: TAlphaColor;
    FForeColor: TAlphaColor;
    FFlatMode: Boolean;
    FForceUpdate: Boolean;

    FGlossAlpha: Byte;

    FCurrentValue: single;
    FThreshHold: single;
    FCaptureThresh: Boolean;
    FMaxValue: single;
    FMinValue: single;

    FToAngle: single;
    FFromAngle: single;

    FNoOfDivisions: integer;
    FNoOfSubDivisions: integer;

    FGaugeName: String;

    procedure SetFlatMode(const Value: Boolean);

    procedure DrawBackground(const Canvas: TCanvas; const RealWidth, Width, Height: single;
      const Center: TPointF);
    procedure DrawCenterPoint(const Canvas: TCanvas; const Width: single;
      const Center: TPointF);
    procedure DrawCallibration(const Canvas: TCanvas; const Width: single;
      const Center: TPointF);
    procedure DrawPointer(const Canvas: TCanvas; const Width: single;
      const Center: TPointF; const Thresh: Boolean = false);
    procedure DrawGloss(const Canvas: TCanvas; const Width: single;
      const Center: TPointF);

    procedure SetCurrentValue(const Value: single);

    procedure Paint; override;
    procedure Resize; override;

    procedure RenderBackground(const Width, Height: single);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure ResetThreshold;

    property BackColor: TAlphaColor read FBackColor write FBackColor;
    property ForeColor: TAlphaColor read FForeColor write FForeColor;
    property DialColor: TAlphaColor read FDialColor write FDialColor;
    property GlossAlpha: Byte read FGlossAlpha write FGlossAlpha;
    property CurrentValue: single read FCurrentValue write SetCurrentValue;
    property MaxValue: single read FMaxValue write FMaxValue;
    property MinValue: single read FMinValue write FMinValue;
    property ToAngle: single read FToAngle write FToAngle;
    property FromAngle: single read FFromAngle write FFromAngle;
    property noOfDivisions: integer read FNoOfDivisions write FNoOfDivisions;
    property noOfSubDivisions: integer read FNoOfSubDivisions
      write FNoOfSubDivisions;
    property GaugeName: String read FGaugeName write FGaugeName;
    property CaptureThresh: Boolean read FCaptureThresh write FCaptureThresh;

    property FlatMode: Boolean read FFlatMode write SetFlatMode;
  published
    property Align;
    property Anchors;
    property ClipChildren default false;
    property ClipParent default false;
    property DesignVisible default True;
    property Enabled default True;
    property Locked default false;
    property Height;
    property HitTest default True;
    property Padding;
    property Opacity;
    property Margins;
    property PopupMenu;
    property position;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property Visible default True;
    property Width;
    { Mouse events }
    property OnClick;
    property OnDblClick;

    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;

    property OnPainting;
    property OnPaint;
    property OnResize;
  end;

implementation

uses FMX.Platform;

{ TGauge }
constructor TGauge.Create(AOwner: TComponent);
var
  ScreenSvc: IFMXScreenService;
begin
  inherited;
  FBitmap := TBitmap.Create;
{$IFDEF ANDROID}
  FFlatMode := True;
{$ENDIF}

  FBackColor := $FF000080;
  FDialColor := $FFE6E6FA;
  FForeColor := $FF000000;

  MaxValue := 100;
  MinValue := 0;
  CurrentValue := 0;

  FromAngle := 135;
  ToAngle := 405;

  noOfDivisions := 10;
  noOfSubDivisions := 3;
  FGaugeName := '';

  GlossAlpha := 200;
  if TPlatformServices.Current.SupportsPlatformService(IFMXScreenService,
    IInterface(ScreenSvc)) then
    FScale := ScreenSvc.GetScreenScale
  else
    FScale := 1;
  FForceUpdate := True;
end;

destructor TGauge.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited;
end;

procedure TGauge.DrawCallibration(const Canvas: TCanvas; const Width: single;
  const Center: TPointF);
var
  currentAngle: single;
  gap: integer;
  X, Y, x1, y1, tx, ty, radius: single;
  rulerValue, incr, totalAngle: single;
  i, j: integer;
begin
  gap := trunc(Width * 0.01);
  radius := Width / 2 - gap * 5;

  currentAngle := FromAngle * PI / 180;
  totalAngle := ToAngle - FromAngle;

  incr := totalAngle / (noOfDivisions * noOfSubDivisions) * PI / 180;
  rulerValue := MinValue;

  Canvas.stroke.Kind := TBrushKind.bkSolid;
  Canvas.stroke.Color := $FF000000;

  Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
  Canvas.Font.Size := Width / 24;

  for i := 0 to noOfDivisions do
  begin
    // Draw Thick Line
    X := (Center.X + radius * Cos(currentAngle));
    Y := (Center.Y + radius * Sin(currentAngle));
    x1 := (Center.X + (radius - Width / 20) * Cos(currentAngle));
    y1 := (Center.Y + (radius - Width / 20) * Sin(currentAngle));
    Canvas.DrawLine(PointF(X, Y), PointF(x1, y1), 1);

    // Draw Strings
    tx := (Center.X + (radius - Width / 10) * Cos(currentAngle));
    ty := (Center.Y - Width / 25 + (radius - Width / 10) * Sin(currentAngle));

    Canvas.FillText(RectF(tx, ty, tx + 1024, ty + 1024),
      format('%0.0f', [rulerValue]), false, 1, [], TTextAlign.taLeading,
      TTextAlign.taLeading);

    rulerValue := rulerValue + round((MaxValue - MinValue) / noOfDivisions);

    if i < noOfDivisions then
      for j := 0 to noOfSubDivisions - 1 do
      begin
                    // Draw thin lines
        currentAngle := currentAngle + incr;
        X := (Center.X + radius * Cos(currentAngle));
        Y := (Center.Y + radius * Sin(currentAngle));
        x1 := (Center.X + (radius - Width / 50) * Cos(currentAngle));
        y1 := (Center.Y + (radius - Width / 50) * Sin(currentAngle));
        Canvas.DrawLine(PointF(X, Y), PointF(x1, y1), 1);
      end;
  end;
end;

procedure TGauge.DrawPointer(const Canvas: TCanvas; const Width: single;
  const Center: TPointF; const Thresh: Boolean = false);
var
  radius: single;
  val: single;
  angle: single;
  pts: TPolygon;
  Value, w, len: single;

begin
  radius := Width / 2 - (Width * 0.12);
  val := MaxValue - MinValue;

  if Thresh then
  begin
    w := 6;
    Value := FThreshHold;
    len := 0.09;
  end
  else
  begin
    w := 20;
    Value := CurrentValue;
    len := 0.09;
  end;

  val := (100 * (Value - MinValue)) / val;
  val := ((ToAngle - FromAngle) * val) / 100;
  val := val + FromAngle;

  angle := val * PI / 180;

  setlength(pts, 5);
  pts[0].X := (Center.X + radius * Cos(angle));
  pts[0].Y := (Center.Y + radius * Sin(angle));

  pts[4].X := (Center.X + radius * Cos(angle - 0.02));
  pts[4].Y := (Center.Y + radius * Sin(angle - 0.02));

  angle := (val + w) * PI / 180;
  pts[1].X := (Center.X + (Width * len) * Cos(angle));
  pts[1].Y := (Center.Y + (Width * len) * Sin(angle));

  pts[2].X := Center.X;
  pts[2].Y := Center.Y;

  angle := (val - w) * PI / 180;
  pts[3].X := (Center.X + (Width * len) * Cos(angle));
  pts[3].Y := (Center.Y + (Width * len) * Sin(angle));

  if Thresh then
    Canvas.Fill.Color := $FFFF0000
  else
    Canvas.Fill.Color := $FF000000;
  Canvas.FillPolygon(pts, 1);

  if Thresh then
    exit;

  setlength(pts, 3);
  angle := val * PI / 180;
  pts[0].X := (Center.X + radius * Cos(angle));
  pts[0].Y := (Center.Y + radius * Sin(angle));

  angle := (val + w) * PI / 180;
  pts[1].X := (Center.X + (Width * len) * Cos(angle));
  pts[1].Y := (Center.Y + (Width * len) * Sin(angle));

  pts[2].X := Center.X;
  pts[2].Y := Center.Y;

  if FFlatMode then
  begin
    Canvas.Fill.Color := $FF808080;
    Canvas.FillPolygon(pts, 1);
  end
  else
  begin
    Canvas.Fill.Kind := TBrushKind.bkGradient;
    try
      Canvas.Fill.Gradient.Color := $FF808080;
      Canvas.Fill.Gradient.Color1 := $0F000000;
      Canvas.FillPolygon(pts, 1);
    finally
      Canvas.Fill.Kind := TBrushKind.bkSolid;
    end;
  end;
end;

procedure TGauge.DrawGloss(const Canvas: TCanvas; const Width: single;
  const Center: TPointF);
var
  R: TRectF;
  X, Y: single;
begin
  R := RectF(Center.X - Width / 2, Center.Y - Width / 2, Center.X + Width / 2,
    Center.Y + Width / 2);
  if not FFlatMode then
    Canvas.Fill.Kind := TBrushKind.bkGradient;
  try
    Canvas.Fill.Color := (GlossAlpha div 4 and $FF) shl 24 or $FFFFFF;
    if not FFlatMode then
    begin
      Canvas.Fill.Gradient.Color := (GlossAlpha and $FF) shl 24 or $FFFFFF;
      Canvas.Fill.Gradient.Color1 := $00FFFFFF;
    end;

    X := R.Left + (Width * 0.10);
    Y := R.Top + (Width * 0.07);
    Canvas.FillEllipse(RectF(X, Y, X + (Width * 0.80), Y + (Width * 0.7)), 1);
    Canvas.Fill.Color := ((GlossAlpha div 3) and $FF) shl 24 or
      (FBackColor and $FFFFFF);

    if not FFlatMode then
    begin
      Canvas.Fill.Gradient.Color := $00FFFFFF;
      Canvas.Fill.Gradient.Color1 := Canvas.Fill.Color;
    end;
    X := R.Left + Width * 0.25;
    Y := R.Top + Width * 0.77;
    Canvas.FillEllipse(RectF(X, Y, X + Width * 0.5, Y + Width * 0.2), 1);
  finally
    Canvas.Fill.Kind := TBrushKind.bkSolid;
  end;
end;

procedure TGauge.DrawCenterPoint(const Canvas: TCanvas; const Width: single;
  const Center: TPointF);
var
  R: TRectF;
  shift: single;
begin
  shift := Width / 5;
  R := RectF(Center.X - (shift / 2), Center.Y - (shift / 2),
    Center.X + (shift / 2), Center.Y + (shift / 2));

  if not FFlatMode then
    Canvas.Fill.Kind := TBrushKind.bkGradient;
  try
    Canvas.Fill.Color := 100 shl 24 or (FDialColor and $FFFFFF);
    if FFlatMode then
    begin
      Canvas.Fill.Gradient.Color := $FF000000;
      Canvas.Fill.Gradient.Color1 := Canvas.Fill.Color;
    end;
    Canvas.FillEllipse(R, 1);

    shift := Width / 7;
    R := RectF(Center.X - (shift / 2), Center.Y - (shift / 2),
      Center.X + (shift / 2), Center.Y + (shift / 2));

    if FFlatMode then
      Canvas.Fill.Color := $80808080
    else
    begin
      Canvas.Fill.Gradient.Color := $FF808080;
      Canvas.Fill.Gradient.Color1 := $FF000000;
    end;
    Canvas.FillEllipse(R, 1);
  finally
    Canvas.Fill.Kind := TBrushKind.bkSolid;
  end;
end;

procedure TGauge.DrawBackground(const Canvas: TCanvas;
  const RealWidth, Width, Height: single; const Center: TPointF);
var
  R: TRectF;
  Y: single;
begin
  R := RectF(Center.X - (Width / 2), Center.Y - (Width / 2),
    Center.X + (Width / 2), Center.Y + (Width / 2));
  Canvas.Fill.Color := 120 shl 24 or (FDialColor and $FFFFFF);
  Canvas.FillEllipse(R, 1);

  // Draw Rim
  Canvas.stroke.Kind := TBrushKind.bkSolid;
  Canvas.stroke.Color := $64808080;
  Canvas.DrawEllipse(R, 1);

  Canvas.stroke.Color := $FF808080;
  Canvas.DrawEllipse(R, 1);

  Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
  Canvas.Font.Size := Width / 18;

  Canvas.FillText(RectF(0, Center.Y + (Width / 4.5), RealWidth, Height), FGaugeName,
    false, 1, [], TTextAlign.taCenter, TTextAlign.taLeading);

  DrawCallibration(Canvas, Width, Center);
end;

procedure TGauge.Resize;
begin
  inherited;
  FForceUpdate := True;
end;

procedure TGauge.RenderBackground(const Width, Height: single);
var
  Center: TPointF;
begin
  if not FForceUpdate then
    exit;
  FForceUpdate := false;

  FBitmap.Resize(trunc(Width * FScale), trunc(Height * FScale));

  Center := PointF(FBitmap.Width / 2, FBitmap.Height / 2);

  FBitmap.Clear(0);
  FBitmap.Canvas.BeginScene(nil);
  DrawBackground(FBitmap.Canvas, FBitmap.Width, 0.98*FBitmap.Width, FBitmap.Height, Center);
  FBitmap.Canvas.EndScene;
end;

procedure TGauge.SetFlatMode(const Value: Boolean);
begin
  if FFlatMode <> Value then
  begin
    FFlatMode := Value;
    FForceUpdate := True;
    repaint;
  end
end;

procedure TGauge.Paint;
var
  Center: TPointF;
  w, Y: single;
begin
  RenderBackground(Width, Height);

  if Canvas.BeginScene(nil) then
    try
      Center := PointF(Width / 2, Height / 2);

      Canvas.DrawBitmap(FBitmap, RectF(0, 0, FBitmap.Width, FBitmap.Height),
        RectF(0, 0, Width, Height), 1);

      Y := Center.Y + Height / 3.5;
      w := 0.98*Width;

      Canvas.Font.Size := Width / 10;
      Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
      Canvas.FillText(RectF(0, Y, Width, Height),
        format('%0.1f', [CurrentValue]), false, 1, [], TTextAlign.taCenter,
        TTextAlign.taLeading);

      if FThreshHold >= FMinValue then
        DrawPointer(Canvas, w, Center, True);

      DrawPointer(Canvas, w, Center);

      DrawCenterPoint(Canvas, w, Center);
      DrawGloss(Canvas, w, Center);

    finally
      Canvas.EndScene;
    end;
end;

procedure TGauge.SetCurrentValue(const Value: single);
begin
  if abs(FCurrentValue - Value) >= 0.1 then
  begin
    FCurrentValue := Value;
    if (CaptureThresh) and (FThreshHold < Value) then
      FThreshHold := Value;

    repaint;
  end;
end;

procedure TGauge.ResetThreshold;
begin
  CaptureThresh := false;
  FThreshHold := FMinValue - 1;
  repaint;
end;

end.

Das läuft jetzt etwas besser, aber in Summe ist es immer noch nicht wirklich performant.

[Union]

Eventuell solltest Du lieber die generischen Routinen FillPath und DrawPath verwenden, dann muss Firemonkey Deine TPointF-Arrays nicht mehr umkopieren.