Image Segementation with K means für VCL und FMX Framework, Teil #2

[bernhard_LA]

ich hatte unter https://www.delphipraxis.net/214380-...framework.html eine erste Implementierung einer Image Segmentation mittels Kmeans Algorithmus vorgestellt (VCL Framework).
Rechendauer für ein Demo Bild mit 400*400 pixel ca. 10 sec.
jetzt habe ich eine Implementierung welche die Canvas.Pixels Zugriffe minimiert, nur leider hat sich in dieser Generic Implementierung die Rechnzeit auf 10 min erhöht.

Hat jemand eine Idee wie ich hier auf eine Ausführungszeit < 10 sec komme ??
( PS: vielleich probiert jemand den Code auch aus :-) )

Delphi-Quellcode:

// Define a centroid function that returns the TClusterData object with the average coordinates of all elements in the cluster
function Centroidfct(const A: TClusterDataREC): Cardinal;
begin
  Result := Round((A.DrawingColor and $FF) + ((A.DrawingColor shr 8) and $FF) +
    ((A.DrawingColor shr 16) and $FF)) div 3;
end;

function DistanceMetric(const A, B: TClusterDataREC): Double;
begin
  // Result := Sqrt(Sqr(A.x - B.x) + Sqr(A.y - B.y));

  Result := ABS(Centroidfct(A) - Centroidfct(B));
end;

procedure TForm1.Button_FullTestClick(Sender: TObject);
var
  MyKMeans: TImageClusterKMeans;
  Stopwatch: TStopwatch;
begin
  // Create a new TStopwatch instance
  // Stopwatch := TStopwatch.Create;
  DebugMemo.lines.Clear;

  Stopwatch.Reset;



  UpdateStatus('start kmean image segmentation ...');

  try

    // Start the stopwatch
    Stopwatch.Start;

    MyKMeans := TImageClusterKMeans.Create(5, DistanceMetric, Centroidfct, 10,
      UpdateStatus);
    try
      MyKMeans.LoadData(FBitmap);

      MyKMeans.Execute;

      MyKMeans.SaveData(FOutBitmap);

      FOutBitmap.SaveToFile('c:\temp\outkmeans.bmp');

      OutImage.Picture.Bitmap.Assign(FOutBitmap);

    finally
      MyKMeans.Free;

      UpdateStatus('kmean image segmentation done!');
    end;

    Stopwatch.Stop;

    DebugMemo.lines.Add(Format('Elapsed time: %d ms',
      [Stopwatch.ElapsedMilliseconds]));

  finally
    // Free the TStopwatch instance
    // Stopwatch.Free;
  end;
end;

Delphi-Quellcode:

unit Unit_TKmeans;

interface

uses types, classes, SysUtils, Generics.Collections,
{$IFDEF FrameWork_VCL}
  vcl.Graphics;
{$ENDIF}
{$IFDEF FrameWork_FMX}
System.UITypes, System.UIConsts, FMX.types, FMX.Utils, FMX.Graphics;
{$ENDIF}

const
  Infinity = 10000000;

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

type
  TClusterDataREC = record
{$IFDEF FrameWork_VCL}
    DrawingColor: TColor;
{$ENDIF}
{$IFDEF FrameWork_FMX}
    DrawingColor: TAlphaColor;
{$ENDIF}
    x, y: Integer;
    chrlabel: char;
    // ...
    // ..
    // .
  end;

  TClusterData = class
    DrawingColor: TColor;
    x, y: Integer;
    chrlabel: char;
    // ...
    // ..
    // .
  end;

  /// <summary>
  /// a bit different pixeldefinition
  /// </summary>
  TClusterDataREC2 = record
    BWColor: Byte;
    x, y: Integer;
    // tbd.
    // ...
    // ..
    // .
  end;

  /// <summary>
  /// here it can be just a simple pixel description,
  /// in general  we store the  complete orginal data inside this list
  /// </summary>
  TRawData<T> = class(TList<T>)
  end;

  /// <summary>
  /// store the  data now inside a  cluster  with a  Centroid
  /// </summary>
  TCluster<T> = record
    /// <summary>
    /// <para>
    /// as of today T, but in future some other data type , depending
    /// </para>
    /// <para>
    /// on future research :-)
    /// </para>
    /// </summary>
    Center: T;

    /// <summary>
    /// the selected elements from out complete raw data
    /// </summary>
    ClusterElements: TArray<T>;
  end;

  /// <summary>
  /// the cluster list
  /// </summary>
  TClusterList<T> = class(TList < TCluster < T >> )
  private
    function GetItem(Aindex: Integer): TCluster<T>;
    procedure SetItem(Aindex: Integer; const Value: TCluster<T>);
  public

    property Items[Aindex: Integer]: TCluster<T> Read GetItem Write SetItem;
  end;

type
  /// <summary>
  /// measure the distance according to this function
  /// </summary
TDistanceMetricfunction < T >= reference to
function(const A, B: T): Double;

type
  /// <summary>
  /// result of this function could be the TColor value , but also
  /// coordinates  my have some impact in future ....
  /// </summary
TCentroidfunction < T >= reference to
function(const A: T): Cardinal;

type
  TKMeans<T> = class
  private

  private
    FClusteredData: TClusterList<T>;

    FRawData: TArray<T>;

    FNumClusters: Integer;

    FDistanceMetric: TDistanceMetricfunction<T>;

    FCentroidfct: TCentroidfunction<T>;

    FMaxIterations: Integer;

    FStatusCallback: TStatusCallback;

  public
    constructor Create(NumClusters: Integer;
      DistanceMetric: TDistanceMetricfunction<T>;
      Centroidfct: TCentroidfunction<T>; MaxIterations: Integer = 10;
      StatusCallback: TStatusCallback = nil);

    function FindNewClusterCentroids: Boolean;

    function InitClusters: Boolean;

    function Execute: Integer;

    function ClusterCentroidsToString: String; virtual; abstract;

    procedure GroupData2NearestCluster;

    property RawData: TArray<T> read FRawData write FRawData;
  end;

type
  TImageClusterKMeans = class(TKMeans<TClusterDataREC>)
  private
    FBMPwidth: Integer;
    FBMPheight: Integer;
  public

    function ClusterCentroidsToString: String;

    procedure LoadData(SoureBitMap: TBitmap);

    procedure SaveData(OutBitMap: TBitmap);
  end;

implementation

constructor TKMeans<T>.Create(NumClusters: Integer;
  DistanceMetric: TDistanceMetricfunction<T>; Centroidfct: TCentroidfunction<T>;
  MaxIterations: Integer = 10; StatusCallback: TStatusCallback = nil);
begin
  FNumClusters := NumClusters;
  FDistanceMetric := DistanceMetric;
  FMaxIterations := MaxIterations;

  FClusteredData := TClusterList<T>.Create;

  // FRawData := TRawData<T>.Create;

  FDistanceMetric := DistanceMetric;

  FCentroidfct := Centroidfct;

  FStatusCallback := StatusCallback;
end;

function TKMeans<T>.Execute: Integer;
var
  i: Integer;
  Changed: Boolean;
  Status: String;
begin

  i := 0;

  if (self.InitClusters) then
  begin
    repeat
      GroupData2NearestCluster;

      Changed := FindNewClusterCentroids;

      inc(i);

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

    until ((i > FMaxIterations) or (NOT Changed));
  end;

  result := i;

end;

function TKMeans<T>.FindNewClusterCentroids: Boolean;
var
  i, j: Integer;
  SelectedCluster: TCluster<T>;
  OldCentroid: Cardinal;
  ElementCount: Cardinal;
  Centroid: Cardinal;
