...

procedure Smooth(Dest, Source: TBitmap; S: Byte; X: Integer = 0; Y: Integer = 0;
   MinCasualOpacity: Byte = 0; MaxCasualOpacity: Byte = 0);

implementation
{----------------------------------------------------------------}
function GetBounds(VLeft,VTop,VWidth,VHeight:Integer):TBounds;
begin
with Result do
 begin
 Left:=VLeft;
 Top:=VTop;
 Width:=VWidth;
 Height:=VHeight;
 end;
end;
{----------------------------------------------------------------}
function BoundsAnd(B1,B2:TBounds):TBounds;
var LStart,LLength:Integer;
 {------------------------------------------------------}
 procedure AndFuncAtOneDirection(Start1,Length1:Integer;
     Start2,Length2:Integer);
 begin
 LStart:=0;
 LLength:=0;
 if (Start1<=Start2)AND(Start1+Length1<=Start2+Length2)
 then
   begin
   LStart:=Start2;
   LLength:=Start1+Length1-Start2;
   end;
 if (Start1<=Start2)AND(Start1+Length1>Start2+Length2)
 then
   begin
   LStart:=Start2;
   LLength:=Length2;
   end;
 if (Start1>=Start2)AND(Start1+Length1>=Start2+Length2)
 then
   begin
   LStart:=Start1;
   LLength:=Start2+Length2-Start1;
   end;
 if (Start1>=Start2)AND(Start1+Length1<Start2+Length2)
 then
   begin
   LStart:=Start1;
   LLength:=Length1;
   end;
 if LLength<0
 then
   LLength:=0;
 end;
 {------------------------------------------------------}
begin
AndFuncAtOneDirection(B1.Left,B1.Width,B2.Left,B2.Width);
Result.Left:=LStart;
Result.Width:=LLength;
AndFuncAtOneDirection(B1.Top,B1.Height,B2.Top,B2.Height);
Result.Top:=LStart;
Result.Height:=LLength;
end;
{----------------------------------------------------------------}
procedure Smooth(Dest, Source: TBitmap; S: Byte; X: Integer = 0; Y: Integer = 0;
   MinCasualOpacity: Byte = 0; MaxCasualOpacity: Byte = 0);
var
 DestP, SourceP, Temp: PAC;
 DestRow, SourceRow: Integer;
 i1, i2, j1, j2, n1, n2, m1, m2: Integer;
 MinWidth, MinHeight: Integer;
 Bounds1, Bounds2: TBounds;
 {------------------------------------------------------}
 k: Integer;
 CAY: array [0..3] of ACD;
 M: ACD;
 MIndex: Integer;
 CAX: array [0..3] of Cardinal;
 StartX, FinX, StartY, FinY: Integer;

 DivisorY, DivisorX: Cardinal;

 {------------------------------------------------------}
 function Borders(Value, MinV, MaxV: Integer): Integer;
 begin
 Result := Value;
 if Result < MinV
 then
   Result := MinV;
 if Result > MaxV
   then
   Result := MaxV;
 end;
 {------------------------------------------------------}

begin
{------------------------------------------------------}
Bounds1 := BoundsAnd(GetBounds(0, 0, Dest.Width, Dest.Height),
   GetBounds(X, Y, Source.Width, Source.Height));
Bounds2 := GetBounds(Bounds1.Left - X - S, Bounds1.Top - Y - S,
   Bounds1.Width + 2 * S, Bounds1.Height + 2 * S);
Bounds2 := BoundsAnd(Bounds2, GetBounds(0, 0, Source.Width, Source.Height));

if (Bounds1.Width <= 0) OR (Bounds1.Height <= 0)
then
 Exit;

Dest.PixelFormat:=pf32bit;
DestP:=Dest.ScanLine[Bounds1.Top];
DestRow:=Dest.Width*4;

Source.PixelFormat:=pf32bit;
SourceP:=Source.ScanLine[Bounds1.Top - Y];
SourceRow:=Source.Width*4;

{------------------------------------------------------}
for k := 0 to 3 do
 begin
 SetLength(CAY[k], Bounds2.Width);
 end;
SetLength(M, (S * 2) + 1);
i1 := (S * 2);
for MIndex := 0 to i1 do
 begin
 if MIndex > S
 then
   M[MIndex] := M[2 * S - MIndex]
 else
   M[MIndex] := (255 * (MIndex + 1)) DIV (S + 1);
 end;
{------------------------------------------------------}
i1 := Bounds1.Top;
while i1 < (Bounds1.Top + Bounds1.Height) do
 begin
 i2 := i1 - Y;
 {------------------------------------------------------}
 StartY := Borders(i2 - S, Bounds2.Top, Bounds2.Top + Bounds2.Height - 1);
 FinY   := Borders(i2 + S, Bounds2.Top, Bounds2.Top + Bounds2.Height - 1);
 DivisorY := 0;
 m2 := 0;
 while m2 < (Bounds2.Width)  do
   begin
   {------------------------------------------------------}
   j2 := m2 + Bounds2.Left;
   for k := 0 to 3 do
     begin
     CAY[k][m2] := 0;
     end;
   n2 := StartY;
   DivisorY := 0;
   while n2 <= FinY do
     begin
     Integer(Temp) := Integer(SourceP) - SourceRow * (n2 - i2);
     {------------------------------------------------------}
     MIndex := n2 - i2 + S;
     DivisorY := DivisorY + M[MIndex];
     for k := 0 to 3 do
       begin
       CAY[k][m2] := CAY[k][m2] + RDWord(Temp^[j2]).B[k] * M[MIndex];
       end;
     {------------------------------------------------------}
     n2 := n2 + 1;
     end;
   {------------------------------------------------------}
   m2 := m2 + 1;
   end;
 {------------------------------------------------------}

 j1 := Bounds1.Left;
 while j1 < (Bounds1.Left + Bounds1.Width) do
   begin
   j2 := j1 - X;
   {------------------------------------------------------}
   StartX := Borders(j2 - S, Bounds2.Left,
       Bounds2.Left + Bounds2.Width - 1) - Bounds2.Left;
   FinX   := Borders(j2 + S, Bounds2.Left,
       Bounds2.Left + Bounds2.Width - 1) - Bounds2.Left;
   for k := 0 to 3 do
     begin
     CAX[k] := 0;
     end;
   DivisorX := 0;
   m2 := StartX;
   while m2 <= FinX do
     begin
     {------------------------------------------------------}
     MIndex := m2 - j2 + Bounds2.Left + S;
     DivisorX := DivisorX + M[MIndex];
     for k := 0 to 3 do
       begin
       CAX[k] := CAX[k] + (CAY[k][m2] * M[MIndex]) DIV (DivisorY);
       end;
     {------------------------------------------------------}
     m2 := m2 + 1;
     end;
   if MaxCasualOpacity = MinCasualOpacity
   then
     begin
     for k := 0 to 3 do
       begin
       RDWord(DestP^[j1]).B[k] := (CAX[k]) DIV (DivisorX);
       end;
     end
   else
     begin
     m1:= RandomRange(MinCasualOpacity, MaxCasualOpacity);
     for k := 0 to 3 do
       begin
       RDWord(DestP^[j1]).B[k] := (RDWord(SourceP^[j2]).B[k] * Cardinal(m1) +
           (CAX[k]) DIV (DivisorX) * (255 - Cardinal(m1))) DIV (255);
       end;
     end;
   {------------------------------------------------------}
   j1 := j1 + 1;
   end;
 {------------------------------------------------------}
 i1 := i1 + 1;
 Integer(SourceP) := Integer(SourceP) - SourceRow;
 Integer(DestP) := Integer(DestP) - DestRow;
 end;
{------------------------------------------------------}
for k := 0 to 3 do
 begin
 SetLength(CAY[k], 0);
 end;
SetLength(M, 0);
end;

end.