Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Потрепаться";
Текущий архив: 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
4-1093237731
Станислав
2004-08-23 09:08
2004.10.03
sendkeys


14-1095146447
KSergey
2004-09-14 11:20
2004.10.03
Win2k и autoexec.bat


1-1095691197
Goga
2004-09-20 18:39
2004.10.03
Управление объектом


1-1095454076
Heet
2004-09-18 00:47
2004.10.03
Как загрузить рисунок в FastReport во время выполнения?


1-1095106051
HydraMarat
2004-09-14 00:07
2004.10.03
Int64 vs Integer





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский