MODULE CALCAL;

{by Ed Reed
    Tailored Computer Solutions
    1919 S. Newport
    Kennewick, WA 99336        }
    
{This module is designed to convert dates from a mmddyy character format to
 an integer which is increased by one for each day.  Day One as written is
 January 1, 1961, which can be changed to suit by changing the FIRST_YR
 constant.  If a change is made, the array of days in the week will have to
 be adjusted to start with the appropriate day or a suitable offset added
 before using MOD to determine day of week.  The module also includes, as a
 comment, a well-butchered piece of a program which illustrates the use of
 the routines involved.  If illegal dates are input, CALDAY will return a
 zero and CALEND will return blanks.  (If FIRST_YR is changed, note that 1900
 was not a leap year but 2000 is.)  The range of acceptable dates is about 89
 years; 32767 days, to be exact.}

CONST

  FIRST_YR  = 61;
  ZERO      = 48;
  DUBL_ZERO = 528;
  
TYPE

  IDATE  = ARRAY [1 ..  6] OF CHAR;
  TWELVE = ARRAY [1 .. 12] OF INTEGER;
  DAZE   = ARRAY [0 ..  6] OF STRING[9];
  MUNTZ  = ARRAY [1 .. 12] OF STRING[9];

PROCEDURE MOLEN;

BEGIN   {Lengths of months.}

  INLINE ($1F / $00 /  {31}
          $1C / $00 /  {28}
          $1F / $00 /  {31}
          $1E / $00 /  {30}
          $1F / $00 /  {31}
          $1E / $00 /  {30}
          $1F / $00 /  {31}
          $1F / $00 /  {31}
          $1E / $00 /  {30}
          $1F / $00 /  {31}
          $1E / $00 /  {30}
          $1F / $00 )  {31}

END;


PROCEDURE PRIOR;

BEGIN   {Number of days in year prior to the first of the month.}

  INLINE ($00 / $00 /  {  0}
          $1F / $00 /  { 31}
          $3B / $00 /  { 59}
          $5A / $00 /  { 90}
          $78 / $00 /  {120}
          $97 / $00 /  {151}
          $B5 / $00 /  {181}
          $D4 / $00 /  {212}
          $F3 / $00 /  {243}
          $11 / $01 /  {273}
          $30 / $01 /  {304}
          $4E / $01 )  {334}

END;


PROCEDURE CALDAY (DATE : IDATE; VAR DAY : INTEGER);

{Tthis procedure calculates a serial date from a calendar date.}
{Day One is January 1, 1961.}

VAR

  MO, DA, YR, XR, LEN : INTEGER;
  LE : ^TWELVE;
  AC : ^TWELVE;

BEGIN

  LE := ADDR (MOLEN);
  AC := ADDR (PRIOR);
  DAY := 0;
{Test input for all numeric.}
  FOR LEN := 1 TO 6 DO
    IF NOT (DATE[LEN] IN ['0' .. '9']) THEN EXIT;
{Convert month, day, and year to integer.}
  MO := ORD (DATE[1]) * 10 + ORD (DATE[2]) - DUBL_ZERO;
  DA := ORD (DATE[3]) * 10 + ORD (DATE[4]) - DUBL_ZERO;
  YR := ORD (DATE[5]) * 10 + ORD (DATE[6]) - DUBL_ZERO;
{Test for valid month and day.}
  IF (MO < 1) OR (MO > 12) OR (DA < 1) THEN EXIT;
  LEN := LE^[MO];
  IF (MO = 2) AND (YR MOD 4 = 0) THEN LEN := 29;
  IF (DA > LEN) THEN EXIT;
{Allow for the coming of the next century.}
  IF YR < FIRST_YR THEN YR := YR + 100;
{Convert year from absolute to relative.}
  XR := YR - FIRST_YR;
{Calculate day.}
  DAY := 365 * XR  +  XR DIV 4  +  AC^[MO]  +  DA;
{Allow for leap year.}
  IF (YR MOD 4 = 0) AND (MO > 2) THEN DAY := DAY + 1;

END;

PROCEDURE CALEND (DAY : INTEGER; VAR DATE : IDATE);

{This procedure accepts a serial date generated
 by CALDAY and converts it back.}

VAR

  MO, DA, YR, QUAD : INTEGER;
  LE : ^TWELVE;
  
