Форум: "Потрепаться";
Текущий архив: 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.45 MB
Время: 0.046 c