Topspeed_JPI/TS-V3/MODBASE/DATEFUNC.MOD

IMPLEMENTATION MODULE DateFunctions;
(*
 *  REPERTOIRE
 *  Release 1.6
 *  By Charles Bradford and Cole Brecheen
 *  (c) Copyright 1985-1992 PMI
 *  Green Bay, WI
 *  All rights reserved
 *  (414) 468=6040
 *
 *  $Header:   D:/logfiles/mods/datefunc.mov   1.4   17 Mar 1991 17:53:06   coleb  $
 *
 *)


(*EntryDiag:
IMPORT Diagnostics;
:EntryDiag*)

IMPORT M2Strings;
IMPORT PosUtils;
IMPORT StrConv;
IMPORT StrEdit;

VAR
  Initialized : BOOLEAN;

TYPE
  RepType = (DB, US, UK, USMilitary, Correspondence);


VAR
  monthtotal: ARRAY [1..12] OF CARDINAL;
  monthtotalleap : ARRAY[1..12] OF CARDINAL;
  monthsize: ARRAY [1..12] OF CARDINAL;


PROCEDURE InitMonthTotal;
  BEGIN
    monthtotal[1] := 0;       monthtotalleap[1]  := 0;
    monthtotal[2] := 31;      monthtotalleap[2]  := 31;
    monthtotal[3] := 59;      monthtotalleap[3]  := 60;
    monthtotal[4] := 90;      monthtotalleap[4]  := 91;
    monthtotal[5] := 120;     monthtotalleap[5]  := 121;
    monthtotal[6] := 151;     monthtotalleap[6]  := 152;
    monthtotal[7] := 181;     monthtotalleap[7]  := 182;
    monthtotal[8] := 212;     monthtotalleap[8]  := 213;
    monthtotal[9] := 243;     monthtotalleap[9]  := 244;
    monthtotal[10] := 273;    monthtotalleap[10] := 274;
    monthtotal[11] := 304;    monthtotalleap[11] := 305;
    monthtotal[12] := 334;    monthtotalleap[12] := 335;
  END InitMonthTotal;

(*
PROCEDURE DateToStr2(d: Date; VAR s: ARRAY OF CHAR;
    representation: RepType);
  VAR daystr, mostr: ARRAY [0..1] OF CHAR;
      yrstr: ARRAY [0..3] OF CHAR;

  BEGIN
  END DateToStr2;
*)


PROCEDURE DateToStr(d: Date; VAR s: ARRAY OF CHAR; VAR OK: BOOLEAN);

  VAR i: CARDINAL;

  PROCEDURE PutDigits(n: CARDINAL);
    BEGIN
      IF n < 10 THEN
        s[i] := '0';
        INC(i);
        s[i] := CHR(n + 48);
        INC(i);
      ELSE
          n := n MOD 100;
          s[i] := CHR((n DIV 10) + 48);
          INC(i);
          s[i] := CHR((n MOD 10) + 48);
          INC(i);
      END;
    END PutDigits;

  BEGIN
    IF (HIGH(s) < 7) OR (NOT ValidDate(d))THEN
      OK := FALSE;
      FOR i := 0 TO HIGH(s) DO
        s[i] := '*';
      END;
    ELSE
      OK := TRUE;
      i := 0;
      PutDigits(d.mo);
      s[i] := '-';
      INC(i);
      PutDigits(d.day);
      s[i] := '-';
      INC(i);
      PutDigits(d.yr-1900);
      IF HIGH(s) > 8 THEN
        s[i] := 0C;
      END;
    END;
  END DateToStr;


  PROCEDURE Digit(c : CHAR) : BOOLEAN;
    BEGIN
      RETURN (c>='0') AND (c<='9');
    END Digit;

