Soften/(Gaussian-)Blur/AntiAliasing (TBitmap)

Phantom1 · Beiträge: 390

Hi,

Ich habe eine Procedure geschrieben die ähnlich wie GaussianBlur arbeit, man kann sie aber auch fürs Soften/Blurren/AntiAliasing benutzten. Man kann einen Pixelradius angeben (von 0.0000001 bis 50 pixel). Je größer der Wert desto mehr wird geblurrt. (achtung große werte können sehr viel rechenzeit beanspruchen!)

Die Matrix und der divisor werden dabei ebenfalls automatisch berechnet, hier mal zwei beispiele zum besseren verständniss:

bei einem radius von 2,0

0,17|0,76|1,00|0,76|0,17
0,76|1,60|2,00|1,60|0,76
1,00|2,00|3,00|2,00|1,00
0,76|1,60|2,00|1,60|0,76
0,17|0,76|1,00|0,76|0,17

und radius 3,6

0,00|0,00|0,13|0,48|0,60|0,48|0,13|0,00|0,00
0,00|0,36|0,99|1,40|1,60|1,40|0,99|0,36|0,00
0,13|0,99|1,80|2,40|2,60|2,40|1,80|0,99|0,13
0,48|1,40|2,40|3,20|3,60|3,20|2,40|1,40|0,48
0,60|1,60|2,60|3,60|4,60|3,60|2,60|1,60|0,60
0,48|1,40|2,40|3,20|3,60|3,20|2,40|1,40|0,48
0,13|0,99|1,80|2,40|2,60|2,40|1,80|0,99|0,13
0,00|0,36|0,99|1,40|1,60|1,40|0,99|0,36|0,00
0,00|0,00|0,13|0,48|0,60|0,48|0,13|0,00|0,00

Desweiteren habe ich die procedure ebenfalls sogut ich konnte optimiert (ich kann allerdings kein assembler).

So und hier der sourcecode:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:

procedure BmpGBlur(Bmp: TBitmap; radius: Single);
Type
  TRGB      = Packed Record b, g, r: Byte End;
  ArrTRGB   = Array of TRGB;
  ArrSingle = Array of Single;
Var
  MatrixDim, MatrixRadius: Byte;
  Matrix   : Array of ArrSingle;
  MatrixY  : ^ArrSingle;
  Faktor   : ^Single;
  BmpCopy  : Array of ArrTRGB;
  BmpCopyY : ^ArrTRGB;
  BmpRGB, BmpCopyRGB: ^TRGB;
  BmpWidth, BmpHeight, x, y, dx, dy: Integer;
  StartDx, CountDx, StartDy, CountDy: Integer;
  R, G, B, Divisor: Single;

  Procedure CalculateMatrix;
  Var x,y: Integer; MxRadius, f: Single;
  Begin
    radius:=radius+1; // der mittel/nullpunkt muss mitgerechnet werden
    If Frac(radius)=0 Then MatrixDim:=Pred(Trunc(radius)*2) Else MatrixDim:=Succ(Trunc(radius)*2);
    SetLength(Matrix,MatrixDim,MatrixDim);
    MxRadius:=MatrixDim div 2;
    For y:=0 To Pred(MatrixDim) Do
      For x:=0 To Pred(MatrixDim) Do begin
        f:=radius-Sqrt(Sqr(x-MxRadius)+Sqr(y-MxRadius));
        If f<0 Then f:=0; // punkte die außerhalb des radius liegen löschen
        Matrix[y,x]:=f;
      end;
  End;

Begin
  Bmp.PixelFormat:=pf24bit;
  If radius<=0 Then radius:=1 Else If radius>=50 Then radius:=50; // radius bereich 0.0 < radius < 50.0
  CalculateMatrix;
  BmpWidth:=Bmp.Width;
  BmpHeight:=Bmp.Height;
  SetLength(BmpCopy,BmpHeight,BmpWidth);
  // Kopie des Bitmaps erstellen im zweidimensionalen Array (BmpCopy)
  For y:=0 To Pred(BmpHeight) Do
    Move(Bmp.ScanLine[y]^,BmpCopy[y,0],BmpWidth*3);
  MatrixRadius:=Pred(MatrixDim) Div 2;
  For y:=0 To Pred(BmpHeight) Do Begin
    BmpRGB:=Bmp.ScanLine[y];
    For x:=0 to Pred(BmpWidth) Do Begin
      R:=0; G:=0; B:=0; Divisor:=0;
      // Matrixpixel außerhalb des Bitmaps weglassen
      If y<MatrixRadius Then StartDy:=y Else StartDy:=MatrixRadius;
      If y>Pred(BmpHeight)-MatrixRadius Then CountDy:=Pred(BmpHeight)-y+StartDy
      Else CountDy:=MatrixRadius+StartDy;
      If x<MatrixRadius Then StartDx:=x Else StartDx:=MatrixRadius;
      If x>Pred(BmpWidth)-MatrixRadius Then CountDx:=Pred(BmpWidth)-x+StartDx
      Else CountDx:=MatrixRadius+StartDx;
      // Bildpunkte mit der Matrix multiplizieren
      MatrixY:=@Matrix[MatrixRadius-StartDy];
      BmpCopyY:=@BmpCopy[y-StartDy];
      For dy:=0 To CountDy Do Begin
        Faktor:=@MatrixY^[MatrixRadius-StartDx];
        BmpCopyRGB:=@BmpCopyY^[x-StartDx];
        For dx:=0 To CountDx Do Begin
          B:=B+BmpCopyRGB^.b*Faktor^; // blau
          G:=G+BmpCopyRGB^.g*Faktor^; // grün
          R:=R+BmpCopyRGB^.r*Faktor^; // rot
          Divisor:=Divisor+Faktor^;
          Inc(BmpCopyRGB);
          Inc(Faktor);
        End;
        Inc(MatrixY);
        Inc(BmpCopyY);
      End;
      // neuen berechneten Bildpunkt schreiben
      BmpRGB.b:=Round(B/Divisor);
      BmpRGB.g:=Round(G/Divisor);
      BmpRGB.r:=Round(R/Divisor);
      Inc(BmpRGB);
    End;
  End;
End;

Gast Erhaltene Danke: 1

Hier habe ich noch eine procedure die das Selbe macht (habe ich irgendwann mal gefunden ;)) allerdings ist sie ein wenig schneller und blurt bei halbem Radius mit gleicher Stärke.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:

unit gblur;

interface

uses Graphics, SysUtils;

const MaxKernelSize = 100;

type
  PRGBTriple = ^TRGBTriple;
  TRGBTriple = packed record
   b: byte; //easier to type than rgbtBlue...
   g: byte;
   r: byte;
  end;
  PRow = ^TRow;
  TRow = array[0..1000000] of TRGBTriple;
  PPRows = ^TPRows;
  TPRows = array[0..1000000] of PRow;
  TKernelSize = 1..MaxKernelSize;
  TKernel = record
   Size: TKernelSize;
   Weights: array[-MaxKernelSize..MaxKernelSize] of single;
  end;

procedure GaussianBlur(theBitmap: TBitmap; radius: double);

implementation

procedure MakeGaussianKernel(var K: TKernel; radius: double;
                            MaxData, DataGranularity: double);
var j: integer; temp, delta: double; KernelSize: TKernelSize;
begin
 for j:= Low(K.Weights) to High(K.Weights) do
 begin
  temp:= j/radius;
  K.Weights[j]:= exp(- temp*temp/2);
 end;
 temp:= 0;
 for j:= Low(K.Weights) to High(K.Weights) do
  temp:= temp + K.Weights[j];
 for j:= Low(K.Weights) to High(K.Weights) do
  K.Weights[j]:= K.Weights[j] / temp;
 KernelSize:= MaxKernelSize;
 delta:= DataGranularity / (2*MaxData);
 temp:= 0;
 while (temp < delta) and (KernelSize > 1) do
 begin
  temp:= temp + 2 * K.Weights[KernelSize];
  dec(KernelSize);
 end;
 K.Size:= KernelSize;
 temp:= 0;
 for j:= -K.Size to K.Size do
  temp:= temp + K.Weights[j];
 for j:= -K.Size to K.Size do
  K.Weights[j]:= K.Weights[j] / temp;
end;

function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
 if (theInteger <= Upper) and (theInteger >= Lower) then
  result:= theInteger
 else
  if theInteger > Upper then result := Upper
   else result := Lower;
end;

function TrimReal(Lower, Upper: integer; x: double): integer;
begin
 if (x < upper) and (x >= lower) then
  result:= trunc(x)
 else
  if x > Upper then
   result:= Upper
  else
   result:= Lower;
end;

procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
 j, n, LocalRow: integer;
 tr, tg, tb: double;
  w: double;
begin
 for j:= 0 to High(theRow) do
 begin
  tb:= 0;
  tg:= 0;
  tr:= 0;
  for n:= -K.Size to K.Size do
  begin
   w:= K.Weights[n];
   with theRow[TrimInt(0, High(theRow), j - n)] do
   begin
    tb:= tb + w * b;
    tg:= tg + w * g;
    tr:= tr + w * r;
   end;
  end;
  with P[j] do
  begin
   b:= TrimReal(0, 255, tb);
   g:= TrimReal(0, 255, tg);
   r:= TrimReal(0, 255, tr);
  end;
 end;
 Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;

procedure GaussianBlur(theBitmap: TBitmap; radius: double);
var
 Row, Col: integer;
 theRows: PPRows;
 K: TKernel;
 ACol, P: PRow;
begin
 if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
 raise exception.Create('GBlur only works for 24-bit bitmaps');
 MakeGaussianKernel(K, radius, 255, 1);
 GetMem(theRows, theBitmap.Height * SizeOf(PRow));
 GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
 for Row:= 0 to theBitmap.Height - 1 do
  theRows[Row]:= theBitmap.Scanline[Row];
 P:= AllocMem(theBitmap.Width*SizeOf(TRGBTriple));
 for Row:= 0 to theBitmap.Height - 1 do
  BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
 ReAllocMem(P, theBitmap.Height*SizeOf(TRGBTriple));
 for Col:= 0 to theBitmap.Width - 1 do
 begin
  for Row:= 0 to theBitmap.Height - 1 do
   ACol[Row]:= theRows[Row][Col];
  BlurRow(Slice(ACol^, theBitmap.Height), K, P);
  for Row:= 0 to theBitmap.Height - 1 do
   theRows[Row][Col]:= ACol[Row];
 end;
 FreeMem(theRows);
 FreeMem(ACol);
 ReAllocMem(P, 0);
end;

end.

Phantom1 · Beiträge: 390

hi obbschtkuche,

habs eben mal getestet, bei einen radius von 3 bei meiner procedure und radius von 1.5 bei dem von dir geposteten procedure ist blurfaktor und die geschwindigkeit fast gleich! bei niedrigeren radien ist dagegen meine wesentlich schneller und bei höheren die andere procedure. Ich glaube das liegt daran das ich eine dynamische matrix verwende und die andere eine feste hat.

Gast Erhaltene Danke: 1

sorry, ich habs nur mit 10 getestet. Also am besten beide verwenden, nur eben die eine für Große radien und die andere für kleine ;)

Phantom1 · Beiträge: 390

desweiteren produziert die von dir gepostete procedure bei radien unter 0.5 ziemlich viele pixelfehler :-/

naja mal sehen ich werde meine procedure auch noch weiter verbessern und vieleicht kann ich ein paar ideen von deiner procedure mit einbauen :wink:

Phantom1 · Beiträge: 390

So habe meine procedure nochmal komplett überarbeitet. Die procedure ist jetzt etwa doppelt so schnell wie die beiden bisher geposteten proceduren zusammen !!!! Pixelfehler gibts bei mir auch nicht.

Hier der Code:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:

procedure TForm1.BmpGBlur(Bmp: TBitmap; radius: Single);
Type
  TRGB      = Packed Record b, g, r: Byte End;
  TRGBs     = Packed Record b, g, r: Single End;
  TRGBArray = Array[0..0] of TRGB;
Var
  MatrixRadius: Byte;
  Matrix : Array[-100..100] of Single;

  Procedure CalculateMatrix;
  Var x: Integer; Divisor: Single;
  Begin
    radius:=radius+1; // der mittel/nullpunkt muss mitgerechnet werden
    MatrixRadius:=Trunc(radius);
    If Frac(radius)=0 Then Dec(MatrixRadius);
    Divisor:=0;
    For x:=-MatrixRadius To MatrixRadius Do Begin
      Matrix[x]:=radius-abs(x);
      Divisor:=Divisor+Matrix[x];
    End;
    For x:=-MatrixRadius To MatrixRadius Do
      Matrix[x]:=Matrix[x]/Divisor;
  End;

Var
  BmpSL              : ^TRGBArray;
  BmpRGB             : ^TRGB;
  BmpCopy            : Array of Array of TRGBs;
  BmpCopyRGB         : ^TRGBs;
  R, G, B            : Single;
  BmpWidth, BmpHeight: Integer;
  x, y, mx           : Integer;
Begin
  Bmp.PixelFormat:=pf24bit;
  If radius<=0 Then radius:=1 Else If radius>99 Then radius:=99; // radius bereich 0 < radius < 99
  CalculateMatrix;
  BmpWidth:=Bmp.Width;
  BmpHeight:=Bmp.Height;
  SetLength(BmpCopy,BmpHeight,BmpWidth);
  // Alle Bildpunkte ins BmpCopy-Array schreiben und gleichzeitig HORIZONTAL blurren
  For y:=0 To Pred(BmpHeight) Do Begin
    BmpSL:=Bmp.Scanline[y];
    BmpCopyRGB:=@BmpCopy[y,0];
    For x:=0 to Pred(BmpWidth) Do Begin
      R:=0; G:=0; B:=0;
      For Mx:=-MatrixRadius To MatrixRadius Do Begin
        If x+mx<0 Then
          BmpRGB:=@BmpSL^[0]              // erster Pixel
        Else If x+mx>=BmpWidth Then
          BmpRGB:=@BmpSL^[Pred(BmpWidth)] // letzter Pixel
        Else
          BmpRGB:=@BmpSL^[x+mx];
        B:=B+BmpRGB^.b*Matrix[mx];
        G:=G+BmpRGB^.g*Matrix[mx];
        R:=R+BmpRGB^.r*Matrix[mx];
      End;
      BmpCopyRGB^.b:=B;  // Farbwerte werden im Typ Single zwischengespeichert !
      BmpCopyRGB^.g:=G;
      BmpCopyRGB^.r:=R;
      Inc(BmpCopyRGB);
    End;
  End;
  // Alle Bildpunkte zurück ins Bmp-Bitmap schreiben und gleichzeitig VERTIKAL blurren
  For y:=0 To Pred(BmpHeight) Do Begin
    BmpRGB:=Bmp.ScanLine[y];
    For x:=0 to Pred(BmpWidth) Do Begin
      R:=0; G:=0; B:=0;
      For mx:=-MatrixRadius To MatrixRadius Do Begin
        If y+mx<=0 Then
          BmpCopyRGB:=@BmpCopy[0,x]                // erster Pixel
        Else If y+mx>=BmpHeight Then
          BmpCopyRGB:=@BmpCopy[Pred(BmpHeight),x]  // letzter Pixel
        Else
          BmpCopyRGB:=@BmpCopy[y+mx,x];
        B:=B+BmpCopyRGB^.b*Matrix[mx];
        G:=G+BmpCopyRGB^.g*Matrix[mx];
        R:=R+BmpCopyRGB^.r*Matrix[mx];
      End;
      BmpRGB^.b:=Round(B);
      BmpRGB^.g:=Round(G);
      BmpRGB^.r:=Round(R);
      Inc(BmpRGB);
    End;
  End;
End;

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme