|
||
Дело было вечером, делать было нечего... | ||
program otbor; { тест }
{$APPTYPE CONSOLE} { Эта строка для Delphi-2005 }
{ Трансляция под Дельфи: dcc32 otbor.pas }
{ Uses crt; } { Эта строка для Турбо-паскаля }
{ Трансляция в среде Турбо-паскаля: ctrl/F9 }
{ Влияние естественного отбора на смертность рожениц
Средняя смертность при первых родах - 25%. Разброс - +-10% (15 - 35%)
Распределение линейное, равномерное. Разброс в детях - +-2% }
type int=integer; bool=boolean; long=longint;
const tr=true; fl=false;
var cn: int; { чет-нечет }
pop: long; { популяция }
Rn: int;
date: int; { текущий год }
kvo: array[0..1010] of long;
unt,old: array[0..4000000] of int; {unt -сам. supr - ссылка на супруга }
supr: array[0..4000000] of long;
Risk: array[0..4000000] of real; { Риск помереть первыми родами }
{ Статистика }
us, ur, upr, uc, rod: long;
{ от старости, родами, первыми родами, сами сдохли, родилось }
ft: text;
{ unt - это
0 - пусто
1 - мальчик
2 - жениться пора (16)
3 - женатый
4 - старик ( >55 )
10 - девочка
11 - замужняя
12 - замуж пора (15)
13 - вдова
14 - вдова
15 - старуха ( > 50 )
}
function chet: int; { чет-нечет }
begin cn:=cn+1; if cn>1 then cn:=0; chet:=cn;
end; {end chet}
procedure setshag;
var i: long; r,dsh: real;
begin
kvo[0]:=pop; r:=kvo[0]; dsh:=1.0034717488;
for i:=1 to 1001 do begin
r:=r*dsh; kvo[i]:=trunc(r);
if i=1 then writeln(i:5,' =',kvo[i]:10);
if i=200 then writeln(i:5,' =',kvo[i]:10);
if i=400 then writeln(i:5,' =',kvo[i]:10);
if i=600 then writeln(i:5,' =',kvo[i]:10);
if i=800 then writeln(i:5,' =',kvo[i]:10);
if i=1000 then writeln(i:5,' =',kvo[i]:10);
end;
end;
{end setshag}
procedure anketa(n:long); { заполняем личное дело }
var v,pol: int;
begin
v:=9+random(37); old[n]:=v;
pol:=chet;
if pol=0 then begin { парень }
pol:=2; if v<16 then pol:=1; if pol>55 then pol:=4; Risk[n]:=rn;
unt[n]:=pol; end else begin { девка }
Risk[n]:=rn; rn:=rn+1; if rn>35 then rn:=15;
pol:=12; if v<15 then pol:=10; if v>50 then pol:=15;
unt[n]:=pol; end;
end;
{end anketa}
procedure NU; { Начальные установки }
var i: long;
begin
cn:=0; date:=0; pop:=100000;
rn:=25; randomize;
us:=0; ur:=0; upr:=0; uc:=0; rod:=0;
setshag;
for i:=0 to 4000000 do begin { начальная зачистка }
unt[i]:=0; supr[i]:=0; old[i]:=0; Risk[i]:=0; end;
for i:=1 to pop do begin { Создаем начальную популяцию }
anketa(i); end;
assign(ft,'e-otbor-10.txt'); rewrite(ft); writeln(ft);
end;
{end NU}
procedure calcRez; { Считает ЦИФРУ }
var i,n,m:long; nr,nv: real;
begin
n:=0; nr:=0; nv:=0; for i:=1 to pop do begin
m:=unt[i]; if m>0 then begin { Живого нашел }
n:=n+1; nr:=nr+Risk[i]; nv:=nv+old[i]; end; end;
nr:=nr/n; nv:=nv/n;
writeln('Год',date:5,' Всего =',pop:8,' Риск =',nr:8:4,
' Ср.возр =',nv:8:4);
writeln('Род ',rod:6,' ум.р ',ur:6,' ум.п.р ',upr:6,' стар.',us:6,
' н.с. ',uc:6);
end;
{end calcRez}
procedure toFile; { пишет в файл текущую инфу }
var i,n,m:long; nr,nv: real;
begin
n:=0; nr:=0; nv:=0; for i:=1 to pop do begin
m:=unt[i]; if m>0 then begin { Живого нашел }
n:=n+1; nr:=nr+Risk[i]; nv:=nv+old[i]; end; end;
nr:=nr/n; nv:=nv/n;
writeln(ft,'Год',date:5,' Всего =',pop:8,' Риск =',nr:8:4,
' Ср.возр. =',nv:8:4);
writeln(ft,'Род ',rod:6,' ум.р ',ur:6,' ум.п.р ',upr:6,' стар.',us:6,
' н.с. ',uc:6);
writeln(ft);
end;
{end toFile}
procedure ss(m:long); { Умер супруг(а). Изменение соц. статуса }
var n,v: int;
begin
n:=unt[m]; v:=old[m]; supr[m]:=0; if n=0 then exit;
if n<10 then begin { Мужик }
n:=2; if v>55 then n:=4; end else begin { баба }
n:=14; if v>50 then n:=15; end;
unt[m]:=n; end;
{end ss}
procedure ubil(m:long); { Убил насмерть хорошего человека... }
begin
unt[m]:=0; old[m]:=0; supr[m]:=0; Risk[m]:=0; end;
{end ubil}
procedure zakopal(m:long); { Уборка одного трупика }
label 3;
var sup: long;
begin
3: if unt[pop]=0 then begin pop:=-1; if pop<2 then exit;
if unt[pop]=0 then goto 3; end;
unt[m]:=unt[pop]; old[m]:=old[pop]; Risk[m]:=Risk[pop];
sup:=supr[pop]; supr[m]:=sup; if sup>0 then supr[sup]:=m;
ubil(pop); pop:=pop-1;
end;
{end zakopal}
procedure vt; { Вывоз трупиков }
label 3;
var i: long;
begin
3: if unt[pop]=0 then begin pop:=-1; if pop<2 then exit;
if unt[pop]=0 then goto 3; end;
for i:=pop-1 downto 1 do begin { вывожу трупики }
if unt[i]=0 then zakopal(i); end;
end;
{end vt}
function born(m:long):bool; { Pожаем }
var spr: long; v,sm,pr,rp: int; rr: real;
begin
born:=tr; spr:=supr[m];
if spr=0 then exit; { Без мужа не рожаем, в подоле не приносим! }
v:=old[m]; rr:=Risk[m]; { Определяем риски смерти }
if v=21 then rr:=rr*0.7;
if v=25 then rr:=rr*0.5;
if v=29 then rr:=rr*0.7;
sm:=random(100); if sm>rr then begin { Родила! }
if chet=0 then pr:=1 else pr:=10; { Мальчик/девочка }
if (pop mod 2)=0 then rr:=Risk[spr] else rr:=Risk[m]; { В папу/в маму}
rp:=(pop mod 5)-2; rr:=rr+rp; if rr<0 then rr:=0;
if rr>99 then rr:=99; { добавил мутации }
{ Регистрирую младенца }
pop:=pop+1; unt[pop]:=pr; old[pop]:=0; supr[pop]:=0; Risk[pop]:=rr;
rod:=rod+1; exit; end;
{ Теперь - померла родами. Хороню }
born:=fl; ur:=ur+1; if v=17 then upr:=upr+1; ss(spr); ubil(m);
end;
{end born}
procedure brak(m:long); { Хорошее дело браком не назовут! }
label 3,9;
var na,cnt: long; n,nn,v,ng,vg: int;
begin
n:=unt[m]; v:=old[m]; ng:=v; vg:=v; nn:=2;
{ Определяю параметры суженого }
if n=2 then begin ng:=v-20; if ng<13 then ng:=13; vg:=v+5; nn:=12; end;
if n=12 then begin ng:= v-5; vg:=v+20; nn:=2 end;
na:=random(pop-2)+1; cnt:=pop div 2;
{ Ищу суженого }
3: if unt[na]<>nn then goto 9;
if old[na]vg then goto 9;
{ Нашелся единственный и неповторимый! Заключаем брак }
if n=2 then begin unt[m]:=3; unt[na]:=11; end;
if n=12 then begin unt[m]:=11; unt[na]:=3; end;
supr[m]:=na; supr[na]:=m; exit; { совет да любовь }
9: na:=na+1; if na>pop then na:=1;
cnt:=cnt-1; if cnt>0 then goto 3;
{ Облом... } end;
{end brak}
procedure year; { просчитывает год жизни популяции }
label 8,9;
var i,sup,kvota,trp: long; n,v: int; kpt:bool;
begin date:=date+1;
us:=0; ur:=0; upr:=0; uc:=0; rod:=0;
for i:=pop downto 1 do begin
kpt:=tr; n:=unt[i]; if n>0 then begin
v:=old[i]+1; old[i]:=v;
if v>70 then begin { умер от старости }
us:=us+1; sup:=supr[i]; if sup>0 then ss(sup); ubil(i); goto 8; end;
if n<10 then begin { Мужик }
if v=16 then n:=2; { Жениться пора }
goto 9; end;
{ баба }
if v=15 then begin n:=12; goto 9; end; { замуж пора }
if n=13 then begin n:=12; goto 9; end; { вдове замуж пора }
if n=14 then begin n:=13; goto 9; end; { вдовствует }
if v=17 then begin kpt:=born(i); goto 9; end; { рожают }
if v=21 then begin kpt:=born(i); goto 9; end;
if v=25 then begin kpt:=born(i); goto 9; end;
if v=29 then begin kpt:=born(i); goto 9; end;
if v=33 then kpt:=born(i);
9: if kpt then begin unt[i]:=n; end;
8: end; end;
vt; { трупики вывез. Теперь - отстрел лишних }
if pop>kvo[date] then begin
kvota:=pop-kvo[date]; for i:=1 to kvota do begin { отстреливаю }
trp:=random(pop-2)+1; if unt[trp]>0 then uc:=uc+1;
sup:=supr[trp]; if sup>0 then ss(sup); ubil(trp); end; end;
vt; { вывез трупики. Теперь - свадьбы }
for i:=1 to pop do begin { ищу холостяков }
n:=unt[i]; if (n=2)or(n=12) then begin
brak(i); end; end; { ищу пару и женю }
{ Смерть стариков, роды, уборка трупов, расстрел лишних, уборка трупов, браки }
toFile;
end;
{end year}
procedure live;
var i: int;
begin
writeln; NU; calcRez; writeln;
for i:=1 to 1001 do begin
year;
if date=50 then calcRez;
if date=100 then calcRez;
if date=200 then calcRez;
if date=300 then calcRez;
if date=400 then calcRez;
if date=500 then calcRez;
if date=600 then calcRez;
if date=700 then calcRez;
if date=800 then calcRez;
if date=900 then calcRez;
if date=1000 then calcRez; end;
calcRez;
end;
{end live}
{ - - - - Собственно, основная часть программы - - - - }
begin
{ live; }
NU; calcRez; writeln;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
year; calcRez;
writeln; writeln(ft); close(ft);
live;
writeln; writeln(ft); close(ft);
end.
|