Советы по Delphi
         

Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки


Публикую полностью работу . Основана на коде модуля gblur2 из предыдущего совета:

Данный метод позволяет создавать тень у текстовых меток TLabel. Не требует лазить в Photoshop и что-то ваять там - тень рисуется динамически, поэтому и объём программы не раздувает. Создание тени присходит в фоновом режиме, во время "простоя" процессора.

Пример использования:

ShowFade(CaptionLabel);
//или
ShowFadeWithParam(CaptionLabel,3,3,2,clGray);

Blur.pas



 unit blur;

interface

uses
Classes,graphics,stdctrls,gblur2;const add_width=4;
add_height=5;type
TBlurThread = class(TThread)private{ Private declarations }text_position:Integer;FadeLabel:TLabel;Temp_Bitmap:TBitmap;
procedure ShowBlur;procedure SetSize;protectedF_width,F_X,F_Y:Integer;F_color:TColor;procedure Execute; override;public
constructor Create(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor);destructor Destroy;
end;procedure ShowFade(Sender:TLabel);procedure ShowFadeWithParam(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor);
implementation
procedure ShowFadeWithParam(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor);var SlowThread:TBlurThread;beginSlowThread:=TBlurThread.Create(Sender,Fade_width,Fade_X,Fade_Y,Fade_color);SlowThread.Priority:=tpIdle;SlowThread.Resume;end;
procedure ShowFade;var SlowThread:TBlurThread;beginSlowThread:=TBlurThread.Create(Sender,3,3,3,clBlack);SlowThread.Priority:=tpIdle;//SlowThread.Priority:=tpLowest;//SlowThread.Priority:=tpTimeCritical;SlowThread.Resume;end;constructor TBlurThread.Create(Sender:TLabel;Fade_width:integer;Fade_X:Integer;Fade_Y:Integer;Fade_color:TColor);beginTemp_Bitmap:=TBitmap.Create;Temp_Bitmap.Canvas.Font:=Sender.Font;FadeLabel:=Sender;F_width:=Fade_width;F_X:=Fade_X;F_Y:=Fade_Y;F_color:=Fade_color;inherited Create(True);end;
destructor TBlurThread.Destroy;beginTemp_Bitmap.Free;inherited Destroy;end;
procedure TBlurThread.ShowBlur;beginFadeLabel.Canvas.Draw(text_position+F_X,F_Y,Temp_Bitmap);FadeLabel.Canvas.TextOut(text_position,0,FadeLabel.Caption);end;
procedure TBlurThread.SetSize;beginif FadeLabel.Width<(Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)+F_width+F_X{add_width}) thenbegin
FadeLabel.Width:=Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)+F_width+F_X{add_width};
FadeLabel.Tag:=2;
end
else
FadeLabel.Tag:=0;

if FadeLabel.Height<(Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption)+F_width+F_Y{add_height}) then
begin
FadeLabel.Height:=Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption)+F_width+F_Y{add_height};
FadeLabel.Tag:=1;
end
else
if FadeLabel.Tag<>2 then
FadeLabel.Tag:=0;
end;
{ TBlurThread }

procedure TBlurThread.Execute;
begin
{ Place thread code here }Synchronize(SetSize);

if FadeLabel.Tag=0 then beginTemp_Bitmap.Width:=FadeLabel.Width;
Temp_Bitmap.Height:=FadeLabel.Height;
Temp_Bitmap.Canvas.Brush.Color:=FadeLabel.Color;
Temp_Bitmap.Canvas.FillRect(FadeLabel.ClientRect);
Temp_Bitmap.Canvas.Font.Color:=F_color; //clBlack

if FadeLabel.Alignment=taRightJustify then
text_position:=FadeLabel.Width-Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)-F_width-F_X{add_width}
else
if FadeLabel.Alignment=taCenter then
text_position:=(FadeLabel.Width-Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption)-F_width-F_X{add_width}) div 2
else
text_position:=0;

Temp_Bitmap.Canvas.TextOut(0,0,FadeLabel.Caption);
Temp_Bitmap.PixelFormat:= pf24Bit;
GBlur(Temp_Bitmap,F_width);
//Temp_Bitmap.SaveToFile('a.bmp');
Synchronize(ShowBlur);
end;


end;

end.

[000814]


Ну вот, добрались и до фильтров. В неформальных испытаниях этот код оказался вдвое быстрее, чем это делает 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 recordb: 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 = recordSize: 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) dobegintemp:= j/radius;K.Weights[j]:= exp(- temp*temp/2);end;
//делаем так, чтобы sum(Weights) = 1:

temp:= 0;for j:= Low(K.Weights) to High(K.Weights) dotemp:= temp + K.Weights[j];for j:= Low(K.Weights) to High(K.Weights) doK.Weights[j]:= K.Weights[j] / temp;

//теперь отбрасываем (или делаем отметку "игнорировать"
//для переменной Size) данные, имеющие относительно небольшое значение -
//это важно, в противном случае смазавание происходим с малым радиусом и
//той области, которая "захватывается" большим радиусом...
KernelSize:= MaxKernelSize;delta:= DataGranularity / (2*MaxData);temp:= 0;while (temp < delta) and (KernelSize > 1) dobegintemp:= temp + 2 * K.Weights[KernelSize];dec(KernelSize);end;
K.Size:= KernelSize;
//теперь для корректности возвращаемого результата проводим ту же
//операцию с K.Size, так, чтобы сумма всех данных была равна единице:

temp:= 0;for j:= -K.Size to K.Size dotemp:= temp + K.Weights[j];for j:= -K.Size to K.Size doK.Weights[j]:= K.Weights[j] / temp;
end;

function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
if (theInteger <= Upper) and (theInteger >= Lower) thenresult:= theIntegerelseif theInteger > Upper thenresult:= Upperelseresult:= Lower;end;

function TrimReal(Lower, Upper: integer; x: double): integer;
begin
if (x < upper) and (x >= lower) thenresult:= trunc(x)elseif x > Upper thenresult:= Upperelseresult:= 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
begintb:= 0;tg:= 0;tr:= 0;for n:= -K.Size to K.Size dobeginw:= K.Weights[n];
//TrimInt задает отступ от края строки...
with theRow[TrimInt(0, High(theRow), j - n)] dobegintb:= tb + w * b;tg:= tg + w * g;tr:= tr + w * r;end;end;with P[j] dobeginb:= 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 doACol[Row]:= theRows[Row][Col];

BlurRow(Slice(ACol^, theBitmap.Height), K, P);
//теперь помещаем обработанный столбец на свое место в данные изображения:
for Row:= 0 to theBitmap.Height - 1 dotheRows[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-цветной палитре требуют некоторых дополнительных хитростей, так как эти изображения не только выглядят в таком случае немного "странными", но и серьезно нарушают работу фильтра. [000124]



Содержание раздела