Главная страница
    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.45 MB
Время: 0.041 c
9-1086760482
*John*1987*
2004-06-09 09:54
2004.10.03
Delphix для Delphi6


3-1093730614
Денисыч
2004-08-29 02:03
2004.10.03
Защита приложения баз данных


1-1095679598
Krot
2004-09-20 15:26
2004.10.03
Вопрос по реестру в WinXP(проблемы с удалением параметра)


14-1094824005
chver
2004-09-10 17:46
2004.10.03
Работа


14-1095145729
}|{yk
2004-09-14 11:08
2004.10.03
Копали ли вы в этом году картошку?





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
Английский Французский Немецкий Итальянский Португальский Русский Испанский