11. освобождается выделенная память для скопированного изображения и обработки строк.
12. (по выбору пункта «операции - сохранить» на вкладке «результат») данные результативного изображения сохраняются в файл.
const
MaxKernelSize = 64;
delay_names = 'миллисекунд';
//for image
PRGBTriple = ^TPxlC;
TPxlC = record//TPxlC
b:byte;
g:byte;
r:byte;
end;
PRow = ^TRow; //массив картинки
TRow = array[0..1000000] of TPxlC;
PPRows = ^TPRows; //массивстрокипикселей
TPRows = array[0..1000000] of PRow;
TKernelSize = 1..MaxKernelSize;
TKernel = record //зерно
Size: TKernelSize; //размер зерна
Weights: array[-(MaxKernelSize-1)..MaxKernelSize] of single;
end;
TXMMSingle = array[0..3] of Single;//массив для SSE
TXMMArrByte = array[0..15] of byte;//массив пикселей
TXMMRsByte = record
item:TXMMArrByte;
end;
TSSERegLines = array[0..5] of TXMMRsByte;
//основная процелура размытия
procedure GBlur(theBitmap: TBitmap; radius: double; withSSE:boolean);
var
frm_img: Tfrm_img;
implementation
uses DateUtils, optscopyimg, optsblurimg;
{$R *.dfm}
const
MAX_imageSize = 65535;
//построение зерна (списка весов) размытия (без SSE)
//MakeGaussianKernel noSSE-----------------------------------------------------
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;
a,b:smallint;
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;
//построение зерна (списка весов) размытия с SSE
//MakeGaussianKernel SSE-------------------------------------------------------
procedure MakeGaussianKernelSSE(var K: TKernel; radius: double;
MaxData, DataGranularity: double);
//Делаем K (гауссово зерно) со среднеквадратичным отклонением = radius.
//Для текущего приложения мы устанавливаем переменные MaxData = 255,
//DataGranularity = 1. Теперь в процедуре установим значение
//K.Size так, что при использовании K мы будем игнорировать Weights (вес)
//с наименее возможными значениями. (Малый размер нам на пользу,
//поскольку время выполнения напрямую зависит от
//значения K.Size.)
const
nmax=3;
var
j: integer;
temp, delta: double;
KernelSize: TKernelSize;
xmm_n,xmm_r,xmm_a:TXMMSingle;
_low,_high,na:smallint;
begin
_low:=Low(K.Weights);
_high:=High(K.Weights);
j:=_low;
for na:=0 to nmax do xmm_a[na]:=2;//константа 2
for na:=0 to nmax do xmm_r[na]:=radius;//радиус
asm
push eax
push ebx
push ecx
push edx
movups xmm0,xmm_a//2 в SSE
movups xmm1,xmm_r//радиус в SSE
end;
while (j<=_high) do begin
for na:=0 to nmax do
if ((j+na)<=_high) then
xmm_n[na]:=j+na
else break;
//копирование простое и передача не дает оптимизации в SSE
asm
movups xmm2,xmm_n //j
divps xmm2,xmm1 //j/radius
movups xmm_n,xmm2
mulps xmm2,xmm2 //temp^2
movups xmm_n,xmm2
divps xmm2,xmm0 //temp*temp/2
movups xmm_n,xmm2
end;//asm
for na:=0 to nmax do begin
if (j<=_high) then
K.Weights[j]:=exp(-xmm_n[na])
else break;
inc(j);
end;//for
end;//while
//получили строку весов (зерна)
//делаем так, чтобы 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;//делим каждое на сумму (нормирование)
for na:=0 to nmax do xmm_n[na]:=temp;
asm
movups xmm0,xmm_n;
end;
j:=_low;
while (j<=_high) do begin
for na:=0 to nmax do begin
if ((j+na)<=_high) then
xmm_n[na]:=K.Weights[j+na]
else break;
end;//for
asm
movups xmm1,xmm_n
divps xmm1,xmm0//K.Weights[j]/temp
movups xmm_n,xmm1
end;
for na:=0 to nmax do begin
if (j<=_high) then
K.Weights[j]:=xmm_n[na]
else break;
inc(j);
end;
end;//while
//отбрасываем (или делаем отметку "игнорировать"
//для переменной 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 na:=0 to nmax do xmm_n[na]:=temp;
asm
movups xmm0,xmm_n;
end;
j:=_low;
while (j<=_high) do begin
for na:=0 to nmax do begin
if ((j+na)<=_high) then
xmm_n[na]:=K.Weights[j+na]
else break;
end;//for
asm
movups xmm1,xmm_n
divps xmm1,xmm0//K.Weights[j]/temp
movups xmm_n,xmm1
end;
for na:=0 to nmax do begin
if (j<=_high) then
K.Weights[j]:=xmm_n[na]
else break;
inc(j);
end;
end;//while
asm
pop edx
pop ecx
pop ebx
pop eax
end;
end;
//TrimInt - округление по указаным границам Integer
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;
//TrimReal - округление по указанным рамкам Real
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;
//BlurRow - размытие строки без SSE
procedure BlurRow(var theRow: array of TPxlC; 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;//with
end;//for
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(TPxlC));
end;
//GBlur - полное размытие картинки
procedure GBlur(theBitmap: TBitmap; radius: double; withSSE:boolean);
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-битными изображениями');
if (withSSE) then MakeGaussianKernelSSE(K, radius, 255, 1)
else MakeGaussianKernel(K, radius, 255, 1);
GetMem(theRows, theBitmap.Height * SizeOf(PRow));
GetMm(ACol, theBitmap.Height * SizeOf(TPxlC));
frm_img.img_pbar.Max:=theBitmap.Height+theBitmap.Width+4;
//запись позиции данных изображения:
forRow := 0 totheBitmap.Height - 1 do
theRows[Row] := theBitmap.Scanline[Row];
//размываем каждую строчку:
P := AllocMem(theBitmap.Width * SizeOf(TPxlC));
if (frm_imgbluropts.CheckBox1.Checked) then begin
for Row := 0 to theBitmap.Height - 1 do begin
BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
frm_img.img_pbar.StepBy(1);
end;
end;
//теперь размываем каждую колонку
ReAllocMem(P, theBitmap.Height * SizeOf(TPxlC));
if (frm_imgbluropts.CheckBox2.Checked) then begin
for Col := 0 to theBitmap.Width - 1 do
begin
//- считываем первую колонку в TRow:
frm_img.img_pbar.StepBy(1);
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;
end;
FreeMem(theRows);
FreeMem(ACol);
ReAllocMem(P, 0);
frm_img.img_pbar.Max:=0;
end;
//end blur---------------------------------------------------------------------
//открыть картинку
procedure Tfrm_img.act_srcOpenImageExecute(Sender: TObject);
begin
if (img_OpenPictureDialog.Execute) then begin
img_src.Picture.LoadFromFile(img_OpenPictureDialog.FileName);
img_lblImageSizeV.Caption:=format('%d - %d',[img_src.Picture.Width,img_src.Picture.Height]);
img_log.Lines.Add(format('open file "%s"',[img_OpenPictureDialog.FileName]));
img_log.Lines.Add(format('image width="%d" height="%d"',[img_src.Picture.Width,img_src.Picture.Height]));
end;
end;
//по высоте картинку - источник
procedure Tfrm_img.act_srcProportionalImgExecute(Sender: TObject);
begin
with (sender as taction) do begin
img_src.Proportional:=Checked;
end;
end;
//по высоте картинку - результат
procedure Tfrm_img.act_desProportionalImgExecute(Sender: TObject);
begin
with (sender as taction) do begin
img_des.Proportional:=Checked;
end;
end;
//копировать - цветовое копирование картинки с умножением на выбранный цвет
procedure Tfrm_img.act_srcCopyExecute(Sender: TObject);
const
xcount=16;
var
mx,nx,ny,nw,nh:word;
citm:^TPxlC;
axmm:TSSERegLines;
xmm_0:TXMMArrByte;
nn,xn:byte;
np1,np2,np3:byte;
ncolor:tcolor;
xc:array[0..3] of byte;
timebefore:Cardinal;
begin
if (frm_optsimgcopy.ShowModal=mrYes) then begin
timebefore:=MilliSecondOfTheHour(Now);
if (img_src.Picture.Width > MAX_imageSize) or (img_src.Picture.Height > MAX_imageSize) then begin
MessageDlg(img_errmsg[0].Text,mtError,[mbok],0);
end else begin
nw:=img_src.Picture.Width;//n size
nh:=img_src.Picture.Height;
img_des.Picture.Bitmap.Width:=nw;//set n size
img_des.Picture.Bitmap.Height:=nh;
img_pbar.Max:=nh+1;//set progressbar
ncolor:=frm_optsimgcopy.Shape1.Brush.Color;
np1:=frm_optsimgcopy.ComboBox1.ItemIndex;
np2:=frm_optsimgcopy.ComboBox2.ItemIndex;
np3:=frm_optsimgcopy.ComboBox3.ItemIndex;
for xn:=0 to 4 do begin
xmm_0[xn*3+0]:=GetBValue(ncolor);//blue
xmm_0[xn*3+1]:=GetGValue(ncolor);//green
xmm_0[xn*3+2]:=GetRValue(ncolor);//red
end;
asm
push eax
push ebx
push ecx
push edx
movups xmm1,xmm_0
end;
for ny:=0 to (nh-1) do begin
citm:=img_src.Picture.Bitmap.ScanLine[ny];
nx:=0;
while (nx<=nw) do begin
FillChar(xmm_0,16,0);//clear
for nn:=0 to 4 do begin
if ((nx+nn)<=nw) then begin
xmm_0[nn*3+0]:=citm.b;
xmm_0[nn*3+1]:=citm.g;
xmm_0[nn*3+2]:=citm.r;
end else break;//if
inc(citm);
end;//for
asm//write,make,read
movups xmm0,xmm_0
andps xmm0,xmm1//multiply color's
movups xmm_0,xmm0
end;//asm
for nn:=0 to 4 do begin
if (nx<=nw) then
img_des.Canvas.Pixels[nx,ny]:=rgb(xmm_0[nn*3+np3],xmm_0[nn*3+np2],xmm_0[nn*3+np1])
else break;
inc(nx);
end;//for
end;//while...
img_pbar.StepBy(1);
end;//for...
asm
pop edx
pop ecx
pop ebx
pop eax
end;
end;//if...
img_pbar.Max:=0;
timebefore:=MilliSecondOfTheHour(Now)-timebefore;
Label1.Caption:=format('%d %s',[timebefore,delay_names]);
img_log.Lines.Add(format('make action="copy image" at="%d" milliseconds',[timebefore]));
end;
end;
//инициализация операций
procedure Tfrm_img.FormCreate(Sender: TObject);
begin
img_errmsg[0]:=tstringlist.create;//error msg
img_errmsg[0].Add('Изображение слишком большое.');//err maxsize image
img_errmsg[0].Add(format('Максимальный размер не должен превышать %d.',[MAX_imageSize]));
img_errmsg[0].Add('Попробуйте выбрать другое.');
img_tabs.ActivePage:=img_tab1;//page