Module DB_Date(Output);
{ Date processing routines
  Copyright © 1989,1990 Bruce Tanner - Cerritos College }

%Include 'DBType.PAS'

Const
  Months_In_Year = 12;		{ Size of Month_Table, etc. }
  Julian_Offset = 1720994;	{ 0 AD as Julian date minus magic numbers (30.6001 * 14) }
  Century_Threshold = 70;	{ If YY is < 70 }
  Century_2 = 2000;		{ Add 2000 to YY }
  Century_1 = 1900;		{ else add 1900 to YY }
  { After around 2050 you'll want to change these numbers }

Type
 { Don't change order; insert new DOW before WKD }
  DOW_Type = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday,
	     Weekday, Tomorrow, Yesterday, Today, Everyday, WKD);

Var
  { Global tables }
  Month_Table: Array [1..Months_In_Year] of String;
  DOW_Table: Array [DOW_Type] of String;
  Perp_Array: Packed Array [0..6, 1..80] of Char;
  Parse_Result: Boolean;	{ 4.4 - Global flag for Parse_Date from Error }
  Reform_Date: D_Type;

{ DB_Str }
Procedure Int_Concat(Var S: String; Int: Integer); Extern;
Procedure Skip_Spaces(S: String; Var Ind: Integer); Extern;
Procedure Find_Space(S: String; Var Ind: Integer); Extern;
Procedure PS_Up_Case(Var S: String); Extern;
Function Get_Num(S: String; Var Ind: Integer; Var Got_Num: Boolean):Integer; Extern;
Function Match_String(S, T: String): Boolean; Extern;

{ DB_TIO }
Procedure Write1(S: Varying [L] of Char); Extern;
Procedure Writeln1(S: Varying [L] of Char); Extern;


[Global] Procedure Date_Init;
Begin { Date_Init }
  Month_Table[1] := 'January';
  Month_Table[2] := 'February';
  Month_Table[3] := 'March';
  Month_Table[4] := 'April';
  Month_Table[5] := 'May';
  Month_Table[6] := 'June';
  Month_Table[7] := 'July';
  Month_Table[8] := 'August';
  Month_Table[9] := 'September';
  Month_Table[10] := 'October';
  Month_Table[11] := 'November';
  Month_Table[12] := 'December';
  { New months go here -- be sure to change Months_In_Year }

  DOW_Table[Sunday] :=    'Sunday';
  DOW_Table[Monday] :=    'Monday';
  DOW_Table[Tuesday] :=   'Tuesday';
  DOW_Table[Wednesday] := 'Wednesday';
  DOW_Table[Thursday] :=  'Thursday';
  DOW_Table[Friday] :=    'Friday';
  DOW_Table[Saturday] :=  'Saturday';
  DOW_Table[Weekday] :=   'Weekday';
  DOW_Table[Tomorrow] :=  'Tomorrow';
  DOW_Table[Yesterday] := 'Yesterday';
  DOW_Table[Today] :=     'Today';	{ "It's Today!" squeaked Piglet }
  DOW_Table[Everyday] :=  'Everyday';	{ "My favorite day", said Pooh }
  DOW_Table[WKD] :=       'WKD';	{ For compatability with ver 2 }

  Reform_Date.Year := 1752;		{ Date of Gregorian calendar reform }
  Reform_Date.Month := 9;		{ For the English dominion calendar... }
  Reform_Date.Day := 14;		{ Use Oct 15, 1582 for original (Italian) date }
					{ Turkey didn't adopt it until 1927 }

End; { Date_Init }


{ ############################## }

Procedure Error(N: Integer);
Begin
  Parse_Result := False;	{ 4.4 - Make Parse_Date return failure }
  Case N of
    1: Writeln1('Date starts with unknown character');
    2: Writeln1('Couldn''t read Day');
    3: Writeln1('Couldn''t read Year');
    4: Writeln1('Non alphanumeric character while looking for DD or MMM');
    5: Writeln1('Non-existent Day of Week');
    6: Writeln1('Non-existent Date');
    Otherwise
      Writeln('Unknown error ', N:1);
      Writeln1('')
  End { Case }
End; { Error }


{ ############################## }

[Global] Function Same_Date(Date1, Date2: D_Type): Boolean;
Begin
  Same_Date := (Date1.Year = Date2.Year) and_then
               (Date1.Month = Date2.Month) and_then
               (Date1.Day = Date2.Day)
End;


{ ############################## }

[Global] Function LE_Date(Date1, Date2: D_Type): Boolean;
Begin
  LE_Date := (Date1.Year < Date2.Year)
     or_else ((Date1.Year = Date2.Year) and (Date1.Month < Date2.Month))
     or_else ((Date1.Year = Date2.Year) and (Date1.Month = Date2.Month)
		and (Date1.Day <= Date2.Day))
End;


{ ############################## }

[Global] Function LE_Time(Time1, Time2: T_Type): Boolean;
Begin
  LE_Time := (Time1 <= Time2)
End;


{ ############################## }

[Global] Function GE_Date(Date1, Date2: D_Type): Boolean;
Begin
  GE_Date := (Date1.Year > Date2.Year)
     or_else ((Date1.Year = Date2.Year) and (Date1.Month > Date2.Month))
     or_else ((Date1.Year = Date2.Year) and (Date1.Month = Date2.Month)
		and (Date1.Day >= Date2.Day))
End;


{ ############################## }

[Global] Function GE_Time(Time1, Time2: T_Type): Boolean;
Begin
  GE_Time := (Time1 >= Time2)
End;


{ ############################## }

Procedure Pars_YYMMDD(N: Integer; Var R_Date: D_Type);
Begin
  R_Date.Year := N DIV 10000;
  If R_Date.Year < Century_Threshold then
     R_Date.Year := R_Date.Year + Century_2
  else If R_Date.Year < 100 then
     R_Date.Year := R_Date.Year + Century_1;
  R_Date.Month := (N MOD 10000) DIV 100;
  R_Date.Day := N MOD 100
End;


{ ############################## }

Procedure PMMDDYY(N: Integer; Var R_Date: D_Type);
Begin
  R_Date.Month := N DIV 10000;
  R_Date.Day := (N MOD 10000) DIV 100;
  R_Date.Year := N MOD 100;
  If R_Date.Year < Century_Threshold then
     R_Date.Year := R_Date.Year + Century_2
  else
     R_Date.Year := R_Date.Year + Century_1
End;


{ ############################## }

Procedure Par_MMDD(N: Integer; Var R_Date: D_Type);
Begin
  R_Date.Month := (N MOD 10000) DIV 100;
  R_Date.Day := N MOD 100
End;


{ ############################## }
{ Return the Julian date, the number of days since Jan 1, 4713 BC }
{ Ref: Computer Language December, 1990 which references: }
{ Astronomical Formulae for Calculators by Jean Meeus - Willmann-Bell, 1988 }
{ Astronomy With Your PC by Peter Duffett-Smith - Cambridge Univ. Press - 1990 }

Function Get_J_Date(T_Date: D_Type): Integer;
Var
  Gregorian_Offset: Integer;
  Year_Correction: Real;

Begin
  If T_Date.Year < 0 then T_Date.Year := T_Date.Year + 1;
  If T_Date.Year < 1 then Year_Correction := 0.75
  else Year_Correction := 0.0;
  If T_Date.Month <= 2 then Begin
    T_Date.Year := T_Date.Year - 1;
    T_Date.Month := T_Date.Month + 12
    End;
  Gregorian_Offset := 0;
  If GE_Date(T_Date, Reform_Date) then { Apply Gregorian calendar reform }
    Gregorian_Offset := 2 - (T_Date.Year DIV 100) + (T_Date.Year DIV 400);
  GET_J_Date := Trunc(365.25 * T_Date.Year - Year_Correction)  { Years worth of days }
		+ Trunc(30.6001 * (T_Date.Month + 1)) { Months worth of days? }
		+ T_Date.Day
		+ Julian_Offset
		+ Gregorian_Offset
End; { Get_J_Date }


{ ############################## }
{ Calculate Year, Month, Day from Julian date }
{ No, I don't know what the magic numbers mean }

Procedure Get_N_Date(Var R_Date: D_Type; J_Date: Integer);
Var
  A, B, C, D, E, Z, Alpha: Integer;

Begin
  Z := J_Date + 1;
  If J_Date < Get_J_Date(Reform_Date) then
    A := Z
  else Begin { Apply Gregorian calendar reform }
    Alpha := Trunc((Z - 1867216.25) / 36524.25);
    A := Z + 1 + Alpha - Alpha DIV 4;
    End;
  B := A + 1524;
  C := Trunc((DBLE(B) - 122.1) / 365.25);
  D := Trunc(C * 365.25);
  E := Trunc((B - D) / 30.6001);
  R_Date.Day := B - D - Trunc(E * 30.6001);
  If E < 13.5 then
    R_Date.Month := E - 1
  else
    R_Date.Month := E - 13;
  If R_Date.Month > 2 then
    R_Date.Year := C - 4716
  else
    R_Date.Year := C - 4715;
  If R_Date.Year < 1 then
    R_Date.Year := R_Date.Year - 1
End; { Get_N_Date }


{ ############################## }

[Global] Procedure Offset_Date(Var R_Date: D_Type; Offset: Integer);
Begin
  Get_N_Date(R_Date, Get_J_Date(R_Date) + Offset)
End; { Offset_Date }


{ ############################## }

Procedure Get_Year(S: String; Var Ind: Integer; Var R_Date: D_Type);
Var
  YY: Integer;
  Got_Num: Boolean;

Begin
  YY := Get_Num(S, Ind, Got_Num);
  IF Not Got_Num then
    Error(3);
  R_Date.Year := YY;
  If R_Date.Year < Century_Threshold then
     R_Date.Year := R_Date.Year + Century_2
  else If R_Date.Year < 100 then
     R_Date.Year := R_Date.Year + Century_1
End;


{ ############################## }
{ Get_Y1 calls Get_Year after skipping 1 character }

Procedure Get_Y1(S: String; Var Ind: Integer; Var R_Date: D_Type);
Begin
  Ind := Ind+1;
  Get_Year(S, Ind, R_Date)
End;


{ ############################## }

Function Check_Date(Var R_Date: D_Type): Boolean;
Var
  JD: Integer;
  T_Date: D_Type;
  OK_Date: Boolean;

Begin
  Get_N_Date(T_Date, Get_J_Date(R_Date));
  OK_Date := Same_Date(R_Date, T_Date) or (R_Date.Day = -1); { 3.7 - See Pars_RDow } 
  If Not OK_Date then Error(6);
  Check_Date := OK_Date
End; { Check_Date }


{ ############################## }

[Global] Function Get_Month(S: String; Var Ind: Integer): Integer;
Var
  Count, MI: Integer;
  T: String;
  SI: Integer;

Begin
  Count := 0;
  SI := 0;
  T := '';
  Skip_Spaces(S, Ind);
  While (Ind+SI <= S.Length) do Begin
    If (S[Ind+SI] in ['A'..'Z']) then
      T := T + S[Ind+SI];		{ Make up a string for Match_String }
    SI := SI+1
    End;
  For MI := 1 to Months_In_Year do
    If Match_String(T, Month_Table[MI]) then Begin
      Get_Month := MI;
      Count := Count+1
      End;
  If Count <> 1 then		{ No unique match of month }
    Get_Month := 0;
  Find_Space(S, Ind)
End;


{ ############################## }
{ Return the DOW in the string, or 0 if none }

[Global] Function Mat_DOW(S: String; Var Ind: Integer; Var Success: Boolean): DOW_Type;
Var
  Count: Integer;
  T: String;
  SI: Integer;
  DI, DX: DOW_Type;

Begin
  Count := 0;
  SI := 0;
  T := '';
  Skip_Spaces(S, Ind);
  While (Ind+SI <= S.Length) do Begin
    If (S[Ind+SI] in ['A'..'Z']) then
      T := T + S[Ind+SI];		{ Make up a string for Match_String }
    SI := SI+1
    End;
  For DI := Sunday to WKD do
    If Match_String(T, DOW_Table[DI]) then Begin
      DX := DI;
      Count := Count+1
      End;
  If DX = WKD then DX := Weekday;	{ Use correct Weekday index }
  Mat_DOW := DX;
  If Count <> 1 then Begin	{ No unique match of DOW }
    Mat_DOW := Sunday;
    Success := False
    End
  else
    Success := True;
  Find_Space(S, Ind)
End; { Mat_DOW }


{ ############################## }
{ Return the day of the week T_Date falls on }

[Global] Function Get_DOW(T_Date: D_Type): DOW_Type;
Begin
  Case ((Get_J_Date(T_Date) + 2) MOD 7) of	{ I sure wish there were an inverse of ORD }
    0: Get_DOW := Sunday;
    1: Get_DOW := Monday;
    2: Get_DOW := Tuesday;
    3: Get_DOW := Wednesday;
    4: Get_DOW := Thursday;
    5: Get_DOW := Friday;
    6: Get_DOW := Saturday
  End { Case }
End;


{ ############################## }
{ Return the next date that matches +-N:DOW }

Procedure Find_DOW(DOW: DOW_Type; Var R_Date: D_Type; Sign: Char; N: Integer);
Var
  DX: DOW_Type;
  Dont_Skip: Boolean;

Begin
  Dont_Skip := (R_Date.Day = 0);
  If Dont_Skip then		{ This came from Pars_NDOW }
    R_Date.Day := 1;
  DX := Get_DOW(R_Date);	{ Look for DOW starting at DX }
  { We have 2 cases (1) If DOW = DX then quit immediately.
                    (2) Advance DX, then test for DOW = DX. }
  { +DOW, Weekday, and n:DOW (which may be the 1st of the month) are case (1) }
  If (N = 0) or (DOW = Weekday) or Dont_Skip then { Case 1 }
    While Not ((DX = DOW)
          or ((DOW = Weekday)
              and (DX in [Monday..Friday]) { and not a holiday })) do Begin
      If Sign = '-' then
        Offset_Date(R_Date, -1)
      else
        Offset_Date(R_Date, 1);
      DX := Get_DOW(R_Date)
    End
   else { Case 2 }
     Repeat
       If Sign = '-' then
         Offset_Date(R_Date, -1)
       else
         Offset_Date(R_Date, 1);
       DX := Get_DOW(R_Date)
     Until (DX = DOW)
End; { Find_DOW }


{ ############################## }

Procedure Par_MSD(S: String; Var Ind: Integer; MM: Integer; Var R_Date: D_Type);
Var
  Got_Num: Boolean;

Begin
  Ind := Ind+1;		{ Point to char after slash }
  R_Date.Month := MM;
  R_Date.Day := Get_Num(S, Ind, Got_Num);
  If Not Got_Num then Error(2);
  If Ind <= S.Length then
    If S[Ind] = '/' then Get_Y1(S, Ind, R_Date)
End;


{ ############################## }

Procedure Par_DD(S: String; Var Ind: Integer; N: Integer; Var R_Date: D_Type);
Var
  Got_Num, Trouble: Boolean;
  MM: Integer;
  Save_Ind: Integer;

Begin
  Save_Ind := Ind;	{ Save the index }
  Trouble := False;
  Ind := Ind+1;		{ Point to char after dash }
  Skip_Spaces(S, Ind);
  If (Ind <= S.Length) then
    If (S[Ind] in ['A'..'Z']) then Begin
      R_Date.Day := N;
      MM := Get_Month(S, Ind);
      If MM > 0 then
        R_Date.Month := MM
      else Begin
        Ind := Save_Ind;	{ Probably '1-Weekday' }
        Trouble := True
        End
      End
    else If (S[Ind] in ['0'..'9']) and (Ind <= S.Length) then Begin
      R_Date.Month := N;
      R_Date.Day := Get_Num(S, Ind, Got_Num)
      End
    else
      Error(4);
  If (Ind <= S.Length) then
    If (S[Ind] = '-') and Not Trouble then Get_Y1(S, Ind, R_Date)
End; { Par_DD }


{ ############################## }

Procedure Par_DS(S: String; Var Ind: Integer; DD: Integer; Var R_Date: D_Type);
Var
  MM: Integer;
  Got_Num: Boolean;

Begin
  Ind := Ind+1;		{ Point to char after space }
  R_Date.Day := DD;
  If Ind <= S.Length then Begin
    MM := Get_Month(S, Ind);
    If MM > 0 then
      R_Date.Month := MM
    else Begin
      Skip_Spaces(S, Ind);
      If (Ind <= S.Length) then
        If (S[Ind] in ['0'..'9']) then Begin
          MM := Get_Num(S, Ind, Got_Num);
          If Got_Num then R_Date.Month := MM
          End
      End;
    Skip_Spaces(S, Ind);
    If (Ind <= S.Length) then
      If (S[Ind] in ['0'..'9']) then
        Get_Year(S, Ind, R_Date)
    End
End;


{ ############################## }

Procedure Pars_RDOW(S: String; Var Ind: Integer; Sign: Char; N: Integer;
		Var R_Date: D_Type);
Var
  MM, Save_N: Integer;
  DI: DOW_Type;
  Month_Start, Month_End: D_Type;
  Same_Month, Good: Boolean;

Begin
  If Ind <= S.Length then
    If S[Ind] = ':' then
      Ind := Ind+1;
  DI := Mat_DOW(S, Ind, Good);	{ Converts WKD to Weekday }
  If Not Good then
    Error(5)
  else
    { #P Should rangecheck case [Sunday..Everyday] }
    Case DI of
      { I sure wish Pascal would allow Sunday..Saturday, Weekday }
      Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday,
      Weekday: Begin
        MM := Get_Month(S, Ind);
        If MM > 0 then
          R_Date.Month := MM;
        Skip_Spaces(S, Ind);
        If Ind <= S.Length then
          If S[Ind] in ['0'..'9'] then	{ May be + or - }
            Get_Year(S, Ind, R_Date);
        Month_Start := R_Date;
        Month_Start.Day := 1;
        Month_End := R_Date;
        Month_End.Day := 31;
        Save_N := N;
        Same_Month := (R_Date.Day = 0);
        Repeat
          Find_DOW(DI, R_Date, Sign, N);{ get the next date that matches DI }
					{ If N=0 return same date if match else +7 }
          If Same_Month then		{ N:DOW must stay in month specified }
            If Not LE_Date(R_Date, Month_End) then Begin { Gone past end of month }
              Offset_Date(R_Date, -7);	{ Stay in this month }
		{ The doc says 9:DOW but all >5 point to last DOW }
              If Save_N = 5 then	{ 3.7 - If we're not 'last dow' (9) }
                R_Date.Day := -1	{ Flag 'not a date' e.g. 5th monday }
              else			{ in a month with only 4 mondays }
                N := 0
              End
            else If Not GE_Date(R_Date, Month_Start) then Begin
              Offset_Date(R_Date, 7);	{ Stay in this month }
              N := 0
              End;
          N := N-1
        Until N <= 0;
        End;
      Tomorrow: Offset_Date(R_Date, 1);
      Yesterday: Offset_Date(R_Date, -1);
      Today, Everyday: { Just return R_Date }
    End { Case }
End; { Pars_RDOW }


{ ############################## }

Procedure Pars_NDOW(S: String; Var Ind: Integer; N: Integer; Var R_Date: D_Type);
Begin
  If N > 0 then R_Date.Day := 0;	{ If abs DOW start before the 1st of the month }
  Pars_RDOW(S, Ind, '+', N, R_Date)
End;


{ ############################## }

{ Parse Parse_Line (PL) returning the appropriate date in R_Date,
  using W_Date as 'today' for relative dating }
{ This is about the trickiest procedure of the whole program.
  Formats accepted are:
  MM/DD/YY
  MM/DD
  MM-DD-YY
  MMM DD YY
  DD MMM YY
  +nn
  -nn
  n:DOW	 (for nth DOW of this month n=9 means DOW in last week of the month)
	 (DOW=monday, tuesday, wednesday, thursday, friday, saturday, sunday,
	      today, yesterday, tomorrow, weekday, everyday
	      or a unique abbreviation )
  +n:DOW
  -n:DOW
  +DOW
  -DOW
  and of course all these can be combined:
  5 june 86 +3:tue is the third tuesday after 6/5/86
}

[Global] Function Parse_Date(PL: String; W_Date: D_Type; Var R_Date: D_Type): Boolean;
Var
  Ind, Sav_Ind: Integer;
  PState: (Alpha, Num, Rel, Unk);
  Rel_Sign: Char;
  Wnum: Integer;
  Got_Num: Boolean;

Begin
  Parse_Result := True;
  R_Date := W_Date;	{ all fields default to the work date }
  PS_Up_Case(PL);
  Ind := 1;		{ Start of the string }
  While Ind <= PL.Length do Begin
    Skip_Spaces(PL, Ind);
    PState := Unk;		{ Default unknown }
    If (Ind <= PL.Length) then
      If PL[Ind] in ['+', '-'] then  { relative date }
        PState := Rel
      else If PL[Ind] in ['A'..'Z'] then { Month or DOW }
        PState := Alpha
      else If PL[Ind] in ['0'..'9'] then { some sort of numeric date }
        Pstate := Num;

    Case PState of
      Unk: Begin
        Error(1);	{ Turns off Parse_Result }
        Ind := Ind+1
        End; { Case Unk }
      Num: Begin
        Wnum := Get_Num(PL, Ind, Got_Num);	{ get the first number }
        If Wnum > 1000000 then		{ format mmddyyyy }
          PMMDDYY(Wnum, R_Date)
        else If Wnum > 123200 then	{ format yymmdd }
          Pars_YYMMDD(Wnum, R_Date)
        else If Wnum > 10000 then	{ format mmddyy }
          PMMDDYY(Wnum, R_Date)
        else If Wnum > 31 then		{ format mmdd }
          Par_MMDD(Wnum, R_Date)
        else
          If (Ind <= PL.Length) then
            Case PL[Ind] of
              ':': Pars_NDOW(PL, Ind, Wnum, R_Date);	{ n:DOW }
              '/': Par_MSD(PL, Ind, Wnum, R_Date);	{ mm/dd }
              '-', '+': Par_DD(PL, Ind, Wnum, R_Date);	{ mm-dd or dd-mmm }
              ' ': Par_DS(PL, Ind, Wnum, R_Date)	{ dd or dd mmm }
            End { Case }
          else
            Par_DS(PL, Ind, Wnum, R_Date);	{ dd or dd mmm }
        End; { Case PState = Num }

      Rel: Begin
        Rel_Sign := PL[Ind];
        Ind := Ind+1;
        Wnum := Get_Num(PL, Ind, Got_Num);
        If (Ind <= PL.Length) then Begin
          If (PL[Ind] = ':') or (Not Got_Num) then	{ +-n:dow or +-dow }
            Pars_RDOW(PL, Ind, Rel_Sign, Wnum, R_Date)
          End
        else Begin
            If Rel_Sign = '-' then Wnum := -Wnum;
            Offset_Date(R_Date, Wnum)		{ Make relative date }
            End
        End; { Case PState = Rel }

      Alpha: Begin
        Sav_Ind := Ind;
        Wnum := Get_Month(PL, Ind);		{ read the month }
        If Wnum = 0 then Begin			{ not mmm dd }
          Ind := Sav_Ind;			{ Ind is used in the while loop}
          Pars_RDOW(PL, Ind, '+', 0, R_Date)	{ Must be DOW; treat like +DOW }
          End
        else Begin
          R_Date.Month := Wnum;
          Ind := Ind+1;
          R_Date.Day := Get_Num(PL, Ind, Got_Num);
          If R_Date.Day = 0 then R_Date.Day := 1;	{ no day, assume 1st }
          Skip_Spaces(PL, Ind);
          If Ind <= PL.Length then Begin
	    If PL[Ind] = ',' then
              Ind := Ind+1;			{ Allow comma in date }
            Wnum := Get_Num(PL, Ind, Got_Num);
            If Got_Num and (Wnum < 3000) then
              R_Date.Year := WNum
            End { Ind Still in PL }
          End { else Wnum > 0 }
        End { Case PState = Alpha }
      End { Case }
    End; { While characters left in PL }
  Parse_Date := Parse_Result and Check_Date(R_Date)
End; { Parse_Date }


{ ############################## }
{ Convert Date/Time into form Monday, January 1, 1984 }

[Global] Procedure PS_Date(T_Date: D_Type; Var D_Date: String);
Begin
  D_Date :=  DOW_Table[Get_DOW(T_Date)] + ', '  + Month_Table[T_Date.Month] + ' ';
  Int_Concat(D_Date, T_Date.Day);
  D_Date := D_Date + ', ';
  Int_Concat(D_Date, T_Date.Year)
End; { PS_Date }


Procedure Display_Weeks(Month: Integer);
Var
  Ind, Ind2, Left, Right, Line: Integer;

Begin
  For Ind := 0 to 3 do Begin
    If Ind > 0 then Write1('  ');
    Right := (18 - Month_Table[Month+Ind].Length) DIV 2;
    Left := 18 - Month_Table[Month+Ind].Length - Right;
    For Ind2 := 1 to Left do Write1(' ');
    Write1(Month_Table[Month+Ind]);
    For Ind2 := 1 to Right do Write1(' ')
    End;
  Writeln1('');
  For Ind := 0 to 3 do Begin
    If Ind > 0 then Write1('  ');
    Write1('  M  T  W Th  F  S')
    End;
  Writeln1('');
  Line := 0;
  While Find_Member(Perp_Array[Line], ['0'..'9']) > 0 do Begin
    Writeln1(Perp_Array[Line]);
    Line := Line + 1
    End
End; { Display_Weeks }


Procedure Perp_Day(JD, Group: Integer; Var Line: Integer);
Var
  DOW, Pos: Integer;
  R_Date: D_Type;

Begin
  DOW := ((JD + 2) MOD 7);
  Get_N_Date(R_Date, JD);
  If DOW > 0 then Begin		{ Cast out Sundays }
    DOW := DOW-1;
    Pos := DOW*3 + Group*20 + 1;
  { Line := (Start_DOW+R_Date.Day-1) DIV 7; Unfortunately, this breaks October 1582 }
    Perp_Array[Line, Pos+2] := Chr((R_Date.Day MOD 10) + Ord('0'));
    If R_Date.Day > 9 then Perp_Array[Line, Pos+1] := Chr((R_Date.Day DIV 10) + Ord('0'));
    If DOW = 5 then Line := Line + 1
    End
End; { Perp_Day }


Procedure Perp_Month(Month, Year, Group: Integer);
Var
  Ind, Start_JD, End_JD, Line: Integer;
  Start_Date, End_Date: D_Type;

Begin
  Start_Date.Day := 1;
  Start_Date.Month := Month + Group;
  Start_Date.Year := Year;
  End_Date.Day := 1;
  If (Month + Group) < 12 then Begin
    End_Date.Month := Month + Group + 1;
    End_Date.Year := Year
    End
  else Begin
    End_Date.Month := 1;
    End_Date.Year := Year + 1
    End;
  Start_JD := Get_J_Date(Start_Date);
  End_JD := Get_J_Date(End_Date) - 1;
  Line := 0;
  For Ind := Start_JD to End_JD do
    Perp_Day(Ind, Group, Line)
End; { Perp_Month }


{ Print four months }
Procedure Perp_Four_Months(Month, Year: Integer);
Var
  Max_Weeks, WPM, Ind, Ind2: Integer;

Begin
  Max_Weeks := 0;
  For Ind := 0 to 6 do
    For Ind2 := 1 to 80 do
      Perp_Array[Ind, Ind2] := ' ';
  For Ind := 0 to 3 do
    Perp_Month(Month, Year, Ind);
  Display_Weeks(Month)
End; { Perp_Months }


{ ############################## }
{ Display a perpetual calendar }
[Global] Procedure Do_Perpetual(Year: Integer);
Begin
  Perp_Four_Months(1, Year);	{ Jan, Feb, Mar, Apr }
  Perp_Four_Months(5, Year);	{ May, Jun, Jul, Aug }
  Perp_Four_Months(9, Year)	{ Sep, Oct, Nov, Dec }
End;

End. { Do_Perpetual }