Процедуры по обработке изображений.

The Shadow · #1 07.10.2007, 16:01

Если кто может, пожалуйста, выложите какие-нибудь процедуры для обработки изображений, типа Motion Blur, Smart Blur, уменьшение шума и др.

zip000 · #2 07.10.2007, 16:36

http://delphisources.ru/pages/faq/graph_games.html
Смотри разделы Графика и Изображения.

4kusNick · #3 07.10.2007, 18:51

Это юнит для Блура:

Код:

unit DGraphBlur;

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: 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
  begin
    theRows[Row] := theBitmap.Scanline[Row];
		//Filters.ProgressBar.StepIt;
    //Filters.ProgressBar.Update;
  end;

  //размываем каждую строчку:
  P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
  for Row := 0 to theBitmap.Height - 1 do
  begin
    BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
		//Filters.ProgressBar.StepIt;
    //Filters.ProgressBar.Update;
  end;

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

    //- считываем первую колонку в 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.

Winny · #4 08.10.2007, 12:04

Цитата:

Сообщение от 4kusNick

Это юнит для Блура:

Код:

unit DGraphBlur;

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: 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
  begin
    theRows[Row] := theBitmap.Scanline[Row];
		//Filters.ProgressBar.StepIt;
    //Filters.ProgressBar.Update;
  end;

  //размываем каждую строчку:
  P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
  for Row := 0 to theBitmap.Height - 1 do
  begin
    BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
		//Filters.ProgressBar.StepIt;
    //Filters.ProgressBar.Update;
  end;

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

    //- считываем первую колонку в 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.

Разве код 4KusNick'а это не эффект MotionBlur'а?

The Shadow · #5 08.10.2007, 14:48

Нет. Не MotionBlur'а. Это скорее GaussianBlur. А MotionBlur - это размытие в движение.

4kusNick · #6 07.10.2007, 18:58

В аттаче модуль DGraphBlur - его можно на прямую не использовать, т.к. в аттаче есть еще небольшой мой модуль DGraphFunctions для работы с эффектами, в нем и DGraphBlur используется.

Вот список процедур и ф-ий:

Код:

//////////////////////////////////////////////////////////////////////////////
  // процедуры
  //////////////////////////////////////////////////////////////////////////////

  procedure Sharpen(sbm, tbm: TBitmap; alpha: Single);
  procedure Contrast(Bitmap: TBitmap; Value: Integer; Local: Boolean);
  procedure PutImageToImage(bmLogo,bmOutput: TBitmap; iX,iY: Integer; bTransp: Boolean; colTransp: TColor);
  procedure Brightness(const Bmp: TBitmap; iValue: Smallint);
  procedure Blur(Bmp: TBitmap; fValue: Double);
  procedure Bevel(Bmp: TBitmap; iRadius: Integer; colColor: TColor);
  procedure RotateBitmap(Bitmap: TBitmap; Angle: Double; BackColor: TColor);

  //////////////////////////////////////////////////////////////////////////////
  // функции
  //////////////////////////////////////////////////////////////////////////////

  function BmpToSepia(const Bmp: TBitmap; Depth: Integer): Boolean;
  function DoGrayScale(const Bmp: TBitmap): Boolean;
  function PutTextToImage(Bitmap: TBitmap; iX,iY: Integer; sText: String; colBackColor: TColor; bBackTransp: Boolean; fFont: TFont): Boolean;
  function GetPixelColor: String;
  function SimpleResize(bmpIn,bmpOut: TBitmap; iHeight,iWidth: Integer; btSide{1-by Width,2-by Height,3-Proportional}: Byte): Boolean;
  function CustomResize(sImagePath,sSavingType,sDestImagePath: String; iHeight,iWidth: Integer; btSide{1-by Width,2-by Height,3-Proportional}: Byte): Boolean;

Если будет не понятно, как пользоваться какими-то ф-ми или процедурами, пишите, покажу на примере.

Karsh · #7 08.10.2007, 01:55

Вот еще один пример.
Компонент от Babak Sateli (там все наглядно показано):

Karsh · #8 08.10.2007, 03:44

Можешь еще и тут глянуть:
Единая база процедур и функций для Delphi

The Shadow · #9 08.10.2007, 11:12

А SmartBlur'а и MotionBlur'а нет ни у кого?

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты