(*$T- COMPILE WITHOUT RUN-TIME TESTS. *)
(*$P0 COMPILE WITH ABSOLUTELY NO PMD INFORMATION. *)

(**       CALENDAR - GENERATE VARIOUS KINDS OF CALENDARS FOR ANY YEAR
*                    1582 - 9999 (INTENDED FOR INTERACTIVE USE ONLY).
*
*         ANDY MICKEL    73/12/01, 79/12/27.
*
*         COPYRIGHT (C)  1980.
*)

PROGRAM CALENDAR(C, OUTPUT, INPUT/);

  CONST
      CHARWIDTH = 7;
     CHARHEIGHT = 7;
   PRINTERWIDTH = 132;
  MAXLINELENGTH = 14  (* = PRINTERWIDTH DIV (CHARWIDTH + 2) *);
        MAXYEAR = 9999;
       YEARSIZE = 4  (* = LOG10(MAXYEAR + 1) *);

  TYPE
        CALKIND = (SMALL, APPOINTMENT, WALL);
           DATE = 0 .. 31;
         MONTHS = (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, SEP, OCT, NOV, DEC);
          WEEKS = 1 .. 6;
           DAYS = (SUN, MON, TUE, WED, THU, FRI, SAT);
     NUMERICDAY = 0 .. 6;
   NUMERICMONTH = 1 .. 12;
    INPUTSTATES = (ERROR, GOTAREQUEST, DONE);
           ALFA = PACKED ARRAY [1 .. 10] OF CHAR;
          IMAGE = ARRAY [1 .. CHARHEIGHT] OF
                    PACKED ARRAY [1 .. CHARWIDTH] OF CHAR;

  VAR
              C: TEXT;
            CAL: ARRAY [MONTHS, WEEKS, DAYS] OF DATE;
    DAYSINMONTH: ARRAY [MONTHS] OF DATE;
    FIRSTOFYEAR: DAYS;
           KIND: CALKIND;
        LARGECH: ARRAY ['A' .. ' '] OF IMAGE;
      MONTHNAME: ARRAY [MONTHS] OF ALFA;
         STATUS: INPUTSTATES;
          TITLE: ARRAY [1 .. MAXLINELENGTH] OF CHAR;
     YEARDIGITS: ARRAY [1 .. YEARSIZE] OF CHAR;
           YEAR: INTEGER;
        ADJYEAR: INTEGER;

  VALUE
    DAYSINMONTH = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
      MONTHNAME = (' JANUARY  ', ' FEBRUARY ', '  MARCH   ', '  APRIL   ',
                   '   MAY    ', '   JUNE   ', '   JULY   ', '  AUGUST  ',
                   'SEPTEMBER ', ' OCTOBER  ', ' NOVEMBER ', ' DECEMBER ');
        LARGECH = (
  (' AAAAA ', 'AA   AA', 'AA   AA', 'AAAAAAA', 'AA   AA', 'AA   AA', 'AA   AA'),
  ('BBBBBB ', 'BB   BB', 'BB   BB', 'BBBBBB ', 'BB   BB', 'BB   BB', 'BBBBBB '),
  (' CCCCC ', 'CC   CC', 'CC     ', 'CC     ', 'CC     ', 'CC   CC', ' CCCCC '),
  ('DDDDDD ', ' DD  DD', ' DD  DD', ' DD  DD', ' DD  DD', ' DD  DD', 'DDDDDD '),
  ('EEEEEEE', 'EE     ', 'EE     ', 'EEEEE  ', 'EE     ', 'EE     ', 'EEEEEEE'),
  ('FFFFFFF', 'FF     ', 'FF     ', 'FFFFF  ', 'FF     ', 'FF     ', 'FF     '),
  (' GGGGG ', 'GG   GG', 'GG     ', 'GG     ', 'GG  GGG', 'GG   GG', ' GGGGG '),
  ('HH   HH', 'HH   HH', 'HH   HH', 'HHHHHHH', 'HH   HH', 'HH   HH', 'HH   HH'),
  ('IIIIII ', '  II   ', '  II   ', '  II   ', '  II   ', '  II   ', 'IIIIII '),
  ('     JJ', '     JJ', '     JJ', '     JJ', '     JJ', ' JJ  JJ', '  JJJJ '),
  ('KK   KK', 'KK  KK ', 'KK KK  ', 'KKKK   ', 'KK KK  ', 'KK  KK ', 'KK   KK'),
  ('LL     ', 'LL     ', 'LL     ', 'LL     ', 'LL     ', 'LL     ', 'LLLLLLL'),
  ('M     M', 'MM   MM', 'MMM MMM', 'MM M MM', 'MM   MM', 'MM   MM', 'MM   MM'),
  ('N    NN', 'NN   NN', 'NNN  NN', 'NN N NN', 'NN  NNN', 'NN   NN', 'NN    N'),
  (' OOOOO ', 'OO   OO', 'OO   OO', 'OO   OO', 'OO   OO', 'OO   OO', ' OOOOO '),
  ('PPPPPP ', 'PP   PP', 'PP   PP', 'PPPPPP ', 'PP     ', 'PP     ', 'PP     '),
  (' QQQQQ ', 'QQ   QQ', 'QQ   QQ', 'QQ   QQ', 'QQ Q QQ', 'QQ  QQ ', ' QQQQ Q'),
  ('RRRRRR ', 'RR   RR', 'RR   RR', 'RRRRRR ', 'RR RR  ', 'RR  RR ', 'RR   RR'),
  (' SSSSS ', 'SS   SS', 'SS     ', ' SSSSS ', '     SS', 'SS   SS', ' SSSSS '),
  ('TTTTTT ', '  TT   ', '  TT   ', '  TT   ', '  TT   ', '  TT   ', '  TT   '),
  ('UU   UU', 'UU   UU', 'UU   UU', 'UU   UU', 'UU   UU', 'UU   UU', ' UUUUU '),
  ('VV   VV', 'VV   VV', 'VV   VV', ' VV VV ', ' VV VV ', '  VVV  ', '   V   '),
  ('WW   WW', 'WW   WW', 'WW   WW', 'WW   WW', 'WW W WW', 'WWWWWWW', ' WW WW '),
  ('XX   XX', ' XX XX ', '  XXX  ', '   X   ', '  XXX  ', ' XX XX ', 'XX   XX'),
  ('YY  YY ', 'YY  YY ', ' YYYY  ', '  YY   ', '  YY   ', '  YY   ', '  YY   '),
  ('ZZZZZZZ', '    ZZ ', '   ZZ  ', ' ZZZZZ ', '  ZZ   ', ' ZZ    ', 'ZZZZZZZ'),
  ('  000 /', ' 00 00 ', '00  /00', '00 / 00', '00/  00', ' 00 00 ', '/ 000  '),
  ('   11  ', '  111  ', '   11  ', '   11  ', '   11  ', '   11  ', ' 111111'),
  (' 22222 ', '22   22', '     22', '    22 ', '  22   ', '22     ', '2222222'),
  (' 33333 ', '33   33', '     33', '  3333 ', '     33', '33   33', ' 33333 '),
  ('   44  ', '  444  ', ' 4444  ', '44 44  ', '4444444', '   44  ', '   44  '),
  ('5555555', '55     ', '55     ', ' 55555 ', '     55', '55   55', ' 55555 '),
  (' 66666 ', '66   66', '66     ', '666666 ', '66   66', '66   66', ' 66666 '),
  ('7777777', '     77', '    77 ', '   77  ', '  77   ', ' 77    ', ' 77    '),
  (' 88888 ', '88   88', '88   88', ' 88888 ', '88   88', '88   88', ' 88888 '),
  (' 99999 ', '99   99', '99   99', ' 999999', '     99', '99   99', ' 99999 '),
  ('       ', '   +   ', '   +   ', '+++++++', '   +   ', '   +   ', '       '),
  ('       ', '       ', '       ', '-------', '       ', '       ', '       '),
  ('       ', ' *   * ', '  * *  ', '** * **', '  * *  ', ' *   * ', '       '),
  ('      /', '     / ', '    /  ', '   /   ', '  /    ', ' /     ', '/      '),
  ('    (( ', '   ((  ', '  ((   ', '  ((   ', '  ((   ', '   ((  ', '    (( '),
  (' ))    ', '  ))   ', '   ))  ', '   ))  ', '   ))  ', '  ))   ', ' ))    '),
  ('  $ $  ', ' $$$$$$', '$ $ $  ', ' $$$$$ ', '  $ $ $', '$$$$$$ ', '  $ $  '),
  ('       ', '       ', '=======', '       ', '=======', '       ', '       '),
  ('       ', '       ', '       ', '       ', '       ', '       ', '       '));


  PROCEDURE INITIALIZE;

  BEGIN
    REWRITE(C);
    LINELIMIT(C, MAXINT);
    WRITELN;
    WRITELN('DO YOU NEED INSTRUCTIONS FOR THIS CALENDAR PROGRAM?');
    READLN;
    IF NOT EOF(INPUT) THEN IF INPUT^ <> 'N' THEN
      BEGIN
        WRITELN;
        WRITELN('   THIS PROGRAM GENERATES 3 KINDS OF CALENDARS FOR ANY YEAR');
        WRITELN('AFTER 1582 UP TO 9999.  (1582 IS THE YEAR OF THE ADVENT OF THE');
        WRITELN('GREGORIAN CALENDAR.)  ALL YOU NEED TO DO IS TO SPECIFY THE');
        WRITELN('YEAR AND KIND OF CALENDAR YOU WANT ON ONE LINE IN THE FORM:');
        WRITELN('YYYYK   WITH NO INTERVENING BLANKS.');
        WRITELN;
        WRITELN('THE "K" CAN BE AN "A", "S", OR "W":');
        WRITELN;
        WRITELN('     A: SELECTS A 12-PAGE "APPOINTMENT" CALENDAR FEATURING');
        WRITELN('           LARGE BOXES IN WHICH TO WRITE.');
        WRITELN('     S: SELECTS A 1-PAGE, "SMALL" CALENDAR.');
        WRITELN('     W: SELECTS A 12-PAGE "WALL" CALENDAR WITH LARGE NUMERALS.');
        WRITELN;
        WRITELN('   YOU MAY REQUEST AS MANY CALENDARS AS YOU WANT...ONE YEAR AND');
        WRITELN('KIND PER LINE.  A BLANK LINE OR AN EMPTY LINE STOPS THE PROGRAM.');
        WRITELN('THE RESULTS ARE WRITTEN ON A FILE NAMED "C".');
      END
  END (* INITIALIZE *);


  PROCEDURE CHECKFORREQUEST(VAR YEAR: INTEGER; VAR KIND: CALKIND;
                            VAR STATUS: INPUTSTATES);

    PROCEDURE GETREQUEST;

      VAR
        COUNT: 1 .. YEARSIZE;

    BEGIN
      STATUS := GOTAREQUEST;
      IF INPUT^ IN ['1' .. '9'] THEN
        BEGIN  COUNT := 1;
          YEARDIGITS[COUNT] := INPUT^;
          YEAR := ORD(YEARDIGITS[COUNT]) - ORD('0');
          REPEAT
            GET(INPUT);
            IF INPUT^ IN ['0' .. '9'] THEN
              BEGIN  COUNT := COUNT + 1;
                YEARDIGITS[COUNT] :=  INPUT^;
                YEAR := (YEAR * 10) + ORD(YEARDIGITS[COUNT]) - ORD('0')
              END
            ELSE
              STATUS := ERROR
          UNTIL (COUNT = YEARSIZE) OR (STATUS = ERROR)
        END
      ELSE
        STATUS := ERROR;
      IF STATUS <> ERROR THEN
        BEGIN GET(INPUT);
          IF INPUT^ IN ['A', 'S', 'W'] THEN
            CASE INPUT^ OF
              'A': KIND := APPOINTMENT;
              'S': KIND := SMALL;
              'W': KIND := WALL
            END
          ELSE
            STATUS := ERROR
        END
    END (* GETREQUEST *);

  BEGIN (* CHECKFORREQUEST *)
    WRITELN;
    WRITELN('PLEASE ENTER THE YEAR AND KIND OF CALENDAR ',
            'YOU WISH (YYYYK).');
    READLN  (* PROMPT *);
    IF NOT EOF(INPUT) THEN
      BEGIN
        WHILE (INPUT^ = ' ') AND NOT EOLN(INPUT) DO
          GET(INPUT);
        IF INPUT^ <> ' ' THEN
          GETREQUEST
        ELSE (* EOLN *)
          STATUS := DONE
      END
    ELSE
      STATUS := DONE
  END (* CHECKFORREQUEST *);


  FUNCTION DAY(WHICH: NUMERICDAY): DAYS;

  BEGIN
    CASE WHICH OF
      0: DAY := SUN;   1: DAY := MON;
      2: DAY := TUE;   3: DAY := WED;
      4: DAY := THU;   5: DAY := FRI;
      6: DAY := SAT
    END
  END (* DAY *);


  FUNCTION MONTH(WHICH: NUMERICMONTH): MONTHS;

  BEGIN
    CASE WHICH OF
      1: MONTH := JAN;   2: MONTH := FEB;
      3: MONTH := MAR;   4: MONTH := APR;
      5: MONTH := MAY;   6: MONTH := JUN;
      7: MONTH := JUL;   8: MONTH := AUG;
      9: MONTH := SEP;  10: MONTH := OCT;
     11: MONTH := NOV;  12: MONTH := DEC
    END
  END (* MONTH *);


  PROCEDURE FILLCALENDAR(DAYPTR: DAYS);

    VAR
       D: DATE;
      MO: MONTHS;
      WK: WEEKS;
      DY: DAYS;

  BEGIN
    FOR MO := JAN TO DEC DO
      FOR WK := 1 TO 6 DO
        FOR DY := SUN TO SAT DO  (* CLEAR CALENDAR *)
          CAL[MO,WK,DY] := 0;
    FOR MO := JAN TO DEC DO
      BEGIN WK := 1;
        FOR D := 1 TO DAYSINMONTH[MO] DO
          BEGIN CAL[MO,WK,DAYPTR] := D;
            IF DAYPTR = SAT THEN
              BEGIN
                DAYPTR := SUN;  WK := WK + 1
              END
            ELSE DAYPTR := SUCC(DAYPTR)
          END
      END
  END (* FILLCALENDAR *);


  PROCEDURE WRITETITLE;

  VAR
    ROW: 1 .. CHARHEIGHT;
      I: 1 .. MAXLINELENGTH;

  BEGIN
    FOR ROW := 1 TO CHARHEIGHT DO
      BEGIN WRITE(C,'  ');
        FOR I := 1 TO MAXLINELENGTH DO
          WRITE(C,LARGECH[ TITLE[I], ROW ]:9);
        WRITELN(C);
      END
  END (* WRITETITLE *);


  PROCEDURE SMALLCALENDAR;

    CONST
      HEIGHT = 3;
       WIDTH = 4;

    VAR
          DY: DAYS;
          WK: WEEKS;
          MO: MONTHS;
           I: 1 .. PRINTERWIDTH;
         COL: 1 .. WIDTH;
         ROW: 1 .. HEIGHT;
      ACROSS: 1 .. PRINTERWIDTH;

    PROCEDURE WRITESEPARATOR;

      VAR
        COL: 1 .. WIDTH;

    BEGIN
      WRITE(C,'  #');
      FOR COL := 1 TO WIDTH DO
        WRITE(C,'#':ACROSS);
      WRITELN(C)
    END (* WRITESEPARATOR *);

  BEGIN (* SMALLCALENDAR *)
    PAGE(C);  WRITELN(C);
    FOR I := 1 TO MAXLINELENGTH DO
      TITLE[I] := ' ';
    FOR I := 1 TO YEARSIZE DO
      TITLE[I+5] := YEARDIGITS[I];
    FOR I := 1 TO 3 DO
      BEGIN
        TITLE[I] := '*';  TITLE[I+11] := '*'
      END;
    WRITETITLE;
    WRITELN(C);
    ACROSS := (PRINTERWIDTH DIV WIDTH) - 1;
    WRITE(C,'  *');
    FOR I := 1 TO ACROSS DO
      WRITE(C,'*#**');
    WRITELN(C);
    FOR ROW := 1 TO HEIGHT DO
      BEGIN WRITESEPARATOR;
        WRITE(C,'  *');
        FOR COL := 1 TO WIDTH DO
          WRITE(C,MONTHNAME[MONTH((ROW - 1) * WIDTH + COL)]:21,'*':11);
        WRITELN(C);
        WRITESEPARATOR;
        WRITE(C,'  *');
        FOR COL := 1 TO WIDTH DO
          WRITE(C,'  SUN MON TUE WED THU FRI SAT  *');
        WRITELN(C);
        WRITE(C,'  #');
        FOR COL := 1 TO WIDTH DO
          WRITE(C,'  ---------------------------  #');
        WRITELN(C);
        FOR WK := 1 TO 6 DO
          BEGIN WRITE(C,'  * ');
            FOR COL := 1 TO WIDTH DO
              BEGIN MO := MONTH((ROW - 1) * WIDTH + COL);
                FOR DY := SUN TO SAT DO
                  IF CAL[MO,WK,DY] = 0 THEN
                    WRITE(C,'    ')
                  ELSE
                    WRITE(C,CAL[MO,WK,DY]:4);
                WRITE(C,'  * ')
              END;
            WRITELN(C);
            WRITESEPARATOR
          END;
        WRITE(C,'  *');
        FOR I := 1 TO ACROSS DO
          WRITE(C,'*#**');
        WRITELN(C)
      END
  END (* SMALLCALENDAR *);


  PROCEDURE WRITEMONTHHEADER(MO: MONTHS);

    VAR
      I: 1 .. PRINTERWIDTH;

  BEGIN
    PAGE(C);  WRITELN(C);
    UNPACK(MONTHNAME[MO],TITLE,1);
    WRITETITLE;
    WRITE(C,' ');
    FOR I := 1 TO PRINTERWIDTH - 1 DO
      WRITE(C,'-');
    WRITELN(C);
    WRITELN(C,'SUNDAY':13,'MONDAY':19,'TUESDAY':19,'WEDNESDAY':20,
            'THURSDAY':19,'FRIDAY':18,'SATURDAY':19);
    WRITE(C,' ');
    FOR I := 1 TO PRINTERWIDTH - 1 DO
      WRITE(C,'+');
    WRITELN(C)
  END (* WRITEMONTHHEADER *);


  PROCEDURE APPOINTCALENDAR;

    VAR
          MO: MONTHS;
          WK: WEEKS;
          DY: DAYS;
           I: 1 .. PRINTERWIDTH;
      ACROSS: 1 .. PRINTERWIDTH;

  BEGIN
    FOR I := 1 TO YEARSIZE DO
      TITLE[I+10] := YEARDIGITS[I];
    ACROSS := (PRINTERWIDTH DIV 7) + 1;
    FOR MO := JAN TO DEC DO
      BEGIN WRITEMONTHHEADER(MO);
        FOR WK := 1 TO 6 DO
          BEGIN WRITE(C,' ');
            FOR DY := SUN TO FRI DO
              WRITE(C,'+':ACROSS);
            WRITELN(C);
            WRITE(C,' ');
            FOR DY := SUN TO FRI DO
              IF CAL[MO,WK,DY] = 0 THEN
                WRITE(C,'+':ACROSS)
              ELSE
                WRITE(C,CAL[MO,WK,DY]:3, '+':ACROSS - 3);
            IF CAL[MO,WK,SAT] <> 0 THEN
              WRITE(C,CAL[MO,WK,SAT]:3);
            FOR I := 1 TO 6 DO
              BEGIN WRITELN(C);
                WRITE(C,' ');
                FOR DY := SUN TO FRI DO
                  WRITE(C,'+':ACROSS);
              END;
            WRITELN(C);
            WRITE(C,' ');
            FOR I := 1 TO PRINTERWIDTH - 1 DO
              WRITE(C,'+');
            IF WK <> 6 THEN WRITELN(C)
          END
      END
  END (* APPOINTCALENDAR *);


  PROCEDURE WALLCALENDAR;

    VAR
        MO: MONTHS;
        WK: WEEKS;
        DY: DAYS;
         I: 1 .. PRINTERWIDTH;
       ROW: 1 .. CHARHEIGHT;
      TENS: CHAR;
      ONES: CHAR;
    ACROSS: 1 .. PRINTERWIDTH;

  BEGIN
    FOR I := 1 TO YEARSIZE DO
      TITLE[I+10] := YEARDIGITS[I];
    ACROSS := (PRINTERWIDTH DIV 7);
    FOR MO := JAN TO DEC DO
      BEGIN WRITEMONTHHEADER(MO);
        FOR WK := 1 TO 6 DO
          BEGIN WRITELN(C);  WRITELN(C);
            FOR ROW := 1 TO CHARHEIGHT DO
              BEGIN
                FOR DY := SUN TO SAT DO
                  BEGIN
                    IF DY <> SUN THEN WRITE(C,' ');
                    IF CAL[MO,WK,DY] = 0 THEN
                      WRITE(C,' ':ACROSS)
                    ELSE
                      BEGIN
                        TENS := CHR((CAL[MO,WK,DY] DIV 10) + ORD('0'));
                        ONES := CHR((CAL[MO,WK,DY] MOD 10) + ORD('0'));
                        IF TENS = '0' THEN TENS := ' ';
                        WRITE(C,LARGECH[TENS,ROW]:10,LARGECH[ONES,ROW]:8);
                      END;
                  END;
                IF (WK <> 6) OR (ROW <> CHARHEIGHT) THEN WRITELN(C)
              END
          END
      END
  END (* WALLCALENDAR *);