begin

  for i := 0 to FClusteredData.Count - 1 do
  begin
    SelectedCluster := FClusteredData.Items[i];
    ElementCount := length(SelectedCluster.ClusterElements);
    OldCentroid := FCentroidfct(SelectedCluster.Center);

    for j := low(SelectedCluster.ClusterElements)
      to High(SelectedCluster.ClusterElements) do
    begin
      Centroid := Centroid + FCentroidfct(SelectedCluster.ClusterElements[j]);
    end;

    if (ElementCount <> 0) then
    begin
      Centroid := Round(Centroid / ElementCount);
    end
    else
    begin
      // this  should not happen !
    end;

  end;

  result := true;

end;

procedure TKMeans<T>.GroupData2NearestCluster;
var
  i, j: Integer;
  closestCluster: Integer;
  minDist: Double;
  Dist: Double;
  ReferenceClusterCenter: T;
  RawDataItem: T;
  UpdateCluster: TCluster<T>;
begin
  /// loop all raw data elements
  for j := low(FRawData) to high(FRawData) do
  begin
    RawDataItem := FRawData[j];
    closestCluster := -1;
    minDist := Infinity;

    // Find the nearest cluster
    for i := 0 to FClusteredData.Count - 1 do
    begin
      Dist := FDistanceMetric(RawDataItem, FClusteredData[i].Center);
      if Dist < minDist then
      begin
        closestCluster := i;
        minDist := Dist;
      end;
    end;

    // these lines are wrong and do not compile, fix the  code here !!!!
    UpdateCluster := FClusteredData[closestCluster];

    SetLength(UpdateCluster.ClusterElements,
      length(UpdateCluster.ClusterElements) + 1);

    UpdateCluster.ClusterElements[High(UpdateCluster.ClusterElements)] :=
      FRawData[j];

    FClusteredData[closestCluster] := UpdateCluster;
  end;
end;

function TKMeans<T>.InitClusters: Boolean;
var
  OneCluster: TCluster<T>;
  i: Integer;
  DataSize: Integer;
begin

  DataSize := length(FRawData);
  FClusteredData.Clear;

  // Initialize the clusters with randomly chosen centers
  for i := 1 to FNumClusters do
  begin
    OneCluster.Center := FRawData[Random(DataSize)];
    SetLength(OneCluster.ClusterElements, 0);
    FClusteredData.Add(OneCluster);
  end;

  result := ((FClusteredData.Count = FNumClusters) and
    (DataSize > FNumClusters));

end;

{$IFDEF FrameWork_VCL}

procedure TImageClusterKMeans.SaveData(OutBitMap: TBitmap);
var
  i, j: Integer;
  ClusterIndex: Integer;
  closestCluster: Integer;
  minDist: Double;
  Dist: Double;
  OneCluster: TCluster<TClusterDataREC>;
  ClusteredData: TClusterDataREC;
begin
  // Loop through all the pixels in the output bitmap

    // Clear the old data
  OutBitMap.Height := FBMPheight;
  OutBitMap.Width := FBMPwidth;
  OutBitMap.PixelFormat := pf24bit;

  for i := 0 to FClusteredData.Count - 1 do
  begin
    OneCluster := FClusteredData[i];

    for j := low(OneCluster.ClusterElements)
      to high(OneCluster.ClusterElements) do
    begin

      ClusteredData := OneCluster.ClusterElements[j];

      OutBitMap.Canvas.Pixels[ClusteredData.x, ClusteredData.y] :=
        OneCluster.Center.DrawingColor;

    end;
  end;

  // Save the output bitmap to a file or show it in a GUI component
  // For example, to save the bitmap to a file:
  OutBitMap.SaveToFile('c:\temp\output.bmp');


end;

function TImageClusterKMeans.ClusterCentroidsToString: String;
var
  i: Integer;
  OneCluster: TCluster<TClusterDataREC>;
