Program generuje hviezdnú oblohu

Kategória: KMP (Klub mladých programátorov)

Program: Hvezdy.pas
Súbor exe: Hvezdy.exe

{ hvezdy.pas                Copyright (c) TrSek alias Zdeno Sekerak  }
{ Program generuje hviezdnu oblohu.                                  }
{                                                                    }
{ Datum:20.04.1996                              http://www.trsek.com }
 
uses crt,graph;
const pocethvezd=50;
      zobrplocha=50;
      viditelnost=1000;
      delta=30;
 
type souradnice=record x,y,z:word; end;
     hvezdokupa=array[0..pocethvezd]of souradnice;
 
var h:^hvezdokupa;
    x,y,z:word;
    xp,yp:integer;
    gd,gm,i:integer;
 
procedure perspektiva(xp,yp,zp:integer;var x,y:integer);
var pomer: integer;
begin
  dec(xp,getmaxx div 2);dec(yp,getmaxy div 2);
  x:=xp*zobrplocha div zp;
  y:=yp*zobrplocha div zp;
  inc(x,getmaxx div 2);inc(y,getmaxy div 2);
end;
 
procedure naplnhvezdu(cislo:word);
begin
  h^[cislo].x:=random($FFFF);
  h^[cislo].y:=random($FFFF);
  h^[cislo].z:=random(1000);
end;
 
procedure napln;
begin
  randomize;
  for i:=0 to pocethvezd do naplnhvezdu(i);
end;
 
procedure zmiz(s:souradnice);
begin
  setcolor(black);
  if s.z <> 0 then begin
    perspektiva(s.x*1000,s.y*1000,s.z+delta,xp,yp);
    setfillstyle(solidfill,black);
    fillellipse(xp,yp,viditelnost div (2*s.z),viditelnost div (2*s.z));
  end;
end;
 
procedure kresli(s:souradnice);
begin
  zmiz(s);
  setfillstyle(solidfill,white);
  if s.z <> 0 then begin
    perspektiva(s.x*1000,s.y*1000,s.z,xp,yp);
    fillellipse(xp,yp,viditelnost div (2*s.z),viditelnost div (2*s.z));
  end;
end;
 
procedure zobrazhvezdy;
begin
  for i:=0 to pocethvezd do begin
    dec(h^[i].z,delta);
    if h^[i].z <= zobrplocha then zmiz(h^[i]);
    if h^[i].z <= zobrplocha then naplnhvezdu(i);
    if (h^[i].z < viditelnost) and (h^[i].z > zobrplocha) then kresli(h^[i]);
  end;
end;
 
procedure EGAVGA_dr; external;
{$L EGAVGA.OBJ }
 
begin
  if RegisterBGIdriver(@egavga_dr) >= 0 then begin
    new(h);
    gd:=detect;
    initgraph(gd,gm,'');
    napln;
    repeat
      zobrazhvezdy;
    until keypressed;
    closegraph;
    dispose(h);
  end else writeln('Nelze inicializovat graficky rezim !');
end.