PROCEDURE StrToDate(s: ARRAY OF CHAR; VAR d: Date; VAR OK: BOOLEAN);
  (* expects mm dd yy *)
  VAR i, yeardigits: CARDINAL;
  BEGIN
    i := 0;
    WHILE (i <= HIGH(s)) AND (NOT Digit(s[i])) DO
      INC(i)
    END;
    d.mo := 0; d.yr := 0; d.day := 0;
    WHILE (i <= HIGH(s)) AND (Digit(s[i])) DO
      d.mo := d.mo * 10 + (ORD(s[i])-48);
      INC(i);
    END;
    INC(i);
    WHILE (i <= HIGH(s)) AND (Digit(s[i])) DO
      d.day := d.day * 10 + (ORD(s[i])-48);
      INC(i);
    END;
    INC(i);
    yeardigits := 0;
    WHILE (i <= HIGH(s)) AND (Digit(s[i])) DO
      d.yr := d.yr * 10 + (ORD(s[i])-48);
      INC(i);
      INC(yeardigits);
    END;
    IF yeardigits <= 2 THEN
      IF d.yr<40
      THEN
        INC(d.yr,2000);
      ELSE
        INC(d.yr, 1900);
      END;
    END;
    IF NOT ValidDate(d) THEN
      d.yr := 0; d.mo := 0; d.day := 0;
      OK := FALSE
    ELSE
      OK := TRUE;
    END;
  END StrToDate;


  PROCEDURE StrToDate2( DateStr: ARRAY OF CHAR; EuropeanStyle: BOOLEAN;
      VAR day, month, year: CARDINAL ): BOOLEAN;
    VAR
      spot: CARDINAL;
      separator: ARRAY [0..0] OF CHAR;
    BEGIN
      StrEdit.CrunchBlanks( DateStr );
      separator[0] := '/';
      IF NOT PosUtils.PresentPos( separator, DateStr, spot ) THEN
        separator[0] := '-';
        IF NOT PosUtils.PresentPos( separator, DateStr, spot ) THEN
          separator[0] := ':';
          IF NOT PosUtils.PresentPos( separator, DateStr, spot ) THEN
            separator[0] := ' ';
            IF NOT PosUtils.PresentPos( separator, DateStr, spot ) THEN
              RETURN FALSE;
            END;
          END;
        END;
      END;
      IF NOT StrConv.StrToCardinal( DateStr, 0, day ) THEN
        RETURN FALSE;
      END;
      IF NOT StrConv.StrToCardinal( DateStr, spot + 1, month ) THEN
        RETURN FALSE;
      END;
      IF (month > 12) OR (NOT EuropeanStyle) THEN
        (* use year as a temp to do swap *)
        year := day;
        day := month;
        month := year;
      END;
      spot := PosUtils.Positn( separator, DateStr, spot + 1 );
      IF spot > HIGH(DateStr) THEN
        RETURN FALSE;
      END;
      IF NOT StrConv.StrToCardinal( DateStr, spot + 1, year ) THEN
        RETURN FALSE;
      END;
      RETURN TRUE;
    END StrToDate2;


PROCEDURE Day(d: Date): CARDINAL;
  BEGIN
    IF ValidDate(d) THEN
      RETURN d.day
    ELSE
      RETURN 0
    END;
  END Day;


PROCEDURE LeapYear(year: CARDINAL): BOOLEAN;
  BEGIN
    RETURN ((year MOD 4 = 0) AND (year MOD 100 # 0)) OR (year MOD 400 = 0)
  END LeapYear;


PROCEDURE DayOfWeek(d: Date; VAR wkday: ARRAY OF CHAR);
  VAR
    daytable: ARRAY [1..12] OF CARDINAL;
    centurytable: ARRAY [1..5] OF CARDINAL;
    century, yearincent, result, i: CARDINAL;

  PROCEDURE InitCent;
    BEGIN
      centurytable[1] := 1;
      centurytable[2] := 2;
      centurytable[3] := 0;
      centurytable[4] := 6;
      centurytable[5] := 4;
    END InitCent;

  PROCEDURE InitDayTable;
    BEGIN
      daytable[1] := 0;
      daytable[2] := 3;
      daytable[3] := 3;
      daytable[4] := 6;
      daytable[5] := 1;
      daytable[6] := 4;
      daytable[7] := 6;
      daytable[8] := 2;
      daytable[9] := 5;
      daytable[10] := 0;
      daytable[11] := 3;
      daytable[12] := 5;
    END InitDayTable;

  BEGIN
    IF ValidDate(d) THEN
      InitDayTable;
      InitCent;
      IF LeapYear(d.yr) THEN
        daytable[1] := 6;
        daytable[2] := 2;
      END;
      century := d.yr DIV 100;
      yearincent := d.yr - century*100;
      result := centurytable[century-16] + yearincent +
                (yearincent DIV 4) + daytable[d.mo] + d.day;
  (* NOTE!!! the above configuration is only likely to be accurate
             for 20th & 21st century *)
      CASE result MOD 7 OF
          0: M2Strings.Copy("Sunday", 0, HIGH(wkday), wkday);
        | 1: M2Strings.Copy("Monday", 0, HIGH(wkday), wkday);
        | 2: M2Strings.Copy("Tuesday", 0, HIGH(wkday), wkday);
        | 3: M2Strings.Copy("Wednesday", 0, HIGH(wkday), wkday);
        | 4: M2Strings.Copy("Thursday", 0, HIGH(wkday), wkday);
        | 5: M2Strings.Copy("Friday", 0, HIGH(wkday), wkday);
        | 6: M2Strings.Copy("Saturday", 0, HIGH(wkday), wkday);
      END; (* case*)
    ELSE
      FOR i := 0 TO HIGH(wkday) DO
        wkday[i] := '*'
      END;
    END;
  END DayOfWeek;

PROCEDURE Month(d: Date): CARDINAL;
  BEGIN
    IF ValidDate(d) THEN
      RETURN d.mo
    ELSE
      RETURN 0
    END;
  END Month;

PROCEDURE CalendarMonth(d: Date; VAR cmonth: ARRAY OF CHAR);
  BEGIN
    IF ValidDate(d) THEN
      CASE d.mo OF
          1: M2Strings.Copy('January', 0, 9, cmonth);
        | 2: M2Strings.Copy('February', 0, 9, cmonth);
        | 3: M2Strings.Copy('March', 0, 9, cmonth);
        | 4: M2Strings.Copy('April', 0, 9, cmonth);
        | 5: M2Strings.Copy('May', 0, 9, cmonth);
        | 6: M2Strings.Copy('June', 0, 9, cmonth);
        | 7: M2Strings.Copy('July', 0, 9, cmonth);
        | 8: M2Strings.Copy('August', 0, 9, cmonth);
        | 9: M2Strings.Copy('September', 0, 9, cmonth);
        | 10: M2Strings.Copy('October', 0, 9, cmonth);
        | 11: M2Strings.Copy('November', 0, 9, cmonth);
        | 12: M2Strings.Copy('December', 0, 9, cmonth);
      END; (* case *)
    ELSE
      M2Strings.Copy('********',0, 8, cmonth);
    END;
  END CalendarMonth;


PROCEDURE Year(d: Date): CARDINAL;
  BEGIN
    IF ValidDate(d) THEN
      RETURN (d.yr)
    ELSE
      RETURN 0
    END;
  END Year;


PROCEDURE DateToWritten(d: Date; VAR written: ARRAY OF CHAR);
  VAR
    temp: ARRAY [0..4] OF CHAR;
  BEGIN
    CalendarMonth(d, written);
    M2Strings.Concat(written, ' ', written);
    StrConv.CardinalToStr(d.day, 0, temp);
    M2Strings.Concat(written, temp, written);
    M2Strings.Concat(written, ', ', written);
    StrConv.CardinalToStr(d.yr, 0, temp);
    M2Strings.Concat(written, temp, written);
  END DateToWritten;


PROCEDURE DatePlusDays(VAR d: Date; days: CARDINAL; VAR OK: BOOLEAN);
  BEGIN
    IF NOT ValidDate(d) THEN
      WITH d DO
        yr := 0;
        mo := 0;
        day := 0;
      END;
      OK := FALSE
    ELSE
      CardToDate(DaysSince1900(d) + days, d);
      OK := TRUE
    END;
  END DatePlusDays;


PROCEDURE InitMonths;
  BEGIN
    monthsize[1] := 31;
    monthsize[2] := 28;
    monthsize[3] := 31;
    monthsize[4] := 30;
    monthsize[5] := 31;
    monthsize[6] := 30;
    monthsize[7] := 31;
    monthsize[8] := 31;
    monthsize[9] := 30;
    monthsize[10] := 31;
    monthsize[11] := 30;
    monthsize[12] := 31;
  END InitMonths;


PROCEDURE ValidDate(d: Date): BOOLEAN;

  BEGIN
    IF LeapYear(d.yr)THEN
      monthsize[2] := 29;
    ELSE
      monthsize[2] := 28;
    END;
    RETURN((d.mo >= 1) AND (d.mo <= 12)) AND
           ((d.day >=1) AND (d.day <= monthsize[d.mo])) AND
           ((d.yr >= MinYear) AND (d.yr <= MaxYear));
  END ValidDate;


PROCEDURE DaysSince1900(d: Date): CARDINAL;
  VAR
    yearsSince, leapYearsSince, result: CARDINAL;
  BEGIN
    IF ValidDate(d) THEN
      yearsSince := (d.yr - 1900) * 365;
      result:=d.yr-1900;
      IF result>1 THEN DEC(result) END;
      leapYearsSince := (result) DIV 4;
      result := yearsSince + leapYearsSince + DayOfYear(d)-1;
      (* IF LeapYear(d.yr) AND (d.mo > 2) THEN
        INC( result );
      END; *)
      RETURN result
    ELSE
      RETURN 0
    END;
  END DaysSince1900;


PROCEDURE DayOfYear(d:Date): CARDINAL;
  (* Returns 0 if the date is not Valid *)
VAR julian: CARDINAL;

BEGIN
  IF ValidDate(d) THEN
    IF LeapYear(d.yr) AND (d.mo > 2) THEN
      julian := monthtotalleap[d.mo] + d.day;
    ELSE
     julian := monthtotal[d.mo] + d.day;
    END;
    RETURN julian
  ELSE
    RETURN 0
  END;
END DayOfYear;

PROCEDURE CardToDate(n: CARDINAL; VAR d: Date);
VAR julday,
    c,LeapYears: CARDINAL;
BEGIN
  d.yr := n DIV 365;
  julday:= n MOD 365+1;
  c:=d.yr;
  IF c >1 THEN DEC(c) END;
  LeapYears:= c DIV 4;(* leap years is to count preceding not current *)
  IF (julday > LeapYears) THEN
    DEC(julday,LeapYears)
  ELSE
    julday:=julday+365-LeapYears;
    DEC(d.yr);
    IF( d.yr#0) AND ((d.yr MOD 4) =0)
    THEN
      INC(julday);(* do not want to count leap day twice *)
    END;
  END;
  d.yr := d.yr + 1900;
  d.mo := 0;
  d.day := 0;
  IF NOT LeapYear(d.yr) THEN
   (* DEC (julday);*)
       REPEAT
      INC(d.mo)
    UNTIL  (d.mo = 12) OR (julday <= monthtotal[d.mo + 1]);
      d.day := julday - monthtotal[d.mo];
  ELSE
    REPEAT
      INC(d.mo)
    UNTIL  (d.mo = 12) OR (julday <= monthtotalleap[d.mo + 1]);
      (* note:  can't just add 1 -- it throws January off!! *)
    d.day := julday - (monthtotalleap[d.mo]);
  END;
END CardToDate;


PROCEDURE CompareDates(d1, d2: Date): Comparison;
  BEGIN
    IF d1.yr > d2.yr THEN
      RETURN DateGreater
    ELSIF d1.yr < d2.yr THEN
      RETURN DateLess
    ELSE
      IF d1.mo > d2.mo THEN
        RETURN DateGreater
      ELSIF d1.mo < d2.mo THEN
        RETURN DateLess
      ELSE
        IF d1.day > d2.day THEN
          RETURN DateGreater
        ELSIF d1.day < d2.day THEN
          RETURN DateLess
        ELSE
          RETURN DateEqual
        END;
      END;
    END;
    RETURN DateEqual;
  END CompareDates;


PROCEDURE DateDiff(d1, d2: Date): CARDINAL;
  BEGIN
    IF CompareDates(d1, d2) = DateGreater THEN
      RETURN(DaysSince1900(d1) - DaysSince1900(d2))
    ELSE
      RETURN(DaysSince1900(d2) - DaysSince1900(d1))
    END;
  END DateDiff;


  PROCEDURE Init();
    BEGIN
      IF Initialized THEN
        RETURN;
      ELSE
        Initialized := TRUE;
      END;
(*EntryDiag:
      Diagnostics.Init();
:EntryDiag*)
      M2Strings.Init();
      PosUtils.Init();
      StrConv.Init();
      StrEdit.Init();
(*EntryDiag:
      Diagnostics.diagS( 'Entering DateFunctions', '' );
:EntryDiag*)

      InitMonthTotal();
      InitMonths();

(*EntryDiag:
      Diagnostics.diagS( 'Exiting DateFunctions', '' );
:EntryDiag*)
    END Init;


BEGIN
  Initialized := FALSE;
  Init();
END DateFunctions.