|
Registriert seit: 8. Jun 2009 Ort: Bayern 1.138 Beiträge Delphi 11 Alexandria |
#1
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 ![]()
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;
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. |
![]() |
Ansicht |
![]() |
![]() |
![]() |
ForumregelnEs ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.
BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus. Trackbacks are an
Pingbacks are an
Refbacks are aus
|
|
Nützliche Links |
Heutige Beiträge |
Sitemap |
Suchen |
Code-Library |
Wer ist online |
Alle Foren als gelesen markieren |
Gehe zu... |
LinkBack |
![]() |
![]() |