bevor ich das Rad neu erfinde .... was ist der einfachste Weg diesen Code von nur VCL Framework für VCL und FMX nutzbar zumachen,
über Vorschläge zu einem Speed up , auch gerne

zusammenfalten · markieren

Delphi-Quellcode:

procedure TImageSegmenationForm.UpdateOutputimage(const Outimg: TBitmap);
begin
  OutImage.Picture.Bitmap.Assign(Outimg);

  OutImage.Repaint;

  Application.ProcessMessages;
end;

procedure TImageSegmenationForm.Action_KmeansExecute(Sender: TObject);
var
  OutBMP: TBitmap;
  k: Integer;
begin
  ///
  UpdateStatus(' Selection : K MEANS');

  OutBMP := TBitmap.Create;
  try

    k := StrToInt(ClusterLabeledEdit.text);

    KMeansCluster(FImage, OutBMP, k, UpdateStatus, UpdateOutputimage);

    UpdateOutputimage(OutBMP);

  finally
    OutBMP.Free;
  end;

end;

zusammenfalten · markieren

Delphi-Quellcode:

unit Unit_kmeans_algo;

interface

uses
  types, classes, System.Generics.Collections, System.SysUtils,
  System.Generics.Defaults,
{$IFDEF Framework_VCL}
  Windows, {Windows API Funktionen}
  VCL.Graphics; { pf1bit, pf... }
{$ENDIF}
{$IFDEF Framework_FMX}
// not yet working :-(
System.UITypes, FMX.Graphics; { pf1bit, pf... }
{$ENDIF}

type
  TStatusCallback = reference to procedure(const Status: string);
  TBitmapProcessCallback = reference to procedure(const Image: TBitmap);

type
  TCluster = record
    DrawingColor: TColor;
    Center: TColor;
    Pixels: array of TColor;
  end;

  TClusterList = TArray<TCluster>;

  /// <summary>
  /// This procedure clusters a bitmap image into K clusters using the K-means algorithm.
  /// The input bitmap image
  /// The output bitmap image
  /// The number of clusters
  /// Optional reference to a procedure to receive status updates during the clustering process
  /// Optional reference to a procedure to receive updates on the output bitmap image during the clustering process
  /// </summary>
procedure KMeansCluster(const Input: TBitmap; const Output: TBitmap;
  const K: Integer; const StatusCallback: TStatusCallback = nil;
  const BitmapProcessCallback: TBitmapProcessCallback = nil);

implementation

/// <summary>
/// Generates a random color.
/// </summary>
function RandomColor: TColor;
begin
  Result := RGB(Random(255), Random(255), Random(255));
end;

/// <summary>
/// Generates a random color.
/// </summary>
/// <param name="A">
/// first value
/// </param>
/// <param name="B">
/// second value
/// </param>
function GetDistance(const A, B: TColor): Double;
var
  R1, G1, B1, R2, G2, B2: Byte;
begin
  R1 := GetRValue(A);
  G1 := GetGValue(A);
  B1 := GetBValue(A);
  R2 := GetRValue(B);
  G2 := GetGValue(B);
  B2 := GetBValue(B);
  Result := Sqrt(Sqr(R1 - R2) + Sqr(G1 - G2) + Sqr(B1 - B2));
end;

/// <summary>
/// Assigns each pixel of the input bitmap image to the nearest cluster.
/// </summary>
procedure GroupPixels2NearestCluster(const Input: TBitmap;
  Clusters: TClusterList);
var
  x, y: Integer;
  i: Integer;
  W, H: Integer;
  K: Integer;
  Distance, MinDistance: Double;
  NearestCluster: Integer;
begin

  W := Input.Width;
  H := Input.Height;
  K := length(Clusters);

  // Clear the pixels from the previous iteration
  for i := 0 to K - 1 do
    SetLength(Clusters[i].Pixels, 0);

  // Assign each pixel to the nearest cluster
  for y := 0 to H - 1 do
  begin
    for x := 0 to W - 1 do
    begin
      MinDistance := MaxInt;
      NearestCluster := -1;

      // Find the nearest cluster for the current pixel
      for i := 0 to K - 1 do
      begin
        Distance := GetDistance(Input.Canvas.Pixels[x, y], Clusters[i].Center);
        if Distance < MinDistance then
        begin
          MinDistance := Distance;
          NearestCluster := i;
        end;
      end;

      // Assign the current pixel to the nearest cluster
      SetLength(Clusters[NearestCluster].Pixels,
        length(Clusters[NearestCluster].Pixels) + 1);
      Clusters[NearestCluster].Pixels[High(Clusters[NearestCluster].Pixels)] :=
        Input.Canvas.Pixels[x, y];
    end;
  end;
end;

/// <summary>
/// Converts the cluster centers into a string representation for debugging
/// purposes.
/// </summary>
function ClusterCentroidsToString(Clusters: TClusterList): string;
var
  i, K: Integer;
  R, G, B: Byte;
  line, s: String;
  len: Cardinal;
begin
  K := length(Clusters);
  line := '';

  for i := 0 to K - 1 do
  begin

    R := GetRValue(Clusters[i].Center);
    G := GetGValue(Clusters[i].Center);
    B := GetBValue(Clusters[i].Center);
    s := Format('[#%.2X%.2X%.2X]', [R, G, B]);

    len := length(Clusters[i].Pixels);
    line := line + s + '->' + IntToStr(len) + '; '
  end;

  Result := line;
end;

