Floyd-Steinberg Dithering

[shmia]

Ich hätte hier einen Floyd-Steinberg-Algorithmus, der allerdings noch etwas Optimierung benötigt.
Im Prinzip habe ich nur den Pseudocode auf Wikipedia in Delphi umgesetzt.

Wer also gerne mit Grafik spielt, ist aufgerufen, den Code mit Hilfe von Scanline[] und anderen Tricks zu beschleunigen. :hi:

Delphi-Quellcode:

function find_closest_palette_color(Color:TColor):TColor;
begin
//  Color := ColorToRGB(Color);  // wird nicht benötigt, da 24-Bit Bitmap vorhanden
  Result := GetBValue(Color) * 21      // Blue
    + GetGValue(Color) * 174   // Green
    + GetRValue(Color) * 61;  // Red
  if Result >= 32768 then  // 128*256
   Result := clWhite
  else
   Result := clBlack;
end;

type
TError = record
  R, G, B : integer;
end;

// Fehler zwischen zwei Farben berechnen
function CalcError(a,b : TColor):TError;
begin
   Result.R := GetRValue(a)-GetRValue(b);
   Result.G := GetGValue(a)-GetGValue(b);
   Result.B := GetBValue(a)-GetBValue(b);
end;

{**************************************************************************
 * NAME:    ApplyError
 * DESC:    Korrigiert die übergebene Farbe um den Wert err * mul/16
 * PARAMS:  color  - orginale Farbe
 *          err    - Farbabweichung
 *          factor - Korrekturfaktor
 * RESULT:  korrigierte Farbe
 *************************************************************************}
function ApplyError(color:TColor; err:TError; factor:Integer):TColor;
var
   r,g,b : Integer;
begin
   // Hinweis: div 16 lässt sich leider nicht durch shr 4 ersetzen
   // da dann anscheinend das Vorzeichen nicht richtig behandelt wird
   r := GetRValue(color) + ((err.R * factor) div 16);
   if r < 0 then r := 0
   else if r > 255 then r := 255;
   g := GetGValue(color) + ((err.G * factor) div 16);
   if g < 0 then g := 0
   else if g > 255 then g := 255;
   b := GetBValue(color) + ((err.B * factor) div 16);
   if b < 0 then b := 0
   else if b > 255 then b := 255;
   Result := RGB(r,g,b);
end;


procedure FloydSteinberg(bmp: TBitmap);
var
   oldpixel, newpixel: TColor;
   x,y: Integer;
   error : TError;
   y_ok:Boolean;
   cv : TCanvas;
begin
   bmp.PixelFormat := pf24bit;
   cv := bmp.Canvas;
   for y := 0 to bmp.Height-1 do
   begin
      y_ok := (y <> bmp.Height-1);


      x := 0;
      oldpixel := cv.Pixels[x,y];
      newpixel := find_closest_palette_color(oldpixel);
      cv.Pixels[x,y] := newpixel;
      error := CalcError(oldpixel, newpixel);
      cv.Pixels[x+1,y] := ApplyError(cv.Pixels[x+1,y], error, 7);
      if y_ok then
      begin
//      cv.Pixels[x-1,y+1] := ApplyError(cv.Pixels[x-1,y+1], error, 3);
      cv.Pixels[x,y+1] := ApplyError(cv.Pixels[x,y+1], error, 5);
      cv.Pixels[x+1,y+1] := ApplyError(cv.Pixels[x+1,y+1], error, 1);
      end;

      for x := 1 to bmp.Width-2 do
      begin
         oldpixel := cv.Pixels[x,y];
         newpixel := find_closest_palette_color(oldpixel);
         cv.Pixels[x,y] := newpixel;
         error := CalcError(oldpixel, newpixel);
         cv.Pixels[x+1,y] := ApplyError(cv.Pixels[x+1,y], error, 7);
         if y_ok then
         begin
         cv.Pixels[x-1,y+1] := ApplyError(cv.Pixels[x-1,y+1], error, 3);
         cv.Pixels[x,y+1] := ApplyError(cv.Pixels[x,y+1], error, 5);
         cv.Pixels[x+1,y+1] := ApplyError(cv.Pixels[x+1,y+1], error, 1);
         end;
      end;
      if y_ok then
      begin
      x := bmp.Width-1;
      oldpixel := cv.Pixels[x,y];
      newpixel := find_closest_palette_color(oldpixel);
      cv.Pixels[x,y] := newpixel;
      error := CalcError(oldpixel, newpixel);
//      cv.Pixels[x+1,y] := ApplyError(cv.Pixels[x+1,y], error, 7);
      cv.Pixels[x-1,y+1] := ApplyError(cv.Pixels[x-1,y+1], error, 3);
      cv.Pixels[x,y+1] := ApplyError(cv.Pixels[x,y+1], error, 5);
