Скачать Вечный календарь на месяц

program CALENDAR;
uses CRT;
const WEEK: array[4..10] of string[3]
            =('ПHД','ВТР','СРД','ЧТВ','ПТH','СБТ','ВСК');
      MONTH: array[1..12] of string[3]
             =('ЯHВ','ФЕВ','МАР','АПР','МАЙ','ИЮH',
             'ИЮЛ','АВГ','СЕH','ОКТ','HОЯ','ДЕК');
var   YEAR, YR, STCOR: integer;
      SUM, BUF: real;
      STILE: boolean;
      CTRL: char;
      CTR, RES, X, Y, A, MO, MO1: byte;
procedure COL;
begin
  if Y=10 then TextAttr:=52 else TextAttr:=48;
end;
begin
    TextAttr:=46;
    ClrScr;
    GotoXY(29,2);
    write('К А Л Е H Д А Р Ь');
    GotoXY(18,20);
    write('Стрелки вправо - влево: листать календарь');
    GotoXY(18,22);
    write('Esc - выход');
    Window(15,5,59,17);
    repeat
      TextAttr:=54;
      ClrScr;
      GotoXY(2,2);
      write('Введите месяц ');
      readln(MO);
      write(' Введите год ');
      readln(YEAR);
      writeln(' Введите стиль:');
      write(' григорианский (G) или юлианский (J)');
      STILE:=(ReadKey<>'j');
    until (MO<13) and (YEAR>1) and (YEAR<9999);
 
{Вот тyт и начинается вычисление}
   repeat
      MO1:=MO+1;
      YR:=YEAR;
      if MO<3 then begin MO1:=MO1+12; Dec(YR) end;
    case MO of
      2: if (YEAR/4)=(YEAR div 4) then CTR:=29 else CTR:=28;
      4, 6, 9, 11: CTR:=30;
      else CTR:=31;
    end;
    if STILE then STCOR:=2-YR div 100+YR div 400 else STCOR:=0;
    SUM:=Trunc(365.25*YR)+Trunc(30.6*MO1)+STCOR+5.5;
    BUF:=SUM / 7 - Trunc(SUM) div 7;
    RES:=Byte(Trunc(7*BUF));
    if RES=0 then RES:=7;
{А вот тyт заканчивается}
 
    Dec(RES);
    ClrScr;
    GotoXY(14,1);
    TextAttr:=52;
    write(MONTH[MO],'   ',YEAR);
    GotoXY(1,4);
    for Y:=4 to 10 do
       begin
          COL;
          writeln('  ',WEEK[Y]);
       end;
    Y:=RES+4;X:=15;
    for A:=1 to CTR do
       begin
          COL;
          GotoXY(X,Y);
          write(A:2);
          Inc(Y);
          if Y=11 then begin Y:=4; X:=X+5 end;
       end;
    GotoXY(1,12);
    repeat
       CTRL:=ReadKey;
    until (CTRL in [#27,#075,#077]);
    case CTRL of
      #27: begin
              TextAttr:=48;
              Window(1,1,80,25);
              ClrScr;
              MO1:=0;
           end;
      #075: begin
              Dec(MO);
              if MO=0 then begin Dec(YEAR); MO:=12 end;
            end;
      #077: begin
              Inc(MO);
              if MO=13 then begin Inc(YEAR); MO:=1 end;
            end;
      end;
  until MO1=0;
end.