BEGIN (* CALENDAR *);
  INITIALIZE;
  IF NOT EOF(INPUT) THEN
    REPEAT
      CHECKFORREQUEST(YEAR,KIND,STATUS);
      IF STATUS = GOTAREQUEST THEN
        BEGIN
          DAYSINMONTH[FEB] := 28;
          IF (YEAR MOD 4) = 0 THEN
            IF ((YEAR MOD 400) = 0) >= ((YEAR MOD 100) = 0) THEN
              DAYSINMONTH[FEB] := 29;
          ADJYEAR := YEAR - 1;
          FIRSTOFYEAR := DAY((36 + ADJYEAR + (ADJYEAR DIV 4)
              - (ADJYEAR DIV 100) + (ADJYEAR DIV 400)) MOD 7);
          FILLCALENDAR(FIRSTOFYEAR);
          CASE KIND OF
            SMALL:
              SMALLCALENDAR;
            APPOINTMENT:
              APPOINTCALENDAR;
            WALL:
              WALLCALENDAR
          END;
          WRITELN('DONE.')
        END
      ELSE
        IF STATUS = ERROR THEN
          WRITELN('SOMETHING''S WRONG WITH YOUR INPUT, PLEASE TRY AGAIN.')
    UNTIL STATUS = DONE
END (*CALENDAR *).