Delphi World - Гауссово размывание (Gaussian Blur) в Delphi
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Гауссово размывание (Gaussian Blur) в Delphi

Автор: Den is Com

Ну вот, добрались и до фильтров. В неформальных испытаниях этот код оказался вдвое быстрее, чем это делает 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-цветной палитре требуют некоторых дополнительных хитростей, так как эти изображения не только выглядят в таком случае немного "странными", но и серьезно нарушают работу фильтра.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования