Bild weichzeichnen

[Khabarakh]

Hier noch eine Routine, die sehr schnell sein sollte.

Delphi-Quellcode:

****************************************************************
* Fastblur routine (c)2005 Roy Magne Klever
* If you improve it send me a copy at [email][e-mail][/email]
****************************************************************
procedure rkFastBlur(src, dest: TBitmap; radius, rep: integer);
type
  PRGB24 = ^TRGB24;
  TRGB24 = packed record
    B: Byte;
    G: Byte;
    R: Byte;
  end;
  TLine24 = array[0..MaxInt div SizeOf(TRGB24) - 1] of TRGB24;
  PLine24 = ^TLine24;
var
  j, divF, i, w, h, x, y, ny, tx, ty, prg: integer;
  p: pRGB24;
  ptrS, ptrD, pv: integer;
  s0, s1: PLine24;
  saR, saG, saB: array of Integer;
begin
  dest.Assign(src);
  if radius = 0 then
    Exit;

  divF := (radius * 2) + 1;
  w := dest.Width - 1;
  h := dest.Height - 1;
  SetLength(saR, w + 1 + (radius * 2));
  SetLength(saG, w + 1 + (radius * 2));
  SetLength(saB, w + 1 + (radius * 2));

  s1 := dest.ScanLine[0];
  ptrD := integer(dest.ScanLine[1]) - integer(s1);

  ny := Integer(s1);
  for y := 0 to h do
  begin
    for j := 1 to rep do
    begin
      i := -radius;
      while i <= w + radius do
      begin
        tx := i;
        if tx < 0 then
          tx := 0
        else if tx >= w then
          tx := w;
        with pRGB24(ny + tx * 3)^ do
        begin
          saR[i + radius] := r + saR[i + radius - 1];
          saG[i + radius] := g + saG[i + radius - 1];
          saB[i + radius] := b + saB[i + radius - 1];
        end;
        inc(i);
      end;
      for x := 0 to w do
      begin
        tx := x + radius;
        with pRGB24(ny + x * 3)^ do
        begin
          r := ((saR[tx + radius] - saR[tx - 1 - radius]) div divF);
          g := ((saG[tx + radius] - saG[tx - 1 - radius]) div divF);
          b := ((saB[tx + radius] - saB[tx - 1 - radius]) div divF);
        end;
      end;
    end;
    inc(ny, PtrD);
  end;

  SetLength(saR, h + 1 + (radius * 2));
  SetLength(saG, h + 1 + (radius * 2));
  SetLength(saB, h + 1 + (radius * 2));
  for x := 0 to w do
  begin
    for j := 1 to rep do
    begin
      ny := Integer(s1);
      i := -radius;
      while i <= h + radius do
      begin
        if (i > 0) and (i < h) then
          inc(ny, PtrD);
        with pRGB24(ny + x * 3)^ do
        begin
          saR[i + radius] := r + saR[i + radius - 1];
          saG[i + radius] := g + saG[i + radius - 1];
          saB[i + radius] := b + saB[i + radius - 1];
        end;
        inc(i);
      end;
      ny := Integer(s1);
      for y := 0 to h do
      begin
        ty := y + radius;
        with pRGB24(ny + x * 3)^ do
        begin
          r := ((saR[ty + radius] - saR[ty - 1 - radius]) div divF);
          g := ((saG[ty + radius] - saG[ty - 1 - radius]) div divF);
          b := ((saB[ty + radius] - saB[ty - 1 - radius]) div divF);
        end;
        inc(ny, PtrD);
      end;
    end;
  end;
  SetLength(saR, 0);
  SetLength(saG, 0);
  SetLength(saB, 0);
end;

Etwas optimiert, allerdings für die GR32-Lib:

Delphi-Quellcode:

procedure FastBlur(Dst: TBitmap32; Radius: Integer; Passes: Integer = 3);
//****************************************************************
//*  Fastblur routine (c)2005 Roy Magne Klever
//*  GR32 Conversion and further optimizations by Michael Hansen
//*  If you improve it please send a copies to:
//*  [email][e-mail][/email]
//*  [email][e-mail][/email]
//****************************************************************
type
   PARGB32 = ^TARGB32;
   TARGB32 = packed record
     B: Byte;
     G: Byte;
     R: Byte;
     A: Byte;
   end;
   TLine32 = array[0..MaxInt div SizeOf(TARGB32) - 1] of TARGB32;
   PLine32 = ^TLine32;

   PSumRecord = ^TSumRecord;
   TSumRecord = packed record
     saB, saG, saR, saA: Cardinal;
   end;

var
   J, X, Y, w, h,  ny, tx, ty: integer;
   ptrD: integer;
   s1: PLine32;
   C: TColor32;
   sa: array of TSumRecord;
   sr1, sr2: TSumRecord;
   n : Cardinal;
begin
   if Radius = 0 then Exit;

   n := Fixed(1 / ((radius * 2) + 1));
   w := Dst.Width - 1;
   h := Dst.Height - 1;

   SetLength(sa, w + 1 + (radius * 2));

   s1 := PLine32(Dst.PixelPtr[0,0]);
   ptrD := Integer(Dst.PixelPtr[0,1]) - Integer(s1);

   ny := Integer(s1);
   for Y := 0 to h do
   begin
     for J := 1 to Passes do
     begin
       X := - Radius;
       while X <= w + Radius do
       begin
         tx := X;
         if tx < 0 then tx := 0 else if tx >= w then tx := w;
         sr1 := sa[X + Radius - 1];
         C := PColor32(ny + tx shl 2)^;
         with sa[X + Radius] do
         begin
           saA := sr1.saA + C shr 24;
           saR := sr1.saR + C shr 16 and $FF;
           saG := sr1.saG + C shr 8 and $FF;
           saB := sr1.saB + C and $FF;
         end;
         inc(X);
       end;
       for X := 0 to w do
       begin
         tx  := X + Radius;
         sr1 := sa[tx + Radius];
         sr2 := sa[tx - 1 - Radius];
         PColor32(ny + X shl 2)^ := (sr1.saA - sr2.saA) * n shl 8 and 
$FF000000 or
                                    (sr1.saR - sr2.saR) * n and $FF0000 or
                                    (sr1.saG - sr2.saG) * n shr 8 and $FF00 
or
                                    (sr1.saB - sr2.saB) * n shr 16;
       end;
     end;
     inc(ny, PtrD);
   end;

   SetLength(sa, h + 1 + (Radius * 2));
   for X := 0 to w do
   begin
     for J := 1 to Passes do
     begin
       ny := Integer(s1);
       Y := - Radius;
       while Y <= h + Radius do
       begin
         if (Y > 0) and (Y < h) then inc(ny, PtrD);
         sr1 := sa[Y + Radius - 1];
         C := PColor32(ny + X shl 2)^;
         with sa[Y + Radius] do
         begin
           saA := sr1.saA + C shr 24;
           saR := sr1.saR + C shr 16 and $FF;
           saG := sr1.saG + C shr 8 and $FF;
           saB := sr1.saB + C and $FF;
         end;
         inc(Y);
       end;
       ny := Integer(s1);
       for Y := 0 to h do
       begin
         ty := Y + Radius;
         sr1 := sa[ty + Radius];
         sr2 := sa[ty - 1 - Radius];
         PColor32(ny + X shl 2)^ := (sr1.saA - sr2.saA) * n shl 8 and 
$FF000000 or
                                    (sr1.saR - sr2.saR) * n and $FF0000 or
                                    (sr1.saG - sr2.saG) * n shr 8 and $FF00 
or
                                    (sr1.saB - sr2.saB) * n shr 16;
         inc(ny, PtrD);
       end;
     end;
   end;
   SetLength(sa, 0);
end;

Ein weiterer Algorithmus von dizzy lässt sich in der CodeLib finden.