FMX如何高质量缩小绘制位图？寻求GPU加速方案

将位图绘制为比源图更小的尺寸时，图像质量会明显下降，尤其是包含细线的图像，子采样会导致部分线条直接消失。我需要在不显著影响运行时性能的前提下提升缩放质量，理想方案是通过GPU实现。

我尝试了三种不同的实现方法：

• 缩放目标矩形：和TBitmap.CreateThumbnail方法逻辑一致，质量较差；
• 使用画布变换矩阵：质量同样不佳；
• 自定义Shrink函数：能达到预期效果，但基于CPU处理速度慢，且不支持旋转+缩放的组合操作。

另外我还尝试修改DrawBitmap函数的HighSpeed参数，但没有明显效果。

Form代码 #

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 240
  ClientWidth = 438
  FormFactor.Width = 320
  FormFactor.Height = 480
  FormFactor.Devices = [Desktop]
  OnCreate = FormCreate
  DesignerMasterStyle = 0
  object Image1: TImage
    MultiResBitmap = <
      item
      end>
    Position.X = 8.000000000000000000
    Position.Y = 8.000000000000000000
  end
  object Image2: TImage
    MultiResBitmap = <
      item
      end>
    Position.X = 216.000000000000000000
    Position.Y = 8.000000000000000000
  end
  object Image3: TImage
    MultiResBitmap = <
      item
      end>
    Position.X = 216.000000000000000000
    Position.Y = 80.000000000000000000
  end
  object Image4: TImage
    MultiResBitmap = <
      item
      end>
    Position.X = 216.000000000000000000
    Position.Y = 152.000000000000000000
  end
  object Label1: TLabel
    Position.X = 266.000000000000000000
    Position.Y = 24.000000000000000000
    Size.Width = 164.000000000000000000
    Size.Height = 17.000000000000000000
    Size.PlatformDefault = False
    Text = 'Scale destination rectangle'
    TabOrder = 6
  end
  object Label2: TLabel
    Position.X = 266.000000000000000000
    Position.Y = 96.000000000000000000
    Size.Width = 164.000000000000000000
    Size.Height = 17.000000000000000000
    Size.PlatformDefault = False
    Text = 'Create canvas scale transform'
    TabOrder = 5
  end
  object Label3: TLabel
    Position.X = 266.000000000000000000
    Position.Y = 168.000000000000000000
    Size.Width = 164.000000000000000000
    Size.Height = 17.000000000000000000
    Size.PlatformDefault = False
    Text = 'Hand coded Shrink function'
    TabOrder = 4
  end
end

Unit代码 #

unit Unit1;

interface

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

type
  PAlphaColorArray = ^TAlphaColorArray;
  TAlphaColorArray = array[0..32767] of TAlphaColor;

  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

procedure Shrink(const ABitmap : TBitmap ; out ABitmapOut : TBitmap);

var
  Form1: TForm1;

implementation

uses Math, Math.Vectors;

{$R *.fmx}

procedure TForm1.FormCreate(Sender: TObject);
const
  r : Single = 0.2;
  size : Integer = 200;
var
  srcRect, dstRect : TRectF;
  bmp : TBitmap;
begin
  // Create source image - circle
  Image1.Bitmap.BitmapScale := 1;
  Image1.Bitmap.SetSize(size, size);
  Image1.Width := Image1.Bitmap.Width;
  Image1.Height := Image1.Bitmap.Height;
  if Image1.Bitmap.Canvas.BeginScene then begin
    Image1.Bitmap.Canvas.Clear(TAlphaColorRec.White);
    Image1.Bitmap.Canvas.Stroke.Thickness := 1;
    Image1.Bitmap.Canvas.DrawEllipse(TRectF.Create(size/10,size/10,9*size/10,9*size/10), 1);
    Image1.Bitmap.Canvas.EndScene;
  end;

  srcRect := Image1.Bitmap.BoundsF;
  dstRect := srcRect;
  dstRect.BottomRight := PointF(dstRect.Width*r, dstRect.Height*r);

  // Try reducing by scaling the destination rectangle
  // Same method as TBitmap.CreateThumbnail
  Image2.Bitmap.BitmapScale := 1;
  Image2.Bitmap.SetSize(Ceil(dstRect.Width), Ceil(dstRect.Height));
  Image2.Width := Image2.Bitmap.Width;
  Image2.Height := Image2.Bitmap.Height;
  if Image2.Bitmap.Canvas.BeginScene then begin
    Image2.Bitmap.Canvas.DrawBitmap(Image1.Bitmap, srcRect, dstRect, 1, True);
    Image2.Bitmap.Canvas.EndScene;
  end;

  // Try reducing using the canvas transform matrix
  Image3.Bitmap.BitmapScale := 1;
  Image3.Bitmap.SetSize(Ceil(dstRect.Width), Ceil(dstRect.Height));
  Image3.Width := Image2.Bitmap.Width;
  Image3.Height := Image2.Bitmap.Height;
  if Image3.Bitmap.Canvas.BeginScene then begin
    Image3.Bitmap.Canvas.SetMatrix(TMatrix.CreateScaling(r, r));
    Image3.Bitmap.Canvas.DrawBitmap(Image1.Bitmap, srcRect, srcRect, 1, True);
    Image3.Bitmap.Canvas.EndScene;
  end;

  // Reduce using Shrink function - Slow (not done on GPU)
  bmp := TBitmap.Create(Ceil(dstRect.Width), Ceil(dstRect.Height));
  bmp.BitmapScale := 1;
  Image4.Width := bmp.Width;
  Image4.Height := bmp.Height;
  Shrink(Image1.Bitmap, bmp);
  Image4.Bitmap.Assign(bmp);
  bmp.Free;
end;

// Shrink a bitmap using all available data from source
// Could be sped up a little for specific cases such as scaling by 0.5
procedure Shrink(const ABitmap : TBitmap ; out ABitmapOut : TBitmap);
Var
  Lx, Ly : integer;
  LyBox, LxBox, LyBox1, LyBox2, LxBox1, LxBox2 : integer;
  TR, TG, TB, TA : integer;
  LRowIn, LRowOut, LRowInStart : PAlphaColorArray;
  LBoxCount : integer;
  LRowBytes, LRowBytesIn : integer;
  LBoxRows : array of PAlphaColorArray;
  LRatioW, LRatioH : Real;
  bdata, bdatao : TBitmapData;
begin
  if (ABitmapOut.Width = 0) or (ABitmapOut.Height = 0) then Exit;

  LRatioH := ABitmap.Height / ABitmapOut.Height;
  LRatioW := ABitmap.Width / ABitmapOut.Width;

  ABitmap.Map(TMapAccess.Read, bdata);
  ABitmapOut.Map(TMapAccess.Write, bdatao);

  try
    SetLength(LBoxRows, Trunc(LRatioH)+1);

    LRowOut := PAlphaColorArray(bdatao.GetScanline(0));
    LRowBytes := bdatao.Pitch;
    LRowBytesIn := bdata.Pitch;
    LRowInStart := PAlphaColorArray(bdata.GetScanline(0));

    for Ly := 0 to ABitmapOut.Height-1 do begin

      LyBox1 := Trunc(Ly*LRatioH);
      LyBox2 := Trunc((Ly+1)*LRatioH) - 1;

      for LyBox := LyBox1 to LyBox2 do
        PByte(LBoxRows[LyBox-LyBox1]) := PByte(LRowInStart) + LyBox*LRowBytesIn;

      for Lx := 0 to ABitmapOut.Width-1 do begin

        LxBox1 := Trunc(Lx*LRatioW);
        LxBox2 := Trunc((Lx+1)*LRatioW) - 1;

        TR := 0; TG := 0; TB := 0; TA := 0;
        LBoxCount := 0;
        for LyBox := LyBox1 to LyBox2 do begin
          LRowIn := LBoxRows[LyBox-LyBox1];
          for LxBox := LxBox1 to LxBox2 do begin
            Inc(TB, TAlphaColorRec(LRowIn[LxBox]).B);
            Inc(TG, TAlphaColorRec(LRowIn[LxBox]).G);
            Inc(TR, TAlphaColorRec(LRowIn[LxBox]).R);
            Inc(TA, TAlphaColorRec(LRowIn[LxBox]).A);
            Inc(LBoxCount);
          end;
        end;

        TAlphaColorRec(LRowOut[Lx]).B := TB div LBoxCount;
        TAlphaColorRec(LRowOut[Lx]).G := TG div LBoxCount;
        TAlphaColorRec(LRowOut[Lx]).R := TR div LBoxCount;
        TAlphaColorRec(LRowOut[Lx]).A := TA div LBoxCount;

      end;

      Inc(PByte(LRowOut), LRowBytes);

    end;

  finally
    ABitmap.Unmap(bdata);
    ABitmapOut.Unmap(bdatao);
  end;
end;

end.

内容的提问来源于stack exchange，提问作者XylemFlow