PROGRAM weekday;

TYPE (* weekday *)
  week_days_type = (MONDAY, TUESDAY, WEDNESDAY, THURSDAY,
                    FRIDAY, SATURDAY, SUNDAY);
  week_type = ARRAY[week_days_type] OF STRING[9];

VAR (* weekday *)
  month,                (* Current month *)
  day,                  (* Current day of month *)
  year : integer;       (* Current year *)
  choice : integer;     (* Menu operation choice selected *)
  days : real;          (* Number of days past a SUNDAY *)
  week_day : week_days_type; (* Answer day of week *)

CONST (* weekday *)
  day_of_week : week_type = ( 'Monday', 'Tuesday', 'Wednesday', 'Thursday',
                              'Friday', 'Saturday', 'Sunday' );

FUNCTION JulianDayNo( mo, day, yr : integer ) : real;

  TYPE (* JulianDayNo *)
    month_type = (nomonth, JANUARY, FEBRUARY, MARCH, APRIL, MAY, JUNE,
                  JULY, AUGUST, SEPTEMBER, OCTOBER, NOVEMBER, DECEMBER);
    month_day_type = ARRAY[month_type] OF integer;
    month_len_type = ARRAY[month_type] OF integer;

  CONST (* JulianDayNo *)
    JulianOffset = 1721425.0;    (* Offset to yield correct Julian # *)
    month_day : month_day_type = ( 0, 0, 31, 59, 90, 120, 151, 181, 212,
                                   243, 273, 304, 334 );
    month_len : month_len_type = ( 0, 31, 28, 31, 30, 31, 30, 31, 31, 30,
                                   31, 30, 31 );

  VAR (* JulianDayNo *)
    days : real;          (* Julian Day Number *)
    leap_year : boolean;  (* Is current year a leap year? *)

  BEGIN (* JulianDayNo *)
    IF ( yr = 0 ) THEN
      mo := 0;            (* Illegal yr value shown by mo val. *)
    IF ( yr > 0 ) THEN    (* B.C. yr is already back one *)
      yr := yr - 1;       (* compute for previous years *)

    (* Compute number of days *)
    days := JulianOffset + day + month_day[month_type(mo)] +
      yr*365.0 + (yr DIV 4) - (yr DIV 100) + (yr DIV 400);

    (* Using THIS year, see if we need to add a leapday *)
    yr := yr + 1;
    leap_year := ((yr MOD 4) = 0) AND
      ( ((yr MOD 100) > 0) OR ((yr MOD 400) = 0) );
    IF ( (month_type(mo) > FEBRUARY) AND (leap_year) ) THEN
      days := days + 1; (* add leapday *)

    IF ( yr <= 0 ) THEN
      BEGIN
        days := days - 1; (* Adjust for B.C. *)
      END;

    IF ( (mo > 0) AND (mo <= 12) AND
         ( (day <= month_len[month_type(mo)]) OR
           ( (leap_year) AND (month_type(mo) = FEBRUARY) AND (day = 29) )
         )
       ) THEN
      JulianDayNo := days (* Return result *)
    ELSE
      JulianDayNo := -1.0 (* Invalid input *)
  END; (* JulianDayNo *)

PROCEDURE GetDate( VAR mo, day, yr : integer );
  TYPE (* GetDate *)
    char_ptr = ^char;
  VAR (* GetDate *)
    date : string[20];
    a : char_ptr;

  PROCEDURE ExtractNum( VAR c : char_ptr; VAR num : integer );
    TYPE (* ExtractNum *)
      numeric_type = SET OF char;
    CONST (* ExtractNum *)
      numeric : numeric_type = ['-', '+', '0'..'9'];
    VAR (* ExtractNum *)
      x : integer;
      negative : boolean;
    BEGIN (* ExtractNum *)
      (*
       * Trim off leading garbage
       *)
      WHILE ( (c^ <> #0) AND NOT(c^ IN numeric) ) DO
        c := Ptr(Ord(c) + 1);

      (*
       * Allow for leading sign character
       *)
      negative := FALSE; (* Assume positive *)
      IF ( (c^ ='-') OR (c^ = '+') ) THEN
        BEGIN
          IF ( c^ = '-' ) THEN
            negative := TRUE;
          c := Ptr(Ord(c) + 1);
        END; (* if *)

      (*
       * Determine & return numeric value.
       *)
      x := 0; (* initialize value *)
      WHILE ( (c^ >= '0') AND (c^ <= '9') ) DO
        BEGIN
          x := x*10 + ord(c^) - ord('0');
          c := Ptr(Ord(c) + 1);
        END; (* while *)
      IF ( negative ) THEN
        x := -x;
      num := x; (* Return numeric value *)
    END; (* ExtractNum *)

  BEGIN (* GetDate *)
    Write('':20, 'Date (MM/DD/YYYY)? ');
    Readln( date );
    date := date + #0; (* Append end of string character *)
    a := Ptr(Addr(date[1])); (* Set to first position of string *)
    ExtractNum( a, month );
    ExtractNum( a, day );
    ExtractNum( a, year );
  END; (* GetDate *)

FUNCTION GetChoice : integer;
VAR (* GetChoice *)
  ch : char;
  choice : integer;
BEGIN (* GetChoice *)
  Writeln;
  ClrScr;
  GotoXY( 32, 5 ); Writeln('Tasks Available');
  GotoXY( 25, 8 ); Writeln('1--Day of the week');
  GotoXY( 25, 10 ); Writeln('2--Days between dates');
  GotoXY( 25, 12 ); Writeln('3--Day of the year');
  GotoXY( 25, 14 ); Writeln('4--Julian Day');
  GotoXY( 25, 16 ); Writeln('5--Exit Program');

  REPEAT (* until valid selection *)
    GotoXY( 21, 20 ); Write('Enter the number of your choice: ');
    REPEAT
      ;
    UNTIL KeyPressed;
    Read( KBD, ch );
    choice := Ord(ch) - Ord('0');
  UNTIL ( (choice > 0) AND (choice <= 5) );
  Writeln;
  ClrScr;
  IF ( choice < 5 ) THEN
    GotoXY( 1, 10 );

  GetChoice := choice;
END; (* GetChoice *)

FUNCTION GetJulianNo : real;
  VAR (* GetJulianNo *)
    days : real;
  BEGIN (* GetJulianNo *)
    REPEAT  (* until inputted date is VALID *)
      GetDate( month, day, year );
      days := JulianDayNo( month, day, year );
    UNTIL ( days >= 0.0 );
    GetJulianNo := days;
  END; (* GetJulianNo *)

FUNCTION ComputeWeekDay( days : real ) : week_days_type;
  VAR (* ComputeWeekDay *)
    dayno : real;
  BEGIN (* ComputeWeekDay *)
    dayno := Frac(days / 7.0) * 7.0 + 0.1;    (* Compute days MOD 7 *)
    ComputeWeekDay := week_days_type( Trunc(dayno) );
  END; (* ComputeWeekDay *)

PROCEDURE DayOfTheWeek;
  VAR (* DayOfTheWeek *)
    days : real;
  BEGIN (* DayOfTheWeek *)
    days := GetJulianNo;
    week_day := ComputeWeekDay( days );
    Writeln;
    Writeln('':14, 'Day of week for ', month:1, '/', day:1, '/', year:1,
      ' is ', day_of_week[week_day]);
    Writeln('':15, 'Julian day number ', days:1:0);
  END; (* DayOfTheWeek *)

PROCEDURE DaysBetweenDays;
  VAR (* DaysBetweenDays *)
    month1,
    day1,
    year1 : integer;
    days1,
    days2 : real;
  BEGIN (* DaysBetweenDays *)
    Writeln('':20, 'Enter the First date.');
    days1 := GetJulianNo;
    month1 := month;
    day1 := day;
    year1 := year;
    Writeln;
    Writeln('':20, 'Enter the Second date.');
    days2 := GetJulianNo;
    Writeln;
    Writeln;
    days2 := Abs(days2 - days1);
    Writeln('':10, 'There are ', days2:1:0, ' days between ',
      month1:1, '/', day1:1, '/', year1:1, ' and ',
      month:1, '/', day:1, '/', year:1);
  END; (* DaysBetweenDays *)

PROCEDURE DayOfYear;
  VAR (* DayOfYear *)
    days1,
    days2 : real;
    dayno : integer;
  BEGIN (* DayOfYear *)
    days1 := GetJulianNo;
    days2 := JulianDayNo( 1, 1, year );
    dayno := Trunc( days1 - days2 + 1.1 );
    Writeln;
    Writeln('':14, month:1, '/', day:1, '/', year:1, ', is day # ', dayno:1);
  END; (* DayOfYear *)

PROCEDURE Pause;
VAR (* Pause *)
  ch : char;
BEGIN (* Pause *)
  GotoXY( 1, 23 );
  Write('Press space bar to continue, ''Q'' to Quit');
  REPEAT
    REPEAT
      ;
    UNTIL KeyPressed;
    Read( KBD, ch );
    IF ( (ch = 'q') OR (ch = 'Q') ) THEN
      Halt;
  UNTIL ( ch = ' ' );
END; (* Pause *)

BEGIN (* weekday *)
  choice := GetChoice;
  WHILE ( choice < 5 ) DO
    BEGIN
      CASE choice OF
        1 : DayOfTheWeek;
        2 : DaysBetweenDays;
        3 : DayOfYear;
        4 : DayOfTheWeek;
      END; (* case *)
      Pause;

      choice := GetChoice;
    END; (* while *)
END. (* weekday *)