//Advanced Delphi Systems Code: ads_BitmapBlurGaussian
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.
//