Форум: "Потрепаться";
Текущий архив: 2004.10.03;
Скачать: [xml.tar.bz2];
ВнизПомогите оптимизировать процедуру Найти похожие ветки
← →
Шишкин Илья © (2004-09-10 20:45) [0]Часть одного проекта является случайная генерация ландшафтов. Написал две процедуры. Одна просто затемняет TBitMap, а другая создаёт более менее красивый эффект рельефа. Беда в том, что обе процедуры работают очень медленно. Буду очень благодарен, если кто-нибудь поможет...
if s.globalfade<>0 then
begin
for i:=0 to Bmp.Height-1 do for j:=0 to BMP.Width-1 do
begin
if BMP.Canvas.Pixels[i,j]<>S.NColor then
begin
BT:=TBT(BMP.Canvas.Pixels[i,j]);
R:=BT.R;
G:=BT.G;
B:=BT.B;
R:=R-S.GlobalFade;
G:=G-S.GlobalFade;
B:=B-S.GlobalFade;
if R<0 then R:=0;
if G<0 then G:=0;
if B<0 then B:=0;
if R>255 then R:=255;
if G>255 then G:=255;
if B>255 then B:=255;
BT.R:=R;
BT.G:=G;
BT.B:=B;
BMP.Canvas.Pixels[i,j]:=TColor(BT);
end;
end;
end;
Использую свой тип, чтобы выделять RGB в TColor. Немного кривовато, но другого способа не знаю...
type
TBT=record
R,G,B,Temp:byte;
end;
А вот вторая процедура:
function Fade(Color:TColor; Value:integer):TColor;
type
TBT=record
R,G,B,Temp:byte;
end;
var
BT:TBT;
R,G,B:integer;
begin
BT:=TBT(Color);
R:=BT.R;
G:=BT.G;
B:=BT.B;
R:=R-Value;
G:=G-Value;
B:=B-Value;
if R<0 then R:=0;
if G<0 then G:=0;
if B<0 then B:=0;
if R>255 then R:=255;
if G>255 then G:=255;
if B>255 then B:=255;
BT.R:=R;
BT.G:=G;
BT.B:=B;
Result:=TColor(BT);
end;
procedure Fader(var BMP:TBitmap; Max,Step:integer; NColor:TColor);
type
TField=array of array of byte;
var
Field:TField;
i,j:integer;
Pitch:integer;
function GetFade(f:TField;x,y:integer):integer;
var
i,j,c,s:integer;
begin
if (x<1) or (x>Length(F)-2) then exit;
if (y<1) or (y>Length(F[0])-2) then exit;
c:=0;
s:=0;
for i:=x-1 to x+1 do for j:=y-1 to y+1 do
begin
if not ((x=0) and (y=0)) then if Field[i,j]<>255 then
begin
c:=c+1;
s:=s+Field[i,j];
end;
end;
Result:=Round(s/c);
end;
begin
SetLength(Field,BMP.Width);
for i:=0 to Bmp.Width-1 do SetLength(Field[i],BMP.Height);
for i:=0 to BMP.Width-1 do for j:=0 to BMP.Height-1 do Field[i,j]:=255;
for i:=0 to Length(Field)-1 do
begin
for j:=0 to Length(Field[i])-1 do
begin
if BMP.Canvas.Pixels[i,j]=NColor then Continue;
if (i<>0) and (j<>0) then Pitch:=GetFade(Field,i,j) else Pitch:=Max div 2;
Pitch:=Pitch+Random(Step*2+1)-Step;
if Pitch<0 then Pitch:=0;
if Pitch>Max then Pitch:=Max;
BMP.Canvas.Pixels[i,j]:=Fade(BMP.Canvas.Pixels[i,j],Pitch);
Field[i,j]:=Pitch;
end;
end;
end;
Использовать так:
procedure TForm1.Button1Click(Sender: TObject);
var
BMP:TBitMap;
begin
Randomize;
BMP:=TBitMap.Create;
BMP.Width:=300;
BMP.Height:=300;
Fader(BMP,80,3,clBlack);
Image1.Picture.Bitmap:=BMP;
BMP.Free;
end;
← →
Rouse_ © (2004-09-10 20:47) [1]Работа с Pixel тормозит.
Используй scanline
а лучше чтолибо наподобие FastDIB
Страницы: 1 вся ветка
Форум: "Потрепаться";
Текущий архив: 2004.10.03;
Скачать: [xml.tar.bz2];
Память: 0.46 MB
Время: 0.027 c