//      cv.Pixels[x+1,y+1] := ApplyError(cv.Pixels[x+1,y+1], error, 1);
      end;
   end;
end;

[Amateurprofi]

@shmia,
vielen herzlichen Dank!
Hab mich aufgerufen gefühlt.
Ist etwas schneller als das Original.
Zeitbedarf für ein Bild mit 4608 x 3456 Pixeln:
Original ca. 180 s
Fälschung ca. 1 s

Delphi-Quellcode:

PROCEDURE FloydSteinberg(Bmp:TBitmap);
resourcestring
   sNo24Bit='Bmp ist keine pf24bit-Bitmap';
   sSize='%S der Bitmap ist = 0';
type
   TBGR=packed record Blue,Green,Red:Byte; end;
   TxBGR=packed record xBlue,xGreen,xRed:Byte; end;
   TPBGR=^TBGR;
   TPxBGR=^TxBGR;
   TDelta=packed record B,G,R:Integer; end;
var
   LO:NativeInt; // Offset zur jeweils nächsten Zeile in Bmp
   Delta:TDelta; // Differenzen alte Farbanteile - neue Farbanteile
   P:TPBGR;      // Zeiger auf aktuelles Pixel
//------------------------------------------------------------------------------
PROCEDURE SetNearestColor;
const
   NC:Array[Boolean] of TBGR=
      ((Blue:255; Green:255; Red:255),(Blue:0; Green:0; Red:0));
var OldPixel:TBGR;
begin
   OldPixel:=P^;
   with OldPixel, TPxBGR(P)^, Delta do begin
       P^:=NC[Blue*21+Green*174+Red*61<32768];
       B:=Blue-xBlue;
       G:=Green-xGreen;
       R:=Red-xRed;
   end;
end;
//------------------------------------------------------------------------------
PROCEDURE SetPixel(XOffset,YOffset,Factor:Integer);
var AP:TPBGR;
begin
   // XOffset=Horizontaler Offset in Pixel
   // YOffset=Vertikaler Offset in Bytes
   AP:=P;
   Inc(AP,XOffset);
   Inc(NativeInt(AP),YOffset);
   with AP^, Delta do begin
      Blue:=EnsureRange(Blue+B*Factor div 16,0,255);
      Green:=EnsureRange(Green+G*Factor div 16,0,255);
      Red:=EnsureRange(Red+R*Factor div 16,0,255);
   end;
end;
//------------------------------------------------------------------------------
var W,H,X,Y:Integer; PP:TPBGR;
begin
   if Bmp.PixelFormat<>pf24Bit then raise Exception.Create(sNo24Bit);
   W:=Bmp.Width-1;  // Letztes Pixel einer Zeile
   H:=Bmp.Height-1; // Letzte Zeile
   if W<0 then raise Exception.CreateFmt(sSize,['Breite']);
   if H<0 then raise Exception.CreateFmt(sSize,['Höhe']);
   PP:=Bmp.ScanLine[0];
   if H>0 then LO:=NativeInt(Bmp.ScanLine[1])-NativeInt(PP) else LO:=0;
   for Y:=H downto 0 do begin
      P:=PP;
      for X:=W downto 0 do begin
         SetNearestColor;
         if X<>0 then SetPixel(1,0,7);
         if Y<>0 then  begin
            if X<>W then SetPixel(-1,LO,3);
            SetPixel(0,LO,5);
            if X<>0 then SetPixel(1,LO,1);
         end;
         Inc(P);
      end;
      Inc(NativeInt(PP),LO)
   end;
end;

[haentschman]

Moin...8-)

Delphi-Quellcode:

with OldPixel, TPxBGR(P)^, Delta do begin
...

Sei bitte nicht böse...aber das mit dem WITH und noch mit mehreren Werten rollen sich mir die Fußnägel hoch. :roll:
Auch wenn es funktioniert...es wird heutzutage davor gewarnt. :warn: Den Neulingen, die auch mitlesen, sollte man das nicht mehr beibringen. :wink:

[Kas Ob.]

Excellent work.

I have few suggestion:
1) Switch from using Integer to NativeUInt or NativeInt, this will pay in x64, as the compiler will not have to insert resizing instructions like movzx and will have the ability to use full register operation.
2) Replace that EnsureRange with simple old fashion if-statement, saving a needless branch.
3) I wouldn't trust the compiler to generate fast div every time when the division is by 2^n, proof this by replacing them with shr n, so div 16 can be shr 4.
4) This is the meat of this and i think it should pay on low cache CPU's or big images or very busy CPU, instead of getting the last line which have the index 0 then go backward "PP:=Bmp.ScanLine[0];" replace with getting the first line and move forward, also for X there is no point of walking backward, see, with huge images, and walking backward the cache lines will continuously be read in backward causing violation and request to update, while the CPU request its cache lines in bulk forward most the time, so accessing the memory backward with thrash the cache and waste time and cycles waiting for memory.

[Kas Ob.]

Zitat:

Zitat von haentschman (Beitrag 1528355)

Sei bitte nicht böse...aber das mit dem WITH und noch mit mehreren Werten rollen sich mir die Fußnägel hoch.

I am more angry than you about the loss of readability and the risk with it :wall:, BUT the CPU is more retarded than a 15th century brick, and without pushing its face into the point with "with" it will not generate a decent code (in many cases anyway).

So yes, i am more angry about the compiler than the "with" or who use it.

[Uwe Raabe]

OT: Wie kommt man eigentlich auf die Idee, einen 15 Jahre alten Thread wieder aufleben zu lassen? Insbesondere, da die letzte Aktivität des Posters mittlerweile auch schon fast 11 Jahre zurück liegt.

[Kas Ob.]

Zitat:

Zitat von Uwe Raabe (Beitrag 1528372)

OT: Wie kommt man eigentlich auf die Idee, einen 15 Jahre alten Thread wieder aufleben zu lassen? Insbesondere, da die letzte Aktivität des Posters mittlerweile auch schon fast 11 Jahre zurück liegt.

:shock: :?

[Sinspin]

Zitat:

Zitat von Uwe Raabe (Beitrag 1528372)

OT: Wie kommt man eigentlich auf die Idee, einen 15 Jahre alten Thread wieder aufleben zu lassen? Insbesondere, da die letzte Aktivität des Posters mittlerweile auch schon fast 11 Jahre zurück liegt.

Warum nicht, es geht ums gleiche Thema.
Ist generell eine Überlegung wert da weiter zu machen wo jemand schonmal was gemacht hat. Fängt man halt nicht bei null an.
Interessant dazu ist auch der Einleitungstext:

Zitat:

Zitat von Amateurprofi (Beitrag 1528354)

@shmia,
vielen herzlichen Dank!
Hab mich aufgerufen gefühlt.
Ist etwas schneller als das Original.
Zeitbedarf für ein Bild mit 4608 x 3456 Pixeln:
Original ca. 180 s
Fälschung ca. 1 s

Es ist einfach nicht aufgefallen dass die Einladung alterstechnisch schon in der Oberstufe ist.
Ist noch keinem von uns passiert?

Zitat:

Zitat von Kas Ob. (Beitrag 1528371)

I am more angry than you about the loss of readability and the risk with it :wall:, BUT the CPU is more retarded than a 15th century brick, and without pushing its face into the point with "with" it will not generate a decent code (in many cases anyway).

So yes, i am more angry about the compiler than the "with" or who use it.

Delphi-Quellcode:

With

have no effect for the compiler. Its just a help for lazy programmer to save some time (they think at least that they save time). Later on, when they have to review or extend the code, they have an high chance to get confused and make errors. Which will then, for sure, cost more time than they have saved in first instance.

[himitsu]

Delphi-Quellcode:

var R: TRect;

with R do
  Width := Right - Left + 1;

Also ich fand es witzig, als so ein Code urplötzlich nichts mehr machte, also nicht mehr die Breite der Form zu setzen,
weil TRect plötzlich ein Property Width bekommen hatte und Dieses dann eben nicht mehr das Width der Form war. :lol:

PS: Inline-Variablen, wenn es unbedingt sein muß.

[Amateurprofi]

Zitat:

Zitat von haentschman (Beitrag 1528355)

Moin...8-)

Delphi-Quellcode:

with OldPixel, TPxBGR(P)^, Delta do begin
...

Sei bitte nicht böse...aber das mit dem WITH und noch mit mehreren Werten rollen sich mir die Fußnägel hoch. :roll:
Auch wenn es funktioniert...es wird heutzutage davor gewarnt. :warn: Den Neulingen, die auch mitlesen, sollte man das nicht mehr beibringen. :wink:

Nee, warum sollte ich böse sein.
Ich verstehe, dass es im Profi-Bereich notwendig, oder zumindest sinnvoll ist, sich an ein bestimmtes Regelwerk zu halten.
Wie jedoch mein Username vermuten lässt bin ich, IT-bezogen, eher Amateur.
Und ich liebe "with", weil es kompakteren Source-Code ermöglicht.
Aus der Delphi Hilfe "When you use the with statement, your code becomes shorter and easier to read".
Letzteres würde ich allerdings nicht unterschreiben.
Zu

Zitat:

rollen sich mir die Fußnägel hoch

Mal zur Fußpflege gehen? (Nicht böse gemeint.)