Code beschleunigen (von einem Grafikfilter)

Phantom1 · Beiträge: 390

Also ich hab ne Procedure geschrieben, mit der man TBitmaps Weichzeichnen kann (ähnlich wie der Gaußscher weichzeichner). Das problem ist nur das ein Bild von 1024x768 etwa 15 sekunden braucht (bei einem pixelradius von 10pixeln).

Und dabei habe ich schon integerzahlen und scanline benutzt, auch die faktoren (von den umliegenden pixeln) werden im voraus berechnet.

Hat jemand eine Idee wie man die procedure noch beschleunigen kann?

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:

procedure TForm1.GBlur(Bmp: TBitmap; radius: Integer);
Type
  TRGBArray = Array[0..0] of Packed Record b, g, r: byte End;
Var
  BmpCopy: TBitmap;
  BmpCopySL: Array of ^TRGBArray;
  BmpSL: ^TRGBArray;
  x,y, dx,dy, ix,iy, R,G,B, RR,GG,BB, divisor: Integer;
  Faktoren: Array of Array of Integer;

  Procedure BerechneFaktoren;
  Var x, y: Integer;
  Begin
    SetLength(Faktoren,radius+1);
    For x:=0 To radius Do Begin
      SetLength(Faktoren[x],radius+1);
      For y:=0 To radius Do
        Faktoren[x,y]:=radius-Round(Sqrt(Sqr(y) + Sqr(x)));
    End;
  End;

Begin
  BmpCopy:=TBitmap.Create;
  Try
    BmpCopy.Assign(Bmp);
    BerechneFaktoren;
    SetLength(BmpCopySL,Bmp.Height);
    For y:=0 to Bmp.Height-1 Do
      BmpCopySL[y]:=BmpCopy.ScanLine[y];
    For y:=0 to Bmp.Height-1 Do Begin
      BmpSL:=Bmp.ScanLine[y];
      For x:=0 to Bmp.Width-1 Do begin
        RR:=0; GG:=0; BB:=0; divisor:=0;
        For dy:=-radius To radius Do
          For dx:=-radius To radius Do Begin
            iy:=y+dy;
            ix:=x+dx;
            If (iy>=0) And (iy<=Bmp.Height-1) And
               (ix>=0) And (ix<=Bmp.Width-1) And
               (Faktoren[abs(dy),abs(dx)]>0) Then Begin
                R:=BmpCopySL[iy,ix].r;
                G:=BmpCopySL[iy,ix].g;
                B:=BmpCopySL[iy,ix].b;
                RR:=RR+R*Faktoren[abs(dy),abs(dx)];
                GG:=GG+G*Faktoren[abs(dy),abs(dx)];
                BB:=BB+B*Faktoren[abs(dy),abs(dx)];
                divisor:=divisor+Faktoren[abs(dy),abs(dx)];
            End;
          End;
        If divisor=0 Then divisor:=1;
        RR:=RR Div divisor;
        GG:=GG Div divisor;
        BB:=BB Div divisor;
        If RR>255 Then RR:=255 Else If RR<0 Then RR:=0;
        If GG>255 Then GG:=255 Else If GG<0 Then GG:=0;
        If BB>255 Then BB:=255 Else If BB<0 Then BB:=0;
        BmpSL[x].r:=RR;
        BmpSL[x].g:=GG;
        BmpSL[x].b:=BB;
      End;
    End;  
  Finally
    BmpCopy.Free;
  End;
End;

Vielen dank im vorraus!

AndyB · Beiträge: 1173 Erhaltene Danke: 14 RAD Studio XE2

Der Code sieht schon recht optimiert aus. Aber die If Abfrage in der Schleife solltest du noch etwas beschleunigen, oder verscheiben.