begin
  result := '';
  for i := 0 to FClusteredData.Count - 1 do
  begin
    OneCluster := FClusteredData[i];
{$IFDEF FrameWork_VCL}
    result := result + ColorToString(OneCluster.Center.DrawingColor) + '|' +
      IntTostr(length(OneCluster.ClusterElements)) + '; ';
{$ENDIF}
{$IFDEF FrameWork_FMX}
    result := result + AlphaColorToString(OneCluster.Center.DrawingColor) + '|'
      + IntTostr(length(OneCluster.ClusterElements)) + '; ';
{$ENDIF}
  end;
end;

procedure TImageClusterKMeans.LoadData(SoureBitMap: TBitmap);
var
  x, y: Integer;
  ClusterData: TClusterDataREC;
begin
  // Clear the old data
  SetLength(FRawData, SoureBitMap.Height * SoureBitMap.Width);
  FBMPwidth := SoureBitMap.Width;
  FBMPheight := SoureBitMap.Height;

  // Loop through all the pixels in the bitmap
  for y := 0 to SoureBitMap.Height - 1 do
  begin
    for x := 0 to SoureBitMap.Width - 1 do
    begin
      // Create a TClusterData object for each pixel
      ClusterData.DrawingColor := SoureBitMap.Canvas.Pixels[x, y];
      ClusterData.x := x;
      ClusterData.y := y;

      // Add the TClusterData object to the FRawData list
      FRawData[y * SoureBitMap.Width + x] := ClusterData;
    end;
  end;
end;
{$ENDIF}
{$IFDEF FrameWork_FMX}

procedure SetPixel(Color: TAlphaColor; i, j: Integer; bitdata: TBitmapData;
  PixelFormat: TPixelFormat);
begin
  AlphaColorToPixel(Color, @PAlphaColorArray(bitdata.Data)
    [j * (bitdata.Pitch div PixelFormatBytes[PixelFormat]) + 1 * i],
    PixelFormat);

end;

function GetPixel(i, j: Integer; bitdata: TBitmapData;
  PixelFormat: TPixelFormat): TAlphaColor;
begin

  result := PixelToAlphaColor(@PAlphaColorArray(bitdata.Data)
    [j * (bitdata.Pitch div PixelFormatBytes[PixelFormat]) + 1 * i],
    PixelFormat);
end;

procedure TImageClusterKMeans.SaveData(OutBitMap: TBitmap);
var
  bitdata1: TBitmapData;
  i: Integer;
  j: Integer;
  Color: TAlphaColor;
  Cquer: Byte;
  OneCluster: TCluster<TClusterDataREC>;
  ClusteredData: TClusterDataREC;
begin

  // Clear the old data
  OutBitMap.Height := FBMPheight;
  OutBitMap.Width := FBMPwidth;

  // Loop through all the pixels in the bitmap

  if (OutBitMap.Map(TMapAccess.ReadWrite, bitdata1)) then
    try

      for i := 0 to FClusteredData.Count - 1 do
      begin
        OneCluster := FClusteredData[i];

        for j := low(OneCluster.ClusterElements)
          to high(OneCluster.ClusterElements) do
        begin

          ClusteredData := OneCluster.ClusterElements[j];

          SetPixel(OneCluster.Center.DrawingColor, ClusteredData.x,
            ClusteredData.y, bitdata1, OutBitMap.PixelFormat)
        end;
      end;

    finally
      OutBitMap.Unmap(bitdata1);
    end;
end;

procedure TImageClusterKMeans.LoadData(SoureBitMap: TBitmap);
var
  bitdata1: TBitmapData;
  i: Integer;
  j: Integer;
  Color: TAlphaColor;
  Cquer: Byte;

  ClusterData: TClusterDataREC;
begin

  // Clear the old data
  SetLength(FRawData, SoureBitMap.Height * SoureBitMap.Width);
  FBMPwidth := SoureBitMap.Width;
  FBMPheight := SoureBitMap.Height;


  // Loop through all the pixels in the bitmap

  if (SoureBitMap.Map(TMapAccess.ReadWrite, bitdata1)) then
    try
      for i := 0 to SoureBitMap.Width - 1 do
        for j := 0 to SoureBitMap.Height - 1 do
        begin
          Color := GetPixel(i, j, bitdata1, SoureBitMap.PixelFormat);

          Cquer := Round(TAlphaColorRec(Color).B * 0.3 + TAlphaColorRec(Color).G
            * 0.59 + TAlphaColorRec(Color).R * 0.11);

          ClusterData.DrawingColor := Color;
          ClusterData.x := i;
          ClusterData.y := j;

          // Add the TClusterData object to the FRawData list
          FRawData[j * SoureBitMap.Width + i] := ClusterData;


        end;

    finally
      SoureBitMap.Unmap(bitdata1);
    end;
end;

{$ENDIF}
{ TClusterList<T> }

function TClusterList<T>.GetItem(Aindex: Integer): TCluster<T>;
begin
  result := inherited Items[Aindex];
end;

procedure TClusterList<T>.SetItem(Aindex: Integer; const Value: TCluster<T>);
begin
  inherited Items[Aindex] := Value;
end;

end.

[TurboMagic]

Hilft es was die in der Schleife im Execute aufgerufenen Unterroutinen
als Inline zu deklarieren? Dann fällt zumindest der Overhead der Funktionsaufrufe weg...

[Sinspin]

Delphi-Quellcode:

      
...
ClusterData.DrawingColor := SoureBitMap.Canvas.Pixels[x, y];
...

Canvas.Pixels ist für sowas generell ungeeignet. Das ist als wolltest Du ein Fahrrad den weg tragen anstatt es zu fahren.

TBitmap hat ScanLine. Je nach gesetztem PixelFormat liefert es pro Aufruf einen Zeiger auf eine Zeile Pixel. Du hast da dann RGB (PixelFormat pf24Bit) oder ARGB (PixelFormat pf32Bit) direkt drinne stehen.

[TiGü]

Zitat:

Zitat von bernhard_LA (Beitrag 1531946)

( PS: vielleich probiert jemand den Code auch aus :-) )

Dafür wäre ein durchkompilierbares Projekt als Zip-Archiv ganz hilfreich.
So muss man ganz schön viel machen, bis das der Quelltext am Laufen ist.

[TiGü]

Was ist das denn für ein Anfängerfehler in procedure TKMeans<T>.GroupData2NearestCluster?

Delphi-Quellcode:

    SetLength(UpdateCluster.ClusterElements,
      length(UpdateCluster.ClusterElements) + 1);

Das wird doch bei jeden neuen Vergrößern alle Daten umkopiert! Und das wird sehr schnell sehr groß!

[bernhard_LA]

*.zip bzw. Download link kommt heute noch



was wäre die Lösung um das unkopieren zu sparen bzw. schneller zu machen?

[TiGü]

TCluster wird eine Klasse und ClusterElements eine Liste.
Ich bin gleich soweit und stelle das Ergebnis gleich rein.

[TiGü]

Hier meine Verbesserungen.
LoadData kann analog wie SaveData verbessert werden, dass überlasse ich dir aber als Übung.
Lesetipp: https://blog.dummzeuch.de/2019/12/12...lls-in-delphi/

Die Bitmap am besten auch in C:\Temp werfen oder über den anderen Button eine neue Öffnen.

Anhang 56553

[bernhard_LA]

die Projekte gibt es hier zum Download, https://github.com/ImageProcessingFM...in/VCL_AND_FMX

[Sinspin]

Zitat:

Zitat von bernhard_LA (Beitrag 1531946)

( PS: vielleich probiert jemand den Code auch aus :-) )

Du meinst das ernst??? Wenn ja, dann wäre es toll wenn der Quelltext vollständig wäre!