Durchschnittsfarbe eines Bitmap "schnell" ermitteln

[KodeZwerg]

Guten morgen Gemeinde!

Ein Neuer Tag, ein neues problem

Ich versuche aus einem Bitmap eine Durchschnittsfarbe zu ermitteln.

Bei dummzeuch wurde ich zwar fündig was mir bereits sehr half es zu beschleunigen, aber seine letzte Optimierung bekomme ich einfach nicht hin.

Hier ist das was ich aus seinem guten Beispiel #2 gemacht habe, es funktioniert, aber doch recht langsam:

Delphi-Quellcode:

function TfrmMain.GetAvgBmpColor: TColor;
type
  TRgbTriple = packed record
    // do not change the order of the fields, do not add any fields
    Blue: Byte;
    Green: Byte;
    Red: Byte;
  end;
  TRgbTripleArray = packed array[0..MaxInt div SizeOf(TRgbTriple) - 1] of TRgbTriple;
  PRgbTripleArray = ^TRgbTripleArray;
var
  x, y: Integer;
  r, g, b: Integer;
  Pixel: TRgbTriple;
  Bmp: TBitmap;
  Filename: string;
  fs: TFileStream;
  wic: TWICImage;
  img: TImage;
begin
  Filename := 'X:\Pfad\Bildname.ext';
  if not FileExists(Filename) then
    Exit;
  bmp := TBitmap.Create;
  wic := TWICImage.Create;
  img := TImage.Create(Self);
  fs := TFileStream.Create(Filename, fmOpenRead);
  try
    bmp.PixelFormat := pf24bit;
    fs.Position := 0;
    wic.LoadFromStream(fs);
    Img.Picture.Assign(wic);
    bmp.Width := Img.Picture.Width;
    bmp.Height := Img.Picture.Height;
    bmp.Canvas.Draw(0, 0, Img.Picture.Graphic);
    r := 0; g := 0; b := 0;
    Assert(bmp.PixelFormat = pf24bit);
    for y := 0 to Pred(bmp.Height) do
      begin
        for x := 0 to Pred(bmp.Width) do
          begin
            Pixel := PRgbTripleArray(bmp.Scanline[y])^[x];
            r := r + Pixel.Red;
            g := g + Pixel.Green;
            b := b + Pixel.Blue;
          end;
      end;
    r := r div (bmp.Width * bmp.Height);
    g := g div (bmp.Width * bmp.Height);
    b := b div (bmp.Width * bmp.Height);
  finally
    Result := RGB(r, g, b);
    bmp.Free;
    fs.Free;
    wic.Free;
    img.Free;
  end;
end;

Sorry für meine schludrige code gestaltung, ist erst alpha phase.


Weiß jemand wie man das eventuell mit diesem Code #3 hinbekommt?

Delphi-Quellcode:

// if you are using Delphi 2007 or older you need to correct the NativeInt declaration from 8 bytes to 4 bytes:
{$IF SizeOf(Pointer) = 4}
type
  NativeInt = Integer;
{$IFEND}

function AddToPtr(const _Ptr: Pointer; _Offset: NativeInt): Pointer; inline;
begin
  Result := Pointer(NativeInt(_Ptr) + _Offset);
end;

function PtrDiff(const _Ptr1, _Ptr2: Pointer): NativeInt; inline;
begin
  Result := NativeInt(_Ptr1) - NativeInt(_Ptr2);
end;

var
  BytesPerPixel: NativeInt;
  InScanLine0: Pointer;
  InBytesPerLine: NativeInt;
  OutScanLine0: Pointer;
  InBytesPerLine: NativeInt;
  InPixel: PRgbTriple;
  OutPixel: PRgbTriple;
// ...
  BytesPerPixel := SizeOf(Pixel) 
  InScanLine0 := InBmp.ScanLine[0];
  InBytesPerLine := NativeInt(_InBmp.ScanLine[1]) - NativeInt(InScanLine0);
  OutScanLine0 := _OutputBmp.ScanLine[0];
  OutBytesPerLine := NativeInt(_OutBmp.ScanLine[1]) - NativeInt(OutScanLine0);
  OutPixel := OutScanLine0;
  for y := 0 to Height - 1 do begin
    for x := 0 to Width - 1 do begin
      InPixel := AddToPtr(InScanLine0, InBytesPerLine * y + x * BytesPerPixel);
      Pixel := InPixel^;
      doSomething(Pixel);
      OutPixel := AddToPtr(OutScanLine0, OutBytesPerLine * y + x * BytesPerPixel);
      OutPixel^ := Pixel;
    end;
  end;

Ich bekomme immer den Fehler das "Pixel" nicht mit "InPixel^" kompatibel ist und weiß gerade nicht weiter.

[Renate Schaaf]

Zitat von KodeZwerg:

Ich bekomme immer den Fehler das "Pixel" nicht mit "InPixel^" kompatibel ist und weiß gerade nicht weiter.

Ich finde ums Verrecken nicht, wo du Pixel deklariert hast. Müsste TRGBTriple sein. Ansonsten: OutPixel brauchst du nicht, einfach die Pixel-Werte aufsummieren wie vorher etc., brauch ich wohl nicht zu erklären.

[TiGü]

Delphi-Quellcode:

function TForm3.GetAvgBmpColor: TColor;
type
  TRgbTriple = packed record
    // do not change the order of the fields, do not add any fields
    Blue: Byte;
    Green: Byte;
    Red: Byte;
  end;
  TRgbTripleArray = packed array[0..MaxInt div SizeOf(TRgbTriple) - 1] of TRgbTriple;
  PRgbTripleArray = ^TRgbTripleArray;
var
  x, y: Integer;
  r, g, b: Integer;
  Pixel: TRgbTriple;
  Bmp: TBitmap;
  Filename: string;
  wic: TWICImage;
  Resolution: Integer;
  ScanLinePtr: Pointer;
begin
  Result := 0;
  Filename := 'Der magische Pfad';
  if not FileExists(Filename) then
    Exit;
  bmp := TBitmap.Create;
  wic := TWICImage.Create;
  try
    wic.LoadFromFile(Filename);
    bmp.Assign(wic);
    bmp.PixelFormat := pf24bit;
    r := 0;
    g := 0;
    b := 0;
    Assert(bmp.PixelFormat = pf24bit);

    for y := 0 to Pred(Bmp.Height) do
    begin
      ScanLinePtr := bmp.Scanline[y];  // der springende Punkt!
      for x := 0 to Pred(Bmp.Width) do
      begin
        Pixel := PRgbTripleArray(ScanLinePtr)^[x];
        r := r + Pixel.Red;
        g := g + Pixel.Green;
        b := b + Pixel.Blue;
      end;
    end;

    Resolution := (bmp.Width * bmp.Height);
    r := r div Resolution;
    g := g div Resolution;
    b := b div Resolution;
    Result := RGB(r, g, b);
  finally
    bmp.Free;
    wic.Free;
  end;
end;

[dummzeuch]

Zitat von KodeZwerg:

Weiß jemand wie man das eventuell mit diesem Code #3 hinbekommt?

Delphi-Quellcode:

// if you are using Delphi 2007 or older you need to correct the NativeInt declaration from 8 bytes to 4 bytes:
{$IF SizeOf(Pointer) = 4}
type
  NativeInt = Integer;
{$IFEND}

function AddToPtr(const _Ptr: Pointer; _Offset: NativeInt): Pointer; inline;
begin
  Result := Pointer(NativeInt(_Ptr) + _Offset);
end;

function PtrDiff(const _Ptr1, _Ptr2: Pointer): NativeInt; inline;
begin
  Result := NativeInt(_Ptr1) - NativeInt(_Ptr2);
end;

var
  BytesPerPixel: NativeInt;
  InScanLine0: Pointer;
  InBytesPerLine: NativeInt;
  OutScanLine0: Pointer;
  InBytesPerLine: NativeInt;
  InPixel: PRgbTriple;
  OutPixel: PRgbTriple;
// ...
  BytesPerPixel := SizeOf(Pixel) 
  InScanLine0 := InBmp.ScanLine[0];
  InBytesPerLine := NativeInt(_InBmp.ScanLine[1]) - NativeInt(InScanLine0);
  OutScanLine0 := _OutputBmp.ScanLine[0];
  OutBytesPerLine := NativeInt(_OutBmp.ScanLine[1]) - NativeInt(OutScanLine0);
  OutPixel := OutScanLine0;
  for y := 0 to Height - 1 do begin
    for x := 0 to Width - 1 do begin
      InPixel := AddToPtr(InScanLine0, InBytesPerLine * y + x * BytesPerPixel);
      Pixel := InPixel^;
      doSomething(Pixel);
      OutPixel := AddToPtr(OutScanLine0, OutBytesPerLine * y + x * BytesPerPixel);
      OutPixel^ := Pixel;
    end;
  end;

Ich bekomme immer den Fehler das "Pixel" nicht mit "InPixel^" kompatibel ist und weiß gerade nicht weiter.

Wo ist denn die Variable Pixel deklariert und als was? Wenn es die irgendwo in der RTL/VCL oder sonstigen Units gibt, die Du einbindest, könnte das die Fehlermeldung erklären.

[KodeZwerg]

Zitat von Renate Schaaf:

Zitat von KodeZwerg:

Ich bekomme immer den Fehler das "Pixel" nicht mit "InPixel^" kompatibel ist und weiß gerade nicht weiter.

Ich finde ums Verrecken nicht, wo du Pixel deklariert hast. Müsste TRGBTriple sein. Ansonsten: OutPixel brauchst du nicht, einfach die Pixel-Werte aufsummieren wie vorher etc., brauch ich wohl nicht zu erklären.

Zitat von dummzeuch:

Wo ist denn die Variable Pixel deklariert und als was? Wenn es die irgendwo in der RTL/VCL oder sonstigen Units gibt, die Du einbindest, könnte das die Fehlermeldung erklären.

Der erste code ist aus seinem blog nur halt für mich angepasst.
Der zweite code ist 1:1 aus seinem blog, es sind 3 teile die aufeinander aufbauen.

//edit
ich bin ja auch noch nicht ganz wach, hallo dummzeuch, DANKE für deine blog!!

@TiGü: WAHNSINN!! Danke für code-optimierung plus das einarbeiten des dritten codes!!

[Michael II]

In einigen der hier geposteten Beispiele befürchte ich bei grossen Bitmaps Integerüberlauf in r,g,b.

Wenn zum Beispiel jedes Pixel einer Bitmap einen Rotwert=255 aufweist, dann läuft r nach >maxint/255 Pixeln über.

Oder etwas anders geschrieben: Eine quadratische Bitmap mit >2901 Pixel Seitenlänge und Rotwert=255 wäre nicht gut...

[TiGü]

Du kannst dir noch ein paar Millisekunden sparen, wenn du nicht den "Umweg" über TBitmap machst:

Delphi-Quellcode:

uses
    Winapi.Wincodec;

type
    TWICImageHelper = class helper for TWICImage
        function GetAverageColor: TColor;
    end;

function TForm3.GetAvgBmpColor: TColor;
var
  Filename: string;
  wic: TWICImage;
begin
  Result := 0;
  Filename := 'Dein Pfad zur Bilddatei';
  if not FileExists(Filename) then
    Exit;
  wic := TWICImage.Create;
  try
    wic.LoadFromFile(Filename);
    Result := wic.GetAverageColor;
  finally
    wic.Free;
  end;
end;

{ TWICImageHelper }

function TWICImageHelper.GetAverageColor: TColor;
type
  // copy from Vcl.Graphics
  PRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = array [Byte] of Winapi.Windows.TRGBQuad;
var
  LWicBitmap: IWICBitmapSource;
  Stride: Cardinal;
  Buffer: array of Byte;
  x, y: Integer;
  BGRAPixel: TRGBQuad;
  r, g, b, Resolution, LBytesPerScanline: Integer;
  ScanLinePtr: Pointer;
