Программа эмуляции развития популяций животных

end;

{***********************************************************}

procedure start;

begin

randomize;

gD := Detect;

InitGraph(gD,gM,'');

setfillpattern(pal,black);

z:=0;{начало эры}

tt:=0; {трупы и съеденные}

ini;

repeat

key:=false;

z:=z+1;

if ((z mod 365)=0) or ((z mod 365)=31) or ((z mod 365)=59)

or ((z mod 365)=90) or ((z mod 365)=120) or ((z mod

365)=151) or ((z mod 365)=181) or ((z mod 365)=212) or

((z mod 365)=242) or ((z mod 365)=273) or ((z mod

365)=303) or ((z mod 365)=334) then

begin

tree:=round(tree-g*ttt);{съели за месяц}

tree:=tree+round(tree*(tr/100));{прирост травы в месяц}

x:=round(tree*ttt);{травоядные умирают от недоедания}

if tree0 then

begin

dead;{хищники едят травоядных}

hnew;{естественная смертность хищников}

havka;{хищники умирают от недоедания}

hrod;{рождение хищников}

end;

if ((z mod 365)=180)and(g>0)and(m>0) then

begin

if random(kata)0 then

begin

x:=random(4);

if x=0 then

begin

x:=random(round(g/50))+5;

moveto(320,240);setcolor(Lightred);str(x,s);

Outtext('Болезнь травоядных унесла ');

Outtext(s);Outtext(' жизней ');

tmor;

end;

if x=1 then

begin

x:=random(round(m/40))+1;

moveto(320,240);setcolor(Lightred);str(x,s);

Outtext('Болезнь хищников унесла ');

Outtext(s);Outtext(' жизней');

hmor;

end;

if x=2 then

begin

zasux;

moveto(320,240);setcolor(Lightred);

str(tree1,s);Outtext('Засуха! Потеряно ');

Outtext(s);Outtext(' тонн травы');

delay(q);

end;

if x=3 then

begin

x:=random(round(g/50))+5;

moveto(0,240);setcolor(Lightred);str(x,s);

Outtext('Наводнение погубило ');Outtext(s);Outtext('

травоядных, ');

tmor;

x:=random(round(m/40))+1;

str(x,s);Outtext(s);Outtext(' хищников, ');

hmor;

zasux;

str(tree1,s);Outtext(s);Outtext(' тонн травы');

-22-

delay(q);

end;

delay(q);

bar(0,240,640,260);

end;

end;

if g>0 then trod;{рождение травоядных}

if g>4000 then break;

if keypressed then key:=true ;

if (g>4000) or (g0)and(m>0)and(ttt>0)and(tp>0)and(tmin>0)and(tmax>0)

and(ct>0)and(ht>0)and(hp>0)and(hmin>0)and(hmax>0)and

(Ch>0)and(tree>0)and (tr>0)and(kata>0)then

begin

start; gmenu; info;

key1:=false;

end;

end;

if (key2='o')or(key2='O') then

begin

Omenu; komenu;

GMENU;

info; key1:=false;

end;

if (key2='q') or (key2='Q')or(key2=#27) then

begin

key1:=true; quit;

end;

until key1=true;

end;

{***********************************************************}

{Body program}

begin

g:=1200;{травоядные кол-во}

v:=30;{возраст травоядного}

m:=200;{хищники кол-во}

w:=25;{возраст хищника}

ct:=yellow;ch:=red;

tmin:=2;tmax:=28;

hmin:=3;hmax:=24;

tp:=3;hp:=7;{детородность}

kata:=9; ht:=3; ttt:=1; tree:=1300; tr:=15.1;

hiddencursor;

GKMENU;

end.

-24-

ПРИЛОЖЕНИЕ 2.

БИБЛИОТЕКА FAUNA1

{Init object}

unit fauna1;

interface

uses graph;

Type TPosition=object

x,y : integer;

procedure Init(x0,y0 : integer);

function getx : integer;

function gety : integer;

end;

type Tosob=object(TPosition)

color : word;

vidno : boolean;

AGE : INTEGER;

constructor Init(x0,y0,age0:integer;col:word);

destructor Done ; virtual ;

procedure Show ; virtual ;

procedure Blind ; virtual ;

function Daizwet : word;

function VidnoLi : boolean;

FUNCTION DAIAGE : INTEGER;

end;

Posob=^Tosob;

{metod Tposition}

Implementation

Procedure Tposition.Init(x0,y0:integer);

Begin

x:=x0;

y:=y0;

End;

Function Tposition.Getx:integer;

Begin GetX:=x End;

Function Tposition.Gety:integer;

Begin Gety:=y End;

Constructor Tosob.Init(x0,y0,age0:integer;col:word);

Begin

Tposition.Init(x0,y0);

AGE:=AGE0;

color:=col;

vidno:=false;

End;

Destructor Tosob.Done;

Begin

Tosob.blind;

End;

procedure Tosob.Show;

Begin

putpixel(TPosition.GetX, TPosition.GetY,color);

vidno:=True;

End;

procedure Tosob.Blind;

-25-

Begin

putpixel(TPosition.GetX, TPosition.GetY,GetBKColor);

vidno:=False;

End;

Function Tosob.Daizwet : word;

Begin Daizwet:=color End;

Function Tosob.VidnoLi : Boolean;

Begin VidnoLi:=Vidno End;

FUNCTION TOSOB.DAIAGE:INTEGER;

BEGIN DAIAGE:=AGE END;

End.

-26-

ПРИЛОЖЕНИЕ 3.

БИБЛИОТЕКА MYCRT

unit Mycrt;

interface

uses tpcrt,dos;

procedure fon(x:byte);

procedure txt(col:byte);

procedure ramka(x1,y1,x2,y2:integer);

procedure colorwind(v1,v2,v3,v4,fon,text:byte);

FUNCTION COLWORD(COL:BYTE):STRING;

function mes(z:longint):string;

implementation

{***********************************************************}

function mes;

var col:string;

x:integer;

begin

x:=z mod 365;

if (x>=0)and(x=31)and(x=59)and(x=90)and(x=120)and(x=151)and(x=181)and(x=212)and(x=242)and(x=273)and(x=304)and(x=336)and(x