Simuluje život rastlín na políčku, ich rozmnožovanie a zánik

{ ZIVOT.PAS                             Copyright (c) Ludovit Mydla }
{ Simuluje zivot rastlin na policku                                 }
{ Vstup : rozmiestnenie rastlin                                     }
{ Vystup: semigraficke znazornenie rastlin                          }
{ Priklad: 4 rastlinky a suradnice [1,2], [1,3], [2,2], [2,3]       }
{                                                                   }
{ Datum:10.04.2003                             http://www.trsek.com }
 
program zivot;
uses crt;
var sus,kvet:array[1..10,1..10] of integer;
    ras,poc:integer;
    k:char;
 
 
{ zisti suseda rastlinke }
procedure ZistiSuseda;
var i,j:integer;
begin
 for i:= 1 to 10 do begin
  for j:= 1 to 10 do begin
   sus[i,j]:=0;
   if ((i<10) and (j<10) and (kvet[i+1,j+1]=2)) then inc( sus[i,j]);
   if ((i<10) and            (kvet[i+1,j  ]=2)) then inc( sus[i,j]);
   if ((i<10) and (j> 1) and (kvet[i+1,j-1]=2)) then inc( sus[i,j]);
   if ((j<10) and            (kvet[i  ,j+1]=2)) then inc( sus[i,j]);
   if ((i> 1) and (j<10) and (kvet[i-1,j+1]=2)) then inc( sus[i,j]);
   if ((j> 1) and            (kvet[i  ,j-1]=2)) then inc( sus[i,j]);
   if ((i> 1) and (j> 1) and (kvet[i-1,j-1]=2)) then inc( sus[i,j]);
   if ((i> 1) and            (kvet[i-1,j  ]=2)) then inc( sus[i,j]);
  end;
 end;
end;
 
 
{ priebeh mnozenia }
procedure Mnozenie(i,j:integer);
begin
 if ((i<10) and (j<10) and (kvet[i+1,j+1]=0)) then kvet[i+1,j+1]:=1;
 if ((i<10) and            (kvet[i+1,j  ]=0)) then kvet[i+1,j  ]:=1;
 if ((i<10) and (j> 1) and (kvet[i+1,j-1]=0)) then kvet[i+1,j-1]:=1;
 if ((j<10) and            (kvet[i  ,j+1]=0)) then kvet[i  ,j+1]:=1;
 if ((j> 1) and            (kvet[i  ,j-1]=0)) then kvet[i  ,j-1]:=1;
 if ((i> 1) and (j>10) and (kvet[i-1,j+1]=0)) then kvet[i-1,j+1]:=1;
 if ((i> 1) and            (kvet[i-1,j  ]=0)) then kvet[i-1,j  ]:=1;
 if ((i> 1) and (j> 1) and (kvet[i-1,j-1]=0)) then kvet[i-1,j-1]:=1;
end;
 
 
procedure ZistiDalej;
var i,j:integer;
begin
 for i:= 1 to 10 do begin
  for j:= 1 to 10 do begin
   if (sus[i,j]<=2) and (kvet[i,j]=2) then kvet[i,j]:=0;
   if (sus[i,j]>=5) and (kvet[i,j]=2) then kvet[i,j]:=0;
   if (sus[i,j]>2) and (sus[i,j]<5) and (kvet[i,j]=2) then mnozenie(i,j);
  end;
 end;
end;
 
 
procedure VynulujMlade;
var i,j:integer;
begin
 for i:= 1 to 10 do
  for j:= 1 to 10 do
   if kvet[i,j]=1 then kvet[i,j]:=2;
end;
 
 
{ semigraficke zobrazenie stavu rastliniek }
procedure Vykresli;
var i,j:integer;
begin
 clrscr;
 for i:=1 to 10 do begin
  for j:=1 to 10 do begin
   if kvet[i,j]=0 then
   begin
     textcolor(darkgray);
     gotoxy(i*4,j*2);Write('');
   end;
 
   if kvet[i,j]=2 then
   begin
     textcolor(green);
     gotoxy(i*4,j*2);Write('');
   end;
  end;
 end;
end;
 
 
{ precita z klavesnice kde su zasadene rastlinky }
procedure Nacitaj;
var x,y:integer;
begin
 for poc:=1 to ras do
 begin
  clrscr;
  Writeln('Zadajte polohu ',poc,'. rastliny (v tvare x,y)');
  Readln(x,y);
  kvet[x,y]:=2;
 end;
end;
 
 
{ hlavny program }
begin
 clrscr;textcolor(white);
 Writeln('Zadajte pocet rastlin (maximalne 10)');
 Readln(ras);
 Nacitaj;
 
 poc:=1;
 Repeat
  Vykresli;
  textcolor(white);Gotoxy(56,24);Write(poc,'. rok (stlac ENTER)');
  poc:=poc+1;
 
  k:=Readkey;
  ZistiSuseda;
  ZistiDalej;
  VynulujMlade;
 Until k=#27;
 
end.