Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Курс видеоуроков программирования и крэкерства 6.0
(актуальность: февраль 2017)
Свежие инструменты, новые видеоуроки!

  • 300+ видеоуроков
  • 800 инструментов
  • 80 свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



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




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS