Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Сделать картинке 2D свертку

01.01.2007
{
 
This function performs a 2D convolution on an image.
 
It can be used for a very wide range of image processing operations
 such
as image smoothing, anti-aliasing, edge detection,
 detail enhancment
, etc. It is very fast.
}
 
 uses
   
Graphics, Windows;
 
 type
   
TRGBTripleArray = array[0..10000] of TRGBTriple;
   
PRGBTripleArray = ^TRGBTripleArray;
 
   T3x3FloatArray
= array[0..2] of array[0..2] of Extended;
 
 implementation
 
 
function Convolve(ABitmap: TBitmap; AMask: T3x3FloatArray;
   
ABias: Integer): TBitmap;
 
var
   LRow1
, LRow2, LRow3, LRowOut: PRGBTripleArray;
   
LRow, LCol: integer;
   
LNewBlue, LNewGreen, LNewRed: Extended;
   
LCoef: Extended;
 
begin
   
LCoef := 0;
   
for LRow := 0 to 2 do
     
for LCol := 0 to 2 do
       
LCoef := LCoef + AMask[LCol, LRow];
   
if LCoef = 0 then LCoef := 1;
 
   
Result := TBitmap.Create;
 
   
Result.Width := ABitmap.Width - 2;
   
Result.Height := ABitmap.Height - 2;
   
Result.PixelFormat := pf24bit;
 
   LRow2
:= ABitmap.ScanLine[0];
   LRow3
:= ABitmap.ScanLine[1];
 
   
for LRow := 1 to ABitmap.Height - 2 do
   
begin
     LRow1
:= LRow2;
     LRow2
:= LRow3;
     LRow3
:= ABitmap.ScanLine[LRow + 1];
 
     
LRowOut := Result.ScanLine[LRow - 1];
 
     
for LCol := 1 to ABitmap.Width - 2 do
     
begin
       
LNewBlue :=
         
(LRow1[LCol - 1].rgbtBlue * AMask[0,0]) + (LRow1[LCol].rgbtBlue * AMask[1,0]) +
         
(LRow1[LCol + 1].rgbtBlue * AMask[2,0]) +
         
(LRow2[LCol - 1].rgbtBlue * AMask[0,1]) + (LRow2[LCol].rgbtBlue * AMask[1,1]) +
         
(LRow2[LCol + 1].rgbtBlue * AMask[2,1]) +
         
(LRow3[LCol - 1].rgbtBlue * AMask[0,2]) + (LRow3[LCol].rgbtBlue * AMask[1,2]) +
         
(LRow3[LCol + 1].rgbtBlue * AMask[2,2]);
       
LNewBlue := (LNewBlue / LCoef) + ABias;
       
if LNewBlue > 255 then
         
LNewBlue := 255;
       
if LNewBlue < 0 then
         
LNewBlue := 0;
 
       
LNewGreen :=
         
(LRow1[LCol - 1].rgbtGreen * AMask[0,0]) + (LRow1[LCol].rgbtGreen * AMask[1,0]) +
         
(LRow1[LCol + 1].rgbtGreen * AMask[2,0]) +
         
(LRow2[LCol - 1].rgbtGreen * AMask[0,1]) + (LRow2[LCol].rgbtGreen * AMask[1,1]) +
         
(LRow2[LCol + 1].rgbtGreen * AMask[2,1]) +
         
(LRow3[LCol - 1].rgbtGreen * AMask[0,2]) + (LRow3[LCol].rgbtGreen * AMask[1,2]) +
         
(LRow3[LCol + 1].rgbtGreen * AMask[2,2]);
       
LNewGreen := (LNewGreen / LCoef) + ABias;
       
if LNewGreen > 255 then
         
LNewGreen := 255;
       
if LNewGreen < 0 then
         
LNewGreen := 0;
 
       
LNewRed :=
         
(LRow1[LCol - 1].rgbtRed * AMask[0,0]) + (LRow1[LCol].rgbtRed * AMask[1,0])
         
+ (LRow1[LCol + 1].rgbtRed * AMask[2,0]) +
         
(LRow2[LCol - 1].rgbtRed * AMask[0,1]) + (LRow2[LCol].rgbtRed * AMask[1,1])
         
+ (LRow2[LCol + 1].rgbtRed * AMask[2,1]) +
         
(LRow3[LCol - 1].rgbtRed * AMask[0,2]) + (LRow3[LCol].rgbtRed * AMask[1,2])
         
+ (LRow3[LCol + 1].rgbtRed * AMask[2,2]);
       
LNewRed := (LNewRed / LCoef) + ABias;
       
if LNewRed > 255 then
         
LNewRed := 255;
       
if LNewRed < 0 then
         
LNewRed := 0;
 
       
LRowOut[LCol - 1].rgbtBlue  := trunc(LNewBlue);
       
LRowOut[LCol - 1].rgbtGreen := trunc(LNewGreen);
       
LRowOut[LCol - 1].rgbtRed   := trunc(LNewRed);
     
end;
   
end;
 
end;
 
 
// example use
// edge detection
procedure TForm1
.Button1Click(Sender: TObject);
 
var
   
LMask: T3x3FloatArray;
 
begin
   
LMask[0,0] := -1;
   
LMask[1,0] := -1;
   
LMask[2,0] := -1;
   
LMask[0,1] := -1;
   
LMask[1,1] := 8;
   
LMask[2,1] := -1;
   
LMask[0,2] := -1;
   
LMask[1,2] := -1;
   
LMask[2,2] := -1;
   Image1
.Picture.Bitmap := Convolve(Image1.Picture.Bitmap, LMask, 0);
 
end;

Взято с сайта: https://www.swissdelphicenter.ch