begin
  Result := 0;
  with Self do
  begin
    if FWicBitmap = nil then 
      Exit;

    FWicBitmap.GetSize(FWidth, FHeight);

    Stride := FWidth * 4;
    SetLength(Buffer, Stride * FHeight);

    WICConvertBitmapSource(GUID_WICPixelFormat32bppBGRA, FWicBitmap, LWicBitmap);
    LWicBitmap.CopyPixels(nil, Stride, Length(Buffer), @Buffer[0]);

    r := 0;
    g := 0;
    b := 0;
    LBytesPerScanline := BytesPerScanline(FWidth, 32, 32);
    for y := 0 to FHeight - 1 do
    begin
      ScanLinePtr := PByte(@Buffer[0]) + y * LBytesPerScanline;
      for x := 0 to FWidth - 1 do
      begin
        BGRAPixel := PRGBQuadArray(ScanLinePtr)^[x];
        r := r + BGRAPixel.rgbRed;
        g := g + BGRAPixel.rgbGreen;
        b := b + BGRAPixel.rgbBlue;
      end;
    end;
    Resolution := FWidth * FHeight;
  end;
  r := r div Resolution;
  g := g div Resolution;
  b := b div Resolution;
  Result := RGB(r, g, b);
end;

Kam bei mir zumindest das gleiche Ergebnis bei rum, bitte nachprüfen!

[KodeZwerg]

Zitat von Michael II:

In einigen der hier geposteten Beispiele befürchte ich bei grossen Bitmaps Integerüberlauf in r,g,b.

Wenn zum Beispiel jedes Pixel einer Bitmap einen Rotwert=255 aufweist, dann läuft r nach >maxint/255 Pixeln über.

Oder etwas anders geschrieben: Eine quadratische Bitmap mit >2901 Pixel Seitenlänge und Rotwert=255 wäre nicht gut...

Danke für diesen Hinweis, mit sowas habe ich nicht gerechnet!
Könnte eine Änderung auf var r, g, b: Int64; da helfen?

Zitat von TiGü:

Du kannst dir noch ein paar Millisekunden sparen, wenn du nicht den "Umweg" über TBitmap machst:
Kam bei mir zumindest das gleiche Ergebnis bei rum, bitte nachprüfen!

Ein paar ms?? Du willst mich jetzt veralbern, das Ding ist enorm schnell! (habe es jetzt nicht gebencht, vorher konnte ich noch zur Tasse greifen, nun ist es bereits nach dem anklicken ausgeführt, Hammer!) Bei mir sind die Werte auch passend/stimmen mit ur-version plus deinem update + deinem update!
Vom Geschwindigkeitsvergleich, meine ur-ur Version war ein Trabbi, danach fand ich dummzeuchs blog und ich hatte einen Sportwagen. Deine erste version war ein Tiefergelegter aufgemotzter Sportwagen, nun ist es ein Formel-1 Wagen!

Ich nahm in Post #1 nur das WIC weil ich vorher nicht wissen kann was für ein Bildformat reinkommt, so als universal Empfänger halt, Konvertierung zu bmp nahm ich weil ich da wusste das es ein ScanLine gibt für die Punkte.

Damit hast Du mir echt eine riesen Freude gemacht! Ganz herzlich vielen Dank für die Mühe, das ist Top!

[TiGü]

Jo, gerne!
Was dem einen sein Problem, ist mein tägliches Code Kata.

Man kann das bestimmt noch weiter optimieren.
Bei der Addition der drei 32-Bit-Zahlen (oder 64-Bit, wenn man in keinen Überlauf will) gibt es bestimmt irgendeine kluge x64-Assemblerfunktion.
Oder man schreibt die Schleifen um, so das nur jedes zweite oder vierte Pixel angeguckt wird.
Je nachdem, wie genau man den Durchschnitt braucht.

[Rollo62]

Zitat von Michael II:

In einigen der hier geposteten Beispiele befürchte ich bei grossen Bitmaps Integerüberlauf in r,g,b.

Ja das sprang mir auch gerade ins Auge.
Trotzdem, theoretisch gibt es Überläufe erst ab Bildgrößen von 24000x24000.
Ich denke es ist noch ein bischen Zeit bis dahin

Aber ich würde auch einen Test o.ä. anlegen, der aufpoppt falls solche Größen mal erreicht werden.