Версия для печати темы

program bio;
uses crt;
const
Size_of_Month: array [1..12] of byte = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
var
d0, d, dd1, dd2, { Den rozhdeniya, den tekushchiy. }
m0, m, dm1, dm2, { Depeche Mode..;) }
y0, y, dy1, dy2,
days, dmin, dmax: integer;
tstr: string[1];
Label L1;

procedure SplashScreen;
var
tmp: string[1];
begin
  textbackground (White);
  textColor (Red);
  ClrScr;
  gotoxy (20,1);
  Writeln('Vashemu vnimaniyu predstavlyayetsya programma, ');
  gotoxy (18,2);
  Writeln('kotoraya rasschityvayet bioritmy cheloveka' );
  gotoxy (20,3);
  Writeln('na zadannyy interval vremeni');
  gotoxy (40,12);
  writeln('Programmu sostavil student Volokhin Denis');
  gotoxy (40,13);
  writeln('');
  gotoxy (49,14);
  writeln('');
  gotoxy (40,15);
  writeln('');
  gotoxy (20,24);
  writeln('Nazhmite lyubuyu klavishu dlya prodolzheniya');
  read(tmp);
  ClrScr;
end;

procedure iDates(var d0, m0, y0, d, m, y, dd1, dm1, dy1, dd2, dm2, dy2: integer);
var
  isCorr: boolean;

procedure rDate(wel: string; var d, m, y: integer);
const
  ymin = 1800;
  ymax = 2200;
begin
repeat
  Write('Vvedite ' + wel + ' v formate DD MM GGGG: ');
  ReadLn(d, m, y);
  isCorr := (y >= ymin) and (Y <= ymax) and (m >= 1)
            and (m <= 12) and (d > 0);

if isCorr then
  if (m = 2) and (d = 29) and (y mod 4 = 0) then
   {foo bar, ibo etogo dnya ne sushchestvuyet..}
  else
   isCorr := d <= Size_of_Month[m];
   if not isCorr then WriteLn('Oshibka v date');
until isCorr;
end;

begin
repeat
rDate('datu rozhdeniya', d0, m0, y0);
rDate('tekushchuyu datu', d,m,y);
{test for corr. input}
isCorr := y > y0;
if not isCorr and (y = y0) then
  begin
   isCorr := m > m0;
   if not isCorr and (y = y0) then
    begin
     isCorr := m > m0;
     if not isCorr and (m = m0) then
      isCorr := d >= d0;
    end;
   end;
until isCorr;
rDate('nachalnuyu datu diapazona poiska', dd1, dm1, dy1);
rDate('konechnuyu datu diapazona poiska', dd2, dm2, dy2);
end;

procedure getDays (d0, m0, y0, d, m, y: integer; var days: integer);

Procedure mLoop;
var
mm: integer;
begin
mm := m0;
while mm < m do
begin
  days := days + Size_of_Month[mm];
  if (mm = 2) and (y0 mod 4 = 0) then inc(days);
  inc(mm);
end;
end;

procedure ymLoop;
var
mm, yy: integer;
begin
mm := m0 + 1;
while mm <= 12 do
  begin
   days := days + Size_of_Month[mm];
   if (mm = 2) and (y0 mod 4 = 0) then inc(days);
   inc(mm);
  end;
yy := y0 + 1;
while yy < y do
  begin
   days := days + 365;
   if yy mod 4 = 0 then inc(days);
   inc(yy);
  end;
mm := 1;
while mm < m do
  begin
   days := days + Size_of_Month[mm];
   if (y mod 4 = 0) and (mm = 2) then inc(days);
   inc(mm);
  end;
end;

begin
if (y = y0) and (m = m0) then

  days := d - d0
   else
    begin
     days := d + Size_of_Month[m0] - d0;
     if (y0 mod 4 = 0) and (m0 = 2) then inc(days);
     if y = y0 then mLoop else ymLoop;
    end;

end;

procedure parseGraph(d0, m0, y0, dmin, dmax: integer);
const
pPhisics   = 2*3.1416/23.6884;
pEmo       = 2*3.1416/28.4261;
pIntellect = 2*3.1416/33.1638;
var
dall, dcurr, i, j, gw: integer;
rP, rE, rI: real;
s: string;
begin
dall := dmax - dmin;
if dall < 0 then WriteLn('Oshibka: Nachalnaya tochka privyshayet konechnuyu.');
gw:=WindMax and $FF -12;
for i := 0 to dall do begin
  dcurr := dmin + i;
  rP := sin(dcurr * pPhisics);
  rE := sin(dcurr * pEmo);
  rI := sin(dcurr * pIntellect);
  s:='';
  for j:=1 to gw do s:=s+' ';
  s[Trunc((rP+1)/2*gw+1)]:='p';
  s[Trunc((rE+1)/2*gw+1)]:='e';
  s[Trunc((rI+1)/2*gw+1)]:='i';
  WriteLn(dd1:2,dm1:3,dy1:5,' :',s,':');
  Inc(dd1);
  if dd1>Size_of_Month[dm1] then begin
    dd1:=1;
    Inc(dm1);
    if dm1>12 then begin
      dm1:=1;
      Inc(dy1)
    end
  end;
end;
writeln ('            100    80    60    40    20    0    -20    -40    -60    -80    -100 ');
writeln ('p-fisicheskiy, e-emotsionalnyy, i-intellektualnyy ');
end;

BEGIN
{ main proc. }
  SplashScreen;
  iDates(d0, m0, y0, d, m, y, dd1, dm1, dy1, dd2, dm2, dy2);
  getDays(d0, m0, y0, d, m, y, days);
  getDays(d0, m0, y0, dd1, dm1, dy1, dmin);
  getDays(d0, m0, y0, dd2, dm2, dy2, dmax);
  parseGraph(d0, m0, y0, dmin, dmax);
  read(tstr);


END.