function FindNewClusterCentroids(Clusters: TClusterList): Boolean;
var
  i, j, K: Integer;
  R, G, B: Cardinal;
  Count: Cardinal;
  OldCenter: Array of TColor;
  AnyChange: Boolean;
begin

  K := length(Clusters);
  SetLength(OldCenter, K);
  AnyChange := false;

  // Update the centers of the clusters
  for i := 0 to K - 1 do
  begin
    Count := length(Clusters[i].Pixels);
    OldCenter[i] := Clusters[i].Center;

    if Count > 0 then
    begin
      R := 0;
      G := 0;
      B := 0;

      // Compute the average color of the pixels in the current cluster
      for j := 0 to Count - 1 do
      begin
        R := R + GetRValue(Clusters[i].Pixels[j]);
        G := G + GetGValue(Clusters[i].Pixels[j]);
        B := B + GetBValue(Clusters[i].Pixels[j]);
      end;

      Clusters[i].Center := RGB(R div Count, G div Count, B div Count);

      if (Clusters[i].Center <> OldCenter[i]) then
        AnyChange := true;

    end;
  end;

  Result := AnyChange;
end;

procedure UpdateClusterImage(Input, Output: TBitmap; Clusters: TClusterList);
var
  x, y: Integer;
  i, K: Integer;
  H, W: Integer;
  Distance, MinDistance: Double;
  NearestCluster: Integer;
begin

  K := length(Clusters);
  H := Output.Height;
  W := Output.Width;

  // Assign the pixels to the clustered colors

  for y := 0 to H - 1 do
  begin
    for x := 0 to W - 1 do
    begin
      MinDistance := MaxInt;
      NearestCluster := -1;

      // Find the nearest cluster for the current pixel
      for i := 0 to K - 1 do
      begin
        Distance := GetDistance(Input.Canvas.Pixels[x, y], Clusters[i].Center);
        if Distance < MinDistance then
        begin
          MinDistance := Distance;
          NearestCluster := i;
        end;
      end;

      // Assign the current pixel to the color of the nearest cluster
      Output.Canvas.Pixels[x, y] := Clusters[NearestCluster].Center;
    end;
  end;

end;

procedure KMeansCluster(const Input: TBitmap; const Output: TBitmap;
  const K: Integer; const StatusCallback: TStatusCallback = nil;
  const BitmapProcessCallback: TBitmapProcessCallback = nil);
var
  x, y, i, j: Integer;
  W, H: Integer;
  Clusters: TClusterList;
  Distance, MinDistance: Double;
  NearestCluster: Integer;
  Status: string;
  Changed: Boolean;
begin
  W := Input.Width;
  H := Input.Height;

  Output.PixelFormat := pf24bit;
  Output.Width := Input.Width;
  Output.Height := Input.Height;

  // Initialize the clusters with randomly chosen centers
  SetLength(Clusters, K);
  for i := 0 to K - 1 do
  begin
    Clusters[i].Center := Input.Canvas.Pixels[Random(W), Random(H)];

    Clusters[i].DrawingColor := RandomColor;
  end;

  Clusters[0].Center := clBlack;
  Clusters[K - 1].Center := clWhite;

  i := 0;

  // Repeat the clustering until convergence
  repeat

    if Assigned(StatusCallback) then
    begin
      Status := Format('Clustering iteration %d of %d', [i, 10]);
      StatusCallback(Status);
    end;

    GroupPixels2NearestCluster(Input, Clusters);

    if Assigned(StatusCallback) then
    begin
      Status := 'Updating cluster centers...';
      StatusCallback(Status);
    end;

    Changed := FindNewClusterCentroids(Clusters);

    if Assigned(StatusCallback) then
    begin
      Status := ClusterCentroidsToString(Clusters);
      StatusCallback(Status);
    end;

    inc(i);

    if Assigned(BitmapProcessCallback) then
    begin
      UpdateClusterImage(Input, Output, Clusters);

      BitmapProcessCallback(Output);
    end;
  until ((i > 10) or (NOT Changed));

  UpdateClusterImage(Input, Output, Clusters);

  if Assigned(StatusCallback) then
  begin
    Status := 'FINAL: ' + ClusterCentroidsToString(Clusters) + 'ITER:' +
      i.ToString;
    StatusCallback(Status);
  end;

end;

end.

VCL und FMX Bitmap funktionieren grundsätzlich anders und sind nicht so einfach kompatibel.
Bei FMX müsste mal TMapAccess nutzen, um Read/Write auf Pixel zu machen.
Vielleicht hilft das, als Gedankenanstoss
https://stackoverflow.com/questions/...l-imaging-pngi
https://docwiki.embarcadero.com/Libr...cs.TBitmap.Map
https://docwiki.embarcadero.com/Libr...cs.TBitmapData


Ich würde versuchen die Kernfunktionen zu isolieren und dann jeweils für VCL und FMX gesondert zu optimieren.
So viel Aufwand wird das nicht sein und am Ende sollte alles nach Außen schön kompatibel sein.

Bezüglich der Frage nach der Geschwindigkeit... der Zugriff auf Canvas.Pixels ist so ziemlich das Langsamste, das du machen kannst... und das auch noch in einer inneren Schleife mehrfach.

Mit dem schon genannten TMapAccess kannst du auch in FMX Scanline nutzen und in VCL TBitmap sowieso. Das sollte daher recht ähnlich sein und ist zumindest für VCL deutlich schneller als Pixels. Bei FMX mag der Unterschied geringer sein.