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.

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;