//
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 Units
Description: 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. //