unit ads_BitmapBlurGaussian;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_BitmapBlurGaussian.pas This unit contains the following routines.
BitmapBlurGaussian_1 BitmapBlurGaussian_2 BitmapBlurGaussian_3 BitmapBlurGaussian_4 BlurRow MakeGaussianKernel TrimInt TrimReal
*) interface uses Windows, Graphics; Function BitmapBlurGaussian( Bitmap : TBitmap; radius : double ): Boolean; OverLoad; Function BitmapBlurGaussian( BitmapSource : TBitmap; BitmapOut : TBitmap; radius : double ): Boolean; OverLoad; Function BitmapBlurGaussian( BitmapSourceFile: String; BitmapOutFile : String; radius : double ): Boolean; OverLoad; Function BitmapBlurGaussian( BitmapFile : String; radius : double ): Boolean; OverLoad; implementation uses SysUtils; //Unit Description UnitIndex Master Index
Function BitmapBlurGaussian(
BitmapSource: TBitmap;
BitmapOut : TBitmap;
radius: double
): Boolean; OverLoad;
Var
Bitmap : TBitmap;
Begin
Bitmap := TBitmap.Create();
Try
Result := BitmapBlurGaussian(Bitmap,radius);
If Result Then BitmapOut.Assign(Bitmap);
Finally
Bitmap.Free;
End;
End;
//Unit Description UnitIndex Master Index
Function BitmapBlurGaussian(
BitmapSourceFile: String;
BitmapOutFile : String;
radius : double
): Boolean; OverLoad;
Var
Bitmap : TBitmap;
Begin
Result := False;
If Not FileExists(BitmapSourceFile) Then Exit;
Bitmap := TBitmap.Create();
Try
Bitmap.LoadFromFile(BitmapSourceFile);
Result := BitmapBlurGaussian(Bitmap,radius);
If Result Then
Begin
If FileExists(BitmapOutFile) Then DeleteFile(BitmapOutFile);
Bitmap.SaveToFile(BitmapOutFile);
End;
Finally
Bitmap.Free;
End;
End;
//Unit Description UnitIndex Master Index
Function BitmapBlurGaussian(
BitmapFile : String;
radius : double
): Boolean; OverLoad;
Begin
Result :=
BitmapBlurGaussian(
BitmapFile, //BitmapSourceFile: String;
BitmapFile, //BitmapOutFile : String;
Radius //radius : double
);//): Boolean; OverLoad;
End;
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;
const
MaxKernelSize = 100;
type
TKernelSize = 1..MaxKernelSize;
TKernel = record
Size: TKernelSize;
Weights: array[-MaxKernelSize..MaxKernelSize] of single;
end;
{the idea is that when using a TKernel you ignore the Weights except
for Weights in the range -Size..Size.}
//Unit Description UnitIndex Master Index
procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double);
{makes K into a gaussian kernel with standard deviation = radius. For the
current application you set MaxData = 255 and DataGranularity = 1. Now
the procedure sets the value of K.Size so that when we use K we will
ignore the Weights that are so small they can't possibly matter. (Small Size
is good because the execution time is going to be propertional to K.Size.)}
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;
{now divide by constant so sum(Weights) = 1:}
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;
{now discard (or rather mark as ignorable by setting Size) the entries that
are too small to matter - this is important, otherwise a blur with a small radius
will take as long as with a large radius...}
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;
{now just to be correct go back and jiggle again so the sum of the entries
we'll be using is exactly 1}
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
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;
//Unit Description UnitIndex Master Index
procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
j, n: integer;
tr, tg, tb: double; {tempRed, etc}
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];
{the TrimInt keeps us from running off the edge of the row...}
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;
//Unit Description UnitIndex Master Index
Function BitmapBlurGaussian(Bitmap: TBitmap; radius: double): Boolean;
Var
Row : integer;
Col : integer;
theRows : PPRows;
K : TKernel;
ACol : PRow;
P : PRow;
Begin
Try
If (Bitmap.HandleType <> bmDIB) or (Bitmap.PixelFormat <> pf24Bit) Then
raise exception.Create('GBlur only works for 24-bit bitmaps');
MakeGaussianKernel(K, radius, 255, 1);
GetMem(theRows, Bitmap.Height * SizeOf(PRow));
GetMem(ACol, Bitmap.Height * SizeOf(TRGBTriple));
{record the location of the bitmap data:}
for Row := 0 to Bitmap.Height - 1 do
theRows[Row] := Bitmap.Scanline[Row];
{blur each row:}
P := AllocMem(Bitmap.Width * SizeOf(TRGBTriple));
for Row := 0 to Bitmap.Height - 1 do
BlurRow(Slice(theRows[Row]^, Bitmap.Width), K, P);
{now blur each column}
ReAllocMem(P, Bitmap.Height * SizeOf(TRGBTriple));
for Col := 0 to Bitmap.Width - 1 do
begin
{first read the column into a TRow:}
for Row := 0 to Bitmap.Height - 1 do
ACol[Row] := theRows[Row][Col];
BlurRow(Slice(ACol^, Bitmap.Height), K, P);
{now put that row, um, column back into the data:}
for Row := 0 to Bitmap.Height - 1 do
theRows[Row][Col] := ACol[Row];
end;
FreeMem(theRows);
FreeMem(ACol);
ReAllocMem(P, 0);
Result := True;
Except
Result := False;
End;
end;
end.
//