Hier noch ein paar Beschleunigungen:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:

  Procedure BerechneFaktoren;
  Var
    x, y, xx: Integer;
    yy: array of Integer;
  Begin
   // y*y Array aufbauen
    SetLength(yy, radius + 1);
    for y := 0 to radius Do yy[y] := Sqr(y);
   // Das Array auf einmal initialisieren
    SetLength(Faktoren, radius+1, radius+1);
    For x:=0 To radius Do Begin
      xx := Sqr(x); // nur einmal berechnen
      For y:=0 To radius Do
        Faktoren[x,y]:=radius-Round(Sqrt(yy[y] + xx));
    End;
  End;

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:

var
  BmpHeight, BmpWudth: Integer;
  Faktor: Integer;
Begin
 // Damit spart man die GetWidth/GetHeight Aufrufe
  BmpWidth := Bmp.Width;
  BmpHeight := Bmp.Height;

  BmpCopy:=TBitmap.Create;
  Try
    BmpCopy.Assign(Bmp);
    BerechneFaktoren;
    SetLength(BmpCopySL,BmpHeight);
    For y:=0 to Bmp.Height-1 Do 
      BmpCopySL[y]:=BmpCopy.ScanLine[y]; 
    For y:=0 to BmpHeight-1 Do Begin
      BmpSL:=Bmp.ScanLine[y];
      For x:=0 to BmpWidth-1 Do begin
        RR:=0; GG:=0; BB:=0; divisor:=0;
        For dy:=-radius To radius Do
          For dx:=-radius To radius Do Begin
            iy:=y+dy;
            ix:=x+dx;
            { Faktor zwischenspeichern um die Berechnungen für den Index nur einmal durchzufürhen. }
            Faktor := Faktoren[Abs(dy),Abs(dx)];
           { durch das Umwandeln von iy und ix in Cardinal werden negative Werte als sehr große Werte interpretiert. Das spart 2 Vergleiche. }
            If (Faktor>0) And
               ((Cardinal(iy)<=Cardinal(BmpHeight-1)) And
               (Cardinal(ix)<=Cardinal(BmpWidth-1)) Then Begin
                R:=BmpCopySL[iy,ix].r;
                G:=BmpCopySL[iy,ix].g;
                B:=BmpCopySL[iy,ix].b;
                RR:=RR+R*Faktor;
                GG:=GG+G*Faktor;
                BB:=BB+B*Faktor;
                divisor:=divisor+Faktor;
            End;
          End;
        If divisor=0 Then divisor:=1;
        RR:=RR Div divisor;
        GG:=GG Div divisor;
        BB:=BB Div divisor;
        If RR>255 Then RR:=255 Else If RR<0 Then RR:=0;
        If GG>255 Then GG:=255 Else If GG<0 Then GG:=0;
        If BB>255 Then BB:=255 Else If BB<0 Then BB:=0;
        BmpSL[x].r:=RR;
        BmpSL[x].g:=GG;
        BmpSL[x].b:=BB;
      End;
    End;  
  Finally
    BmpCopy.Free;
  End;
End;

Ein klein wenig schneller dürfte es jetzt sein.

_________________
Ist Zeit wirklich Geld?

AndyB · Beiträge: 1173 Erhaltene Danke: 14 RAD Studio XE2

Zitat:

markieren

Delphi-Quelltext

1:
2:

        For dy:=-radius To radius Do 
          For dx:=-radius To radius Do Begin

Wenn man diese beiden Schleifenbedingungen, so anpasst, dass

markieren

Delphi-Quelltext

1:
2:

If (iy>=0) And (iy<=Bmp.Height-1) And 
   (ix>=0) And (ix<=Bmp.Width-1) And

immer eintritt, also True liefert, spart man 4 Verleiche, die immer ausgeführt werden müssen.

_________________
Ist Zeit wirklich Geld?

AndyB · Beiträge: 1173 Erhaltene Danke: 14 RAD Studio XE2

Das würde dann ungefähr so aussehen. Hierbei hat man vier Vergleiche, die für jeden Bildpunkt nur einmal durchlaufen werden. In deinem ursprünglichen Code wurden die vier Vergleiche sehr viel öfter durchlaufen

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:

StartDy := -radius;
if y + StartDy < 0 then StartDy := 0 - y;
EndDy := radius;
if y + EndDy >= BmpHeight then EndDy := (BmpHeight - 1) - y;

StartDx := -radius;
if x + StartDx < 0 then StartDx := 0 -xy;
EndDx := radius;
if x + EndDx >= BmpWidth then EndDx := (BmpWidth - 1) - x;

For dy:=StartDy To EndDy Do  
   For dx:=StartDx To EndDx Do Begin
      iy:=y+dy; 
      ix:=x+dx; 
      Faktor := Faktoren[Abs(dy),Abs(dx)];
      if Faktor > 0 then begin
       { Das kann der Compiler besser optimieren. }
        RR:=RR + BmpCopySL[iy,ix].r * Faktor; 
        GG:=GG + BmpCopySL[iy,ix].g * Faktor; 
        BB:=BB + BmpCopySL[iy,ix].b * Faktor; 
        divisor:=divisor+Faktor; 
      End; 
   End; 
...

Statistik:
Neue Version: Vergleiche: 4 *(BmpWidth*BmpHeight)
Alte Version: Vergleiche: 4 *((radius*2)*(radius*2))*(BmpWidth*BmpHeight)
Den Geschwindigkeitsvorteil, darfst du dir selbst ausrechnen.

_________________
Ist Zeit wirklich Geld?

Phantom1 · Beiträge: 390

@AndyB:

vielen dank erstmal! deine optimierungen sind wirklich gut, der code läuft jetzt fast 50% schneller

, also nur noch 8 anstatt 15 sek.

Phantom1 · Beiträge: 390

Hab grad noch 2 kleine optimierungen vorgenommen, in der faktorenberechnung und im mittleren codeabschnitt

hier nochmal der komplette 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:

procedure TForm1.GBlur(Bmp: TBitmap; radius: Integer);
Type
  TRGBArray = Array[0..0] of Packed Record b, g, r: byte End;
Var
  BmpCopy: TBitmap;
  BmpCopySL: Array of ^TRGBArray;
  BmpSL: ^TRGBArray;
  x,y, dx,dy, ix,iy, R,G,B, Faktor,divisor,
  BmpHeight,BmpWidth, StartDy,EndDy, StartDx,EndDx: Integer;
  Faktoren: Array of Array of Integer;

  Procedure BerechneFaktoren;
  Var
    x, y: Integer;
    Sqr_: Array of Integer;
  Begin
    SetLength(Sqr_, radius+1);
    for x:=0 to radius Do Sqr_[x]:=Sqr(x);
    SetLength(Faktoren, radius+1, radius+1);
    For x:=0 To radius Do
      For y:=0 To radius Do
        Faktoren[x,y]:=radius-Round(Sqrt(Sqr_[y] + Sqr_[x]));
  End;

Begin
  BmpWidth:=Bmp.Width;
  BmpHeight:=Bmp.Height;
  BmpCopy:=TBitmap.Create;
  Try
    BmpCopy.Assign(Bmp);
    BerechneFaktoren;
    SetLength(BmpCopySL,BmpHeight);
    For y:=0 to Bmp.Height-1 Do
      BmpCopySL[y]:=BmpCopy.ScanLine[y];
    For y:=0 to BmpHeight-1 Do Begin
      BmpSL:=Bmp.ScanLine[y];
      For x:=0 to BmpWidth-1 Do begin
        R:=0; G:=0; B:=0; divisor:=0;

        If y-radius<0 then StartDy:=0-y Else StartDy:=-radius;
        If y+radius>=BmpHeight then EndDy:=(BmpHeight-1)-y Else EndDy:=radius;
        If x-radius<0 then StartDx:=0-x Else StartDx:=-radius;
        If x+radius>=BmpWidth then EndDx:=(BmpWidth-1)-x Else EndDx:=radius;

        For dy:=StartDy To EndDy Do
          For dx:=StartDx To EndDx Do Begin
            iy:=y+dy;
            ix:=x+dx;
            Faktor:=Faktoren[Abs(dy),Abs(dx)];
            If Faktor>0 Then Begin
              R:=R+BmpCopySL[iy,ix].r*Faktor;
              G:=G+BmpCopySL[iy,ix].g*Faktor;
              B:=B+BmpCopySL[iy,ix].b*Faktor;
              divisor:=divisor+Faktor;
            End;
          End;
        If divisor=0 Then divisor:=1;
        R:=R Div divisor;
        G:=G Div divisor;
        B:=B Div divisor;
        If R>255 Then R:=255 Else If R<0 Then R:=0;
        If G>255 Then G:=255 Else If G<0 Then G:=0;
        If B>255 Then B:=255 Else If B<0 Then B:=0;
        BmpSL[x].r:=R;
        BmpSL[x].g:=G;
        BmpSL[x].b:=B;
      End;
    End;
  Finally 
    BmpCopy.Free; 
  End;
End;

AndyB · Beiträge: 1173 Erhaltene Danke: 14 RAD Studio XE2

Schneller dürfte es nicht mehr mit diesem Algorithmus, ohne das ganze selbst in Assembler zu schreiben, gehen.

Bei einem 1024x786 Bild wird die innere Schleife mehr als 32 Millionen mal durchlaufen. Das sollte man noch optimieren. Ohne die Eingrenzung der Start und Endwerte will ich mir die Durchlaufanzahl der inneren Schleife gar nicht vorstellen.

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:

procedure GBlur(Bmp: TBitmap; radius: Integer);
Type
  PRGB = ^TRGB;
  TRGB = Packed Record b, g, r: byte End;
  PRGBArray = ^TRGBArray;
  TRGBArray = Array[0..0] of TRGB;
Var
  BmpCopy: TBitmap;
  BmpCopySL: Array of PRGBArray;
  BmpSL: PRGBArray;
  BmpCopySL_X: PRGBArray;
  x,y, dx,dy, ix,iy, RR,GG,BB, divisor: Integer;
  Faktoren: Array of TIntegerDynArray;

  Procedure BerechneFaktoren;
  Var 
    x, y: Integer;
    Sqr_: Array of Integer;
  Begin
    SetLength(Sqr_, radius+1); 
    for x:=0 to radius Do Sqr_[x]:=Sqr(x); 
    SetLength(Faktoren, radius+1, radius+1); 
    For x:=0 To radius Do 
      For y:=0 To radius Do 
        Faktoren[x,y]:=radius-Round(Sqrt(Sqr_[y] + Sqr_[x])); 
  End;

var
  BmpHeight, BmpWidth: Integer;
  Faktor: Integer;
  StartDy, EndDy, StartDx, EndDx: Integer;
  RGB: PRGB;
  FaktorenX: PIntegerArray;
Begin
  BmpWidth := Bmp.Width;
  BmpHeight := Bmp.Height;

  BmpCopy:=TBitmap.Create;
  Try
    Bmp.PixelFormat := pf24bit; // damit TRGB auch passt
    BmpCopy.Assign(Bmp);
    BerechneFaktoren;
    SetLength(BmpCopySL,BmpHeight);
    For y:=0 to BmpHeight-1 Do
      BmpCopySL[y]:=BmpCopy.ScanLine[y];
    For y:=0 to BmpHeight-1 Do Begin
      BmpSL:=Bmp.ScanLine[y];
      For x:=0 to BmpWidth-1 Do begin
        RR:=0; GG:=0; BB:=0; divisor:=0;
        If y-radius>=0 then StartDy:=-radius else StartDy:=0-y;
        If y+radius<BmpHeight then EndDy:=radius else EndDy:=(BmpHeight-1)-y;
        If x-radius>=0 then StartDx:=-radius else StartDx:=0-x;
        If x+radius<BmpWidth then EndDx:=radius else EndDx:=(BmpWidth-1)-x;
        dy := StartDy;
        Inc(StartDy, y);
        Inc(EndDy, y);
        Inc(StartDx, x);
        Inc(EndDx, x);
        BmpCopySL_X := BmpCopySL[StartDy];
        For iy:=StartDy To EndDy Do
        Begin
          if dy >= 0 then FaktorenX := @Faktoren[dy][0] else FaktorenX := @Faktoren[-dy][0];
          RGB := @BmpCopySL_X[StartDx];
          dx := StartDx - x;
          For ix:=StartDx To EndDx Do Begin
            if dx >= 0 then Faktor := FaktorenX[dx] else Faktor := FaktorenX[-dx];
            inc(dx);
            if Faktor > 0 then begin
              RR:=RR + RGB^.r * Faktor;
              GG:=GG + RGB^.g * Faktor;
              BB:=BB + RGB^.b * Faktor;
              divisor:=divisor+Faktor;
            End;
            Inc(RGB);
          End;
          Inc(dy);
        End;
        If divisor=0 Then divisor:=1;
        RR:=RR Div divisor;
        GG:=GG Div divisor;
        BB:=BB Div divisor;
        If RR>255 Then RR:=255 Else If RR<0 Then RR:=0;
        If GG>255 Then GG:=255 Else If GG<0 Then GG:=0;
        If BB>255 Then BB:=255 Else If BB<0 Then BB:=0;
        BmpSL[x].r:=RR;
        BmpSL[x].g:=GG;
        BmpSL[x].b:=BB;
      End;
    End;
  Finally
    BmpCopy.Free;
  End;
  Bmp.Modified := True; // Bitmap informieren, dass es verändert wurde
End;

_________________
Ist Zeit wirklich Geld?

Phantom1 · Beiträge: 390

hhhm, in den von dir zuletzt geposteten code scheint irgendwo ein fehler drinn zu sein, da das bild nicht korrekt weichgezeichnet wird.

ich hab den fehler leider noch nicht gefunden

AndyB · Beiträge: 1173 Erhaltene Danke: 14 RAD Studio XE2

Zitat:

RGB := @BmpCopySL_X[StartDx];

Diese Zeile müsste so lauten:

markieren

Delphi-Quelltext

1:	RGB := PRGB(BmpCopySL_X[StartDx]);

_________________
Ist Zeit wirklich Geld?

Phantom1 · Beiträge: 390

AndyB hat folgendes geschrieben:

Zitat:

RGB := @BmpCopySL_X[StartDx];

Diese Zeile müsste so lauten:

markieren

Delphi-Quelltext

1:	RGB := PRGB(BmpCopySL_X[StartDx]);

geht leider auch nicht, der sagt dann "ungültige typumwandlung"

Ich habe selbst noch einige optimierungen vorgenommen (dein code ist leider noch nicht dabei) und habe nochmals 25% rausgeholt (es dauert jetzt nur noch 6 statt 8 sekunden :wink:

), 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:

procedure TForm1.GBlur(Bmp: TBitmap; radius: Integer);
Type
  TRGBArray = Array[0..0] of Packed Record b, g, r: byte End;
Var
  BmpCopy: TBitmap;
  BmpCopySL: Array of ^TRGBArray;
  BmpSL: ^TRGBArray;
  x,y, dx,dy, ix,iy, R,G,B, Faktor,divisor, Abs_dy, lx: Integer;
  BmpHeight,BmpWidth, StartDy,EndDy, StartDx,EndDx: Integer;
  Faktoren: Array of Array of Integer;
  MaxX: Array of Integer;

  Procedure BerechneFaktoren;
  Var
    x, y, f: Integer;
    Sqr_: Array of Integer;
  Begin
    SetLength(Sqr_, radius);
    For x:=0 To radius-1 Do Sqr_[x]:=Sqr(x);
    SetLength(MaxX, radius);
    SetLength(Faktoren, radius, radius);
    For y:=0 To radius-1 Do
      For x:=0 To radius-1 Do Begin
        f:=radius-Round(Sqrt(Sqr_[x] + Sqr_[y]));
        Faktoren[y,x]:=f;
        If f=1 Then MaxX[y]:=x; // letzten punkt der im radius liegt suchen
      End;
  End;

Begin
  If radius<1 Then radius:=1;
  Inc(radius);
  BmpWidth:=Bmp.Width;
  BmpHeight:=Bmp.Height;
  BmpCopy:=TBitmap.Create;
  Try
    BmpCopy.Assign(Bmp);
    BerechneFaktoren;
    SetLength(BmpCopySL,BmpHeight);
    For y:=0 To Bmp.Height-1 Do
      BmpCopySL[y]:=BmpCopy.ScanLine[y];
    For y:=0 To BmpHeight-1 Do Begin
      BmpSL:=Bmp.ScanLine[y];
      For x:=0 to BmpWidth-1 Do begin
        R:=0; G:=0; B:=0; divisor:=0;
        If y-radius<0 Then StartDy:=0-y Else StartDy:=-radius;
        If y+radius>=BmpHeight Then EndDy:=(BmpHeight-1)-y Else EndDy:=radius;
        Inc(StartDy); Dec(EndDy);
        For dy:=StartDy To EndDy Do Begin
          Abs_dy:=Abs(dy);
          lx:=MaxX[Abs_dy];
          If x-lx<0 Then StartDx:=0-x Else StartDx:=-lx;
          If x+lx>=BmpWidth Then EndDx:=(BmpWidth-1)-x Else EndDx:=lx;
          For dx:=StartDx To EndDx Do Begin
            iy:=y+dy; ix:=x+dx;
            Faktor:=Faktoren[Abs_dy,Abs(dx)];
            Inc(R,BmpCopySL[iy,ix].r*Faktor);
            Inc(G,BmpCopySL[iy,ix].g*Faktor);
            Inc(B,BmpCopySL[iy,ix].b*Faktor);
            Inc(divisor,Faktor);
          End;
        End;
        R:=R Div divisor;
        G:=G Div divisor;
        B:=B Div divisor;
        If R>255 Then R:=255 Else If R<0 Then R:=0;
        If G>255 Then G:=255 Else If G<0 Then G:=0;
        If B>255 Then B:=255 Else If B<0 Then B:=0;
        BmpSL[x].r:=R;
        BmpSL[x].g:=G;
        BmpSL[x].b:=B;
      End;
    End;
  Finally
    BmpCopy.Free;
  End;
End;

AndyB · Beiträge: 1173 Erhaltene Danke: 14 RAD Studio XE2

Probiere es mal mit

RGB := @BmpCopySL_X[StartDx][0];

Und wenn das auch nicht hilft, dann kannst du wenigstens die innere Schleife noch so umändern:

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:

For x:=0 to BmpWidth-1 Do begin 
  R:=0; G:=0; B:=0; divisor:=0; 
  If y-radius<0 Then StartDy:=0-y Else StartDy:=-radius; 
  If y+radius>=BmpHeight Then EndDy:=(BmpHeight-1)-y Else EndDy:=radius; 
  Inc(StartDy); Dec(EndDy);

  Inc(StartDy, y); Inc(EndDy, y);
  Inc(StartDx, x); Inc(EndDx, x);
  For iy:=StartDy To EndDy Do Begin 
    Abs_dy:=Abs(iy - y); 
    lx:=MaxX[Abs_dy]; 
    If x-lx<0 Then StartDx:=0-x Else StartDx:=-lx; 
    If x+lx>=BmpWidth Then EndDx:=(BmpWidth-1)-x Else EndDx:=lx; 
    dx := StartDx - x;
    For ix:=StartDx To EndDx Do Begin 
      Faktor:=Faktoren[Abs_dy,Abs(dx)]; 
      RGB := @BmpCopySL[iy, ix][0]; // Addressierung nur 1x ausführen
      Inc(R,RGB.r*Faktor); 
      Inc(G,RGB.g*Faktor); 
      Inc(B,RGB.b*Faktor); 
      Inc(divisor,Faktor); 
      Inc(dx);
  End; 
End;

_________________
Ist Zeit wirklich Geld?

Phantom1 · Beiträge: 390

AndyB hat folgendes geschrieben:

Probiere es mal mit

RGB := @BmpCopySL_X[StartDx][0];

das hatte ich auch schon probiert, der sagt dann, "Array-Typ erforderlich"

Durch die letzten optimierungen, dauerts jetzt nur noch 4 statt 6 sekunden, ich denke das reicht aus für meine zwecke.

Und danke nochmal für deine hilfe!

Hier nochmal der komplette 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:

procedure TForm1.GBlur(Bmp: TBitmap; radius: Integer);
Type
  TRGB = Packed Record b, g, r: byte End;
  TRGBArray = Array[0..0] of TRGB;
Var
  BmpCopy: TBitmap;
  BmpCopySL: Array of ^TRGBArray;
  BmpSL: ^TRGBArray;
  BmpRGB, BmpCopyRGB: ^TRGB;
  x,y, dx,dy, R,G,B, Faktor,divisor, Abs_dy, lx: Integer;
  BmpHeight,BmpWidth, StartDy,EndDy, StartDx,EndDx: Integer;
  Faktoren: Array of Array of Integer;
  MaxX: Array of Integer;

  Procedure BerechneFaktoren;
  Var
    x, y, f: Integer;
    Sqr_: Array of Integer;
  Begin
    SetLength(Sqr_, radius);
    For x:=0 To radius-1 Do Sqr_[x]:=Sqr(x);
    SetLength(MaxX, radius);
    SetLength(Faktoren, radius, radius);
    For y:=0 To radius-1 Do
      For x:=0 To radius-1 Do Begin
        f:=radius-Round(Sqrt(Sqr_[x] + Sqr_[y]));
        Faktoren[y,x]:=f;
        If f=1 Then MaxX[y]:=x; // letzten punkt der im radius liegt suchen
      End;
  End;

Begin
  If radius<1 Then radius:=1 Else If radius>100 then radius:=100;
  Inc(radius);
  BmpWidth:=Bmp.Width;
  BmpHeight:=Bmp.Height;
  BmpCopy:=TBitmap.Create;
  Try
    BmpCopy.Assign(Bmp);
    BerechneFaktoren;
    SetLength(BmpCopySL,BmpHeight);
    For y:=0 To BmpHeight-1 Do
      BmpCopySL[y]:=BmpCopy.ScanLine[y];
    For y:=0 To BmpHeight-1 Do Begin
      BmpSL:=Bmp.ScanLine[y];
      BmpRGB:=@BmpSL[0];
      For x:=0 to BmpWidth-1 Do begin
        R:=0; G:=0; B:=0; divisor:=0;
        If y-radius+1<0 Then StartDy:=0-y Else StartDy:=-radius+1;
        If y+radius-1>=BmpHeight Then EndDy:=BmpHeight-1-y Else EndDy:=radius-1;
        For dy:=StartDy To EndDy Do Begin
          Abs_dy:=Abs(dy);
          lx:=MaxX[Abs_dy];
          If x-lx<0 Then StartDx:=0-x Else StartDx:=-lx;
          If x+lx>=BmpWidth Then EndDx:=BmpWidth-1-x Else EndDx:=lx;
          BmpCopyRGB:=@BmpCopySL[y+dy,x+StartDx];
          For dx:=StartDx To EndDx Do Begin
            Faktor:=Faktoren[Abs_dy,Abs(dx)];
            Inc(R,BmpCopyRGB.r*Faktor);
            Inc(G,BmpCopyRGB.g*Faktor);
            Inc(B,BmpCopyRGB.b*Faktor);
            Inc(divisor,Faktor);
            Inc(BmpCopyRGB);
          End;
        End;
        BmpRGB.r:=R Div divisor;
        BmpRGB.g:=G Div divisor;
        BmpRGB.b:=B Div divisor;
        Inc(BmpRGB);
      End;
    End;
  Finally
    BmpCopy.Free;
  End;
End;

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme