old/PAS/OLD/BIO.PAS

Uses CRT,Graph,DOS;

Procedure LITTFONT;external;
{$L litt.obj}

Procedure SANSFONT;external;
{$L sans.obj}

Procedure VGADRV;external;
{$L VGADRV.obj}

const

  path = '';
  Size_of_Month: array [1..12] of byte =
            (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
var
 Gd,Gm,y1,m1,d1,num,j:Integer;
 y2,m2,d2,dayofweek : Word;
 r1,r,s :longint;
 f,i,e : array [1..31] of real ;
{--------------------------------------}
Procedure Table(j:integer);
var
i:byte;
str1,str2,str3 : string[4];
str4 :string;
Begin
  MoveTo(10,100);
  SetTextStyle(SmallFont,0,0);
  SetColor(white);
  for i := 1 to j+1 do
  begin
    LineRel(0,300);
    str(i,str1);
    if i <= size_of_month[m2] then
      if i = d2 then
      begin
        SetColor(red);
        if i >= 10 then OutTextXY(GetX+5,70,str1)
        else OutTextXY(GetX+8,70,str1);
        SetColor(White);
      end
      else if i >= 10 then OutTextXY(GetX+5,70,str1)
        else OutTextXY(GetX+8,70,str1);
    MoveTo(GetX+20,100);
  end;
  Line(10,250,GetX-20,250);
  OutTextXY(2,245,'0');
  SetColor(Yellow);
  SetLineStyle(0,3,123);
  Line(65,420,95,420);
  SetColor(Blue);
  Line(270,420,300,420);
  SetColor(Green);
  Line(460,420,490,420);
  SetColor(White);
  OutTextXY(100,415,'ˆ­â¥«¥ªâ. €ªâ¨¢­');
  OutTextXY(305,415,'”¨§¨ç. €ªâ¨¢­');
  OutTextXY(495,415,'�¬®æ¨®­ «. €ªâ¨¢­');
  Str(d1,str1);
  Str(m1,str2);
  Str(y1,str3);
  str4 := concat('�¨®à¨â¬ë ­  ',str1,'/',str2,'/',str3);
  SetTextStyle(SansSerifFont,0,4);
  SetTextJustify(CenterText,CenterText);
  SetColor(LightBlue);
  OutTextXY(319,20,str4);
  SetTextJustify(LeftText,TopText);
End;{Table}
{---------------------------}
Procedure Write_Bio(j:integer);
var
  k:Integer;
Begin
  SetColor(Blue);
  MoveTo(20,250-trunc(f[1]));
  For k := 2 to j do LineTo(GetX+20,250-trunc(f[k]));
  SetColor(Green);
  MoveTo(20,250-trunc(e[1]));
  For k := 2 to j do LineTo(GetX+20,250-trunc(e[k]));
  SetColor(Yellow);
  MoveTo(20,250-trunc(i[1]));
  For k := 2 to j do LineTo(GetX+20,250-trunc(i[k]));
End;{Write_Bio}
{-------------------------------}
Procedure InputDates(var d1,m1,y1 : integer);
var
  correctly: Boolean; {�ਧ­ ª ¯à ¢¨«ì­®£® ¢¢®¤ }
{-------------------}
Procedure InpDate(text: string; var d,m,y: integer);
const
  YMIN = 1800; 		{Œ¨­¨¬ «ì­ë© ¯à ¢¨«ì­ë© £®¤}
  YMAX = 2000; 		{Œ ªá¨¬ «ì­ë© ¯à ¢¨«ì­ë© £®¤}
begin {InpDate}
repeat
  Write(text);
  ReadLn(d,m,y);
  correctly := (y >= YMIN) and (Y <= YMAX) and (m >= 1)
                           and (m <= 12)   and (d > 0);
  if correctly then
   if (m = 2) and (d = 29) and (y mod 4 = 0)
   then
     {�¨ç¥£® ­¥ ¤¥« âì: íâ® 29 ä¥¢à «ï ¢¨á®ª®á­®£® £®¤ !}
   else
     correctly := d <= Size_of_Month[m];
  if not correctly then
    WriteLn('Žè¨¡ª  ¢ ¤ â¥!')
until correctly
end; {InpDate}
{-------------------}
begin {InputDates}
 repeat
 InpDate(' ‚¢¥¤¨â¥ ¤ âã ஦¤¥­¨ï ¢ ä®à¬ â¥ „„ ŒŒ ƒƒƒƒ:',
                                                    d1,m1,y1);
 until correctly
end; {InputDates}

{------------------------------}

Begin
 ClrScr;
 InputDates(d1,m1,y1) ;
 if (RegisterBGIDriver(@VGADRV) < 1) or
    (RegisterBGIFont(@SANSFONT) < 1) or
    (RegisterBGIFont(@LITTFONT) < 1) then Halt(1);
 Gd := VGA;Gm:=VGAhi;
 InitGraph(Gd, Gm, path);
 if GraphResult <> grOk then
  Halt(1);
 GetDate(y2,m2,d2,dayofweek);
 s := trunc((22-m1)/10);
 r1:= trunc((y1-1899-s)*365.25) + trunc((12 * s + m1 - 14)*30.59)+29+d1;
 s := trunc( (22-m2)/10);
 r := trunc((y2-1899-s)*365.25) + trunc((12 * s + m2 - 14)*30.59)+29+d2;
 r := r-r1;
 r := r - d2;
 for j := 1 to size_of_month[m2] do
 begin
   f[j]:=150*sin((2*Pi*((r+j) mod 23))/23);
   e[j]:=150*sin((2*pi*((r+j) mod 28))/28);
   i[j]:=150*sin((2*pi*((r+j) mod 33))/33);
 End;
 SetLineStyle(SolidLn,1,123);
 SetColor(White);
 SetFillStyle(7,Green);
 Table(Size_of_month[m2]);
 Write_Bio(Size_of_month[m2]);
 Readln;
 CloseGraph;
End.