Гауссово размывание (Gaussian Blur) в Delphi

Ну вот, добрались и до фильтров. В неформальных испытаниях этот код оказался вдвое быстрее, чем это делает Adobe Photoshop. Мне кажется есть множество фильтров, которые можно переделать или оптимизировать для быстроты обработки изображений.

Ядро гауссовой функции exp(-(x^2 + y^2)) есть разновидность формулы f(x)*g(y), которая означает, что мы можем выполнить двумерную свертку, делая последовательность одномерных сверток - сначала мы свертываем каждую строчку изображения, затем - каждую колонку. Хороший повод для ускорения (N^2 становится N*2). Любая свертка требует некоторого место для временного хранения результатов - ниже в коде программа BlurRow как раз распределяет и освобождает память для каждой колонки. Вероятно это должно ускорить обработку изображения, правда не ясно насколько.

Поле "size" в записи TKernel ограничено значением 200. Фактически, если вы хотите использовать еще больший радиус, это не вызовет проблем - попробуйте со значениями radius = 3, 5 или другими. Для большого количества данных методы свертки на поверку оказываются эффективнее преобразований Фурье (как показали опыты).

Еще один комментарий все же необходим: гауссово размывание имеет одно магическое свойство, а именно - вы можете сначала размыть каждую строчку (применить фильтр), затем каждую колонку - фактически получается значительно быстрее, чем двумерная свертка.

Во всяком случае вы можете сделать так:

unit
 GBlur2;

interface


uses
 Windows, Graphics;

type


  PRGBTriple = ^TRGBTriple;
  TRGBTriple = packed
 record

    b: byte; //легче для использования чем типа 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
;
  //идея заключается в том, что при использовании TKernel мы игнорируем
  //Weights (вес), за исключением Weights в диапазоне -Size..Size.

procedure
 GBlur(theBitmap: TBitmap; radius: double);

implementation


uses
 SysUtils;

procedure
 MakeGaussianKernel(var
 K: TKernel; radius: double;

  MaxData, DataGranularity: double);
//Делаем K (гауссово зерно) со среднеквадратичным отклонением = radius.
//Для текущего приложения мы устанавливаем переменные MaxData = 255,
//DataGranularity = 1. Теперь в процедуре установим значение
//K.Size так, что при использовании K мы будем игнорировать Weights (вес)
//с наименее возможными значениями. (Малый размер нам на пользу,
//поскольку время выполнения напрямую зависит от
//значения 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
;

  //делаем так, чтобы 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;

  //теперь отбрасываем (или делаем отметку "игнорировать"
  //для переменной Size) данные, имеющие относительно небольшое значение -
  //это важно, в противном случае смазавание происходим с малым радиусом и
  //той области, которая "захватывается" большим радиусом...

  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;

  //теперь для корректности возвращаемого результата проводим ту же
  //операцию с K.Size, так, чтобы сумма всех данных была равна единице:

  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
;

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
;

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
;

procedure
 BlurRow(var
 theRow: array
 of
 TRGBTriple; K: TKernel; P: PRow);
var

  j, n, LocalRow: integer;
  tr, tg, tb: double; //tempRed и др.

  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];

      //TrimInt задает отступ от края строки...

      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
;

procedure
 GBlur(theBitmap: TBitmap; radius: double);
var

  Row, Col: integer;
  theRows: PPRows;
  K: TKernel;
  ACol: PRow;
  P: PRow;
begin

  if
 (theBitmap.HandleType <> bmDIB) or
 (theBitmap.PixelFormat <> pf24Bit) then


    raise

      exception.Create('GBlur может работать только с 24-битными изображениями');

  MakeGaussianKernel(K, radius, 255, 1);
  GetMem(theRows, theBitmap.Height * SizeOf(PRow));
  GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));

  //запись позиции данных изображения:
  for
 Row := 0 to
 theBitmap.Height - 1 do


    theRows[Row] := theBitmap.Scanline[Row];

  //размываем каждую строчку:
  P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
  for
 Row := 0 to
 theBitmap.Height - 1 do


    BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);

  //теперь размываем каждую колонку
  ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
  for
 Col := 0 to
 theBitmap.Width - 1 do

  begin

    //- считываем первую колонку в TRow:

    for
 Row := 0 to
 theBitmap.Height - 1 do

      ACol[Row] := theRows[Row][Col];

    BlurRow(Slice(ACol^, theBitmap.Height), K, P);

    //теперь помещаем обработанный столбец на свое место в данные изображения:

    for
 Row := 0 to
 theBitmap.Height - 1 do

      theRows[Row][Col] := ACol[Row];
  end
;

  FreeMem(theRows);
  FreeMem(ACol);
  ReAllocMem(P, 0);
end
;

end
.

Должно работать, если только вы не удалите некоторый код вместе с глупыми коментариями. Для примера:

procedure
 TForm1.Button1Click(Sender: TObject);
var

  b: TBitmap;
begin

  if
 not
 openDialog1.Execute then

    exit;

  b := TBitmap.Create;
  b.LoadFromFile(OpenDialog1.Filename);
  b.PixelFormat := pf24Bit;
  Canvas.Draw(0, 0, b);
  GBlur(b, StrToFloat(Edit1.text));
  Canvas.Draw(b.Width, 0, b);
  b.Free;
end
;

Имейте в виду, что 24-битные изображения при системной 256-цветной палитре требуют некоторых дополнительных хитростей, так как эти изображения не только выглядят в таком случае немного "странными", но и серьезно нарушают работу фильтра.

Другое по теме:

• Быстрая работы с графикой в среде Windows
• Delphi и Flash. Совмещение несовместимого!
• Перемещение Image'a по форме во время работы программы