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

Страница 4

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;

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

if g>4000 then break;

if keypressed then key:=true ;

if (g>4000) or (g<=0) or (m<=0) or (m>1000) then

key:=true;

setcolor(white);

bar(0,0,640,17);

moveto(0,0);

outtext('Травоядные Хищники Съедено

Трава Год');

setcolor(ct);moveto(0,10);str(g,s);outtext(s);

setcolor(ch);moveto(175,10);str(m,s);outtext(s);

setcolor(red);moveto(300,10);str(tt,s);outtext(s);

setcolor(green);moveto(400,10);str((tree),s);outtext(s);

setcolor(magenta);moveto(510,10);str((z div 365),s);

outtext(mes(z));outtext(' ');outtext(s);outtext(' года');

if (z mod 365)=0 then tt:=0;

until key=true;

closegraph;

end;

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

procedure komenu;

var key:char;

begin

repeat

key:=readkey;

if (key='h') or (key='H') then

begin

herb;

window(40,10,80,25);

fon(black);

clrscr;

info;

omenu;

end;

if (key='B') or (key='b') then

begin

beast;

window(40,10,80,25);

fon(black);

clrscr;

info;

omenu;

end;

if (key='E') or (key='e') then

begin

env;

window(40,10,80,25);

fon(black);

-23-

clrscr;

info;

omenu;

end;

until key=#27;

quit;

CLRSCR;

end;

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

PROCEDURE GKMENU;

var key2:char;

key1:boolean;

begin

gmenu;

info;

repeat

key2:=readkey;

if (key2='s') or (key2='S') then

begin

if(g>0)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;

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<=30) then col:='Январь';

if (x>=31)and(x<=58) then col:='Февраль';

if (x>=59)and(x<=89) then col:='Март';

if (x>=90)and(x<=119) then col:='Апрель';

if (x>=120)and(x<=150) then col:='Май';

if (x>=151)and(x<=180) then col:='Июнь';

if (x>=181)and(x<=211) then col:='Июль';

if (x>=212)and(x<=241) then col:='Август';

if (x>=242)and(x<=272) then col:='Сентябрь';

if (x>=273)and(x<=303) then col:='Октябрь';

if (x>=304)and(x<=335) then col:='Ноябрь';

if (x>=336)and(x<=365) then col:='Декабрь';

mes:=col;

end;

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

FUNCTION COLWORD;

VAR COLO:STRING;

BEGIN

IF COL=0 THEN COLO:='ЧЕРНЫЙ';

IF COL=1 THEN COLO:='СИНИЙ';

IF COL=2 THEN COLO:='ЗЕЛЕНЫЙ';

IF COL=3 THEN COLO:='ГОЛУБОЙ';

IF COL=4 THEN COLO:='КРАСНЫЙ';

IF COL=5 THEN COLO:='ФИОЛЕТОВЫЙ';

IF COL=6 THEN COLO:='КОРИЧНЕВЫЙ';

IF COL=7 THEN COLO:='СВЕТЛО-СЕРЫЙ';

IF COL=8 THEN COLO:='ТЕМНО-СЕРЫЙ';

IF COL=9 THEN COLO:='СВЕТЛО-СИНИЙ';

IF COL=10 THEN COLO:='СВЕТЛО-ЗЕЛЕНЫЙ';

IF COL=11 THEN COLO:='СВЕТЛО-ГОЛУБОЙ';

IF COL=12 THEN COLO:='СВЕТЛО-КРАСНЫЙ';

IF COL=13 THEN COLO:='СВЕТЛО-ФИОЛЕТОВЫЙ';

IF COL=14 THEN COLO:='ЖЕЛТЫЙ';

-27-

IF COL=15 THEN COLO:='БЕЛЫЙ';

COLWORD:=COLO;

END;

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

procedure fon;

begin

textbackground(x);

end;

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

procedure txt;

begin

textcolor(col);

end;

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

procedure ramka; {вывести рамку}

const

a=#186;b=#187;c=#188;d=#200;e=#201;f=#205;

{T}

var i,j:integer;

begin

hiddencursor;

gotoxy(x1,y1);

write(e);

for i:=(x1+1) to (x2-1) do write(f);

write(b);

for i:=(y1+1) to (y2-1) do

begin

gotoxy(x1,i);

write(a);

gotoxy(x2,i);

write(a);

end;

gotoxy(x1,y2);

write(d);

for i:=(x1+1) to (x2-1) do write(f);

write(c);

hiddencursor;

end;

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

procedure colorwind; {сделать окно с рамкой}

begin

window(v1,v2,v3,v4);