BEGIN

  IF DAY < 1 THEN
    BEGIN
      FILLCHAR (DATE, 6, ' ');
      EXIT
    END;
  LE := ADDR (MOLEN);
{Knock off 1 because output from MOD starts at zero.}
  DA   := DAY - 1;
{Calculate date in multiples of four years.}
  QUAD := DA DIV 1461;
  DA   := DA MOD 1461;
  IF DA = 1154 THEN
{Handle leap day.}
    BEGIN
      MO := 2;
      DA := 29;
      YR := 3;
    END
  ELSE
    BEGIN
{Adjust leap year after leap day.}
      IF DA > 1154 THEN DA := DA - 1;
{Calculate year (0 to 3), month, and day.}
      YR := DA DIV 365;
      DA := DA - (YR * 365) + 1;   {Put the 1 back.}
      MO := 1;
      WHILE DA > LE^[MO] DO
        BEGIN
          DA := DA - LE^[MO];
          MO := MO + 1
        END;
    END;
{Calculate absolute year.}
  YR := YR + (QUAD * 4) + FIRST_YR;
  IF YR > 99 THEN YR := YR - 100;
{Convert to character string.}
  DATE[1] := CHR ((MO DIV 10) + ZERO);
  DATE[2] := CHR ((MO MOD 10) + ZERO);
  DATE[3] := CHR ((DA DIV 10) + ZERO);
  DATE[4] := CHR ((DA MOD 10) + ZERO);
  DATE[5] := CHR ((YR DIV 10) + ZERO);
  DATE[6] := CHR ((YR MOD 10) + ZERO);

END; 


PROCEDURE WEEK;

BEGIN    {Days of the week}

  INLINE ($08 / 'SATURDAY ' /
          $06 / 'SUNDAY   ' /
          $06 / 'MONDAY   ' /
          $07 / 'TUESDAY  ' /
          $09 / 'WEDNESDAY' /
          $08 / 'THURDSAY ' /
          $06 / 'FRIDAY   ' )

END;


PROCEDURE YEAR;

BEGIN    {Months of the year}

  INLINE ($07 / 'JANUARY  ' /
          $08 / 'FEBRUARY ' /
          $05 / 'MARCH    ' /
          $05 / 'APRIL    ' /
          $03 / 'MAY      ' /
          $04 / 'JUNE     ' /
          $04 / 'JULY     ' /
          $06 / 'AUGUST   ' /
          $09 / 'SEPTEMBER' /
          $07 / 'OCTOBER  ' /
          $08 / 'NOVEMBER ' /
          $08 / 'DECEMBER ' )

END;



{      PROCEDURE SETDAT;

These scraps of code illustrate some of the uses of serial date routines.

VAR

  I, J, LEN, NEWDAY, OLDDAY, IDAY, IMON, DMOD : INTEGER;
  GETIT : STRING[9];
  NEWDATE : IDATE;
  MONTHS : ^MUNTZ;
  DAYS : ^DAZE;

BEGIN

  WRITE (HOME, CLEAR);
  CALDAY (TODAY, OLDDAY);
  DMOD := OLDDAY MOD 7;     Determine day of week
  DAYS := ADDR (WEEK);
  MONTHS := ADDR (YEAR);
  IMON := ORD (TODAY[1]) * 10 + ORD (TODAY[2]) - DUBL_ZERO;
  IDAY := ORD (TODAY[3]) * 10 + ORD (TODAY[4]) - DUBL_ZERO;
  WRITELN (HOME, 'THE DATE NOW REORDED IS ', XTODAY, ', ', DAYS^[DMOD],
      ', ', MONTHS^[IMON], ' ', IDAY, ', 19', TODAY[5], TODAY[6]);
  MOVE (GETIT[1], NEWDATE, 6);
  CALDAY (NEWDATE, NEWDAY);
  IF NEWDAY = 0 THEN          Determine validity of date entered from keyboard
    ERRMSG ('BAD MONTH OR DAY');
  IF (NEWDAY < OLDDAY) OR (NEWDAY > OLDDAY + 3) THEN   Find difference
    BEGIN                                              between new date and
      WRITELN ('NEW DATE DIFFERS FROM OLD DATE BY ',   old date and output it.
          NEWDAY - OLDDAY, ' DAYS');
      WRITE ('IS THIS OK (Y or N)? -- ');
  IMON := ORD (TODAY[1]) * 10 + ORD (TODAY[2]) - DUBL_ZERO;
  IDAY := ORD (TODAY[3]) * 10 + ORD (TODAY[4]) - DUBL_ZERO;
  DMOD := NEWDAY MOD 7;
  WRITELN;
  WRITELN ('NEW DATE IS ', XTODAY, ', ', DAYS^[DMOD],
      ', ', MONTHS^[IMON], ' ', IDAY, ', 19', TODAY[5], TODAY[6]);
  WRITELN; WRITE ('PRESS ANY KEY TO CONTINUE');
  READ (OPTION);
END;
                                    }

MODEND.