home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mod201j.zip / modula2.exe / os2src / datefunc.mod < prev    next >
Text File  |  1996-01-31  |  7KB  |  259 lines
  1. (* PROGRAM NAME : Date functions
  2. * AUTHOR : Johan terryn 
  3. * COPYRIGHT (C) 1995 BY XINIX
  4. * ────────────────────────────────────────────────────────────────────────────
  5. * CREATED : 28/12/1995 *)
  6. IMPLEMENTATION MODULE DateFunctions;
  7.  
  8. FROM OS2DEF      IMPORT APIRET;
  9. FROM DOSDATETIME IMPORT DATETIME, DosGetDateTime;
  10.  
  11. (*
  12. TYPE DATE = RECORD
  13.      day, month, year : CARDINAL;
  14. END;
  15. DateFormat = (EURO, US, ANSI, ISO);
  16. *)
  17.  
  18. (*$XL+*)
  19. CONST dom : ARRAY OF CARDINAL = [31,29,31,30,31,30,31,31,30,31,30,31];
  20. CONST Leap         =     4;  (* Leap years every 4 years *)
  21.       Century      =   100;  (* Years in a century       *)
  22.       QuadCentury  =   400;  (* Years in four centuries  *)
  23.       NormalYear   =   365;  (* Days in a non-leap year  *)
  24.       FirstYear    =  1583;  (* Our first year           *)
  25.       DaysIn4Years =  1461;  (* Including leap day       *)
  26. VAR   Dateformat   : DateFormat;
  27.  
  28. PROCEDURE SetDateFormat(NewFormat: DateFormat) : DateFormat;
  29. (*****************)
  30. VAR OldFormat : DateFormat;
  31. BEGIN
  32.  OldFormat  := Dateformat;
  33.  Dateformat := NewFormat;
  34.  RETURN OldFormat
  35. END SetDateFormat;
  36.  
  37. PROCEDURE Leapyear(year : CARDINAL) : BOOLEAN;
  38. (*****************)
  39. (* OK 28/12/1995 *)
  40. BEGIN
  41.  RETURN ((year MOD 4 = 0) AND (year MOD 100 > 0)) OR (year MOD 400 = 0); 
  42. END Leapyear;
  43.  
  44. PROCEDURE ToDay(): DATE;
  45. (******************)
  46. VAR DateTime : DATETIME;
  47.     rc       : APIRET;
  48.     Date     : DATE;
  49. BEGIN
  50.   rc := DosGetDateTime (DateTime);
  51.   Date.year  := DateTime.year;
  52.   Date.month := DateTime.month;
  53.   Date.day   := DateTime.day;  
  54.   RETURN (Date);
  55. END  ToDay;
  56.  
  57. PROCEDURE ValidDate(date : DATE) : BOOLEAN;
  58. (*****************)
  59. (* 25/12/1995 verified, tested and OK *)
  60. BEGIN
  61.    IF date.year >= FirstYear  THEN
  62.     IF date.month IN {1,2,3,4,5,6,7,8,9,10,11,12} THEN
  63.       IF (date.day > 0) AND (date.day <= dom[date.month-1]) THEN
  64.         IF (date.day = 29) AND (date.month = 2) AND NOT Leapyear(date.year)  THEN 
  65.           RETURN FALSE
  66.         ELSE  
  67.           RETURN TRUE
  68.         END (* if *)
  69.       END (* if *)
  70.     END (* if *)
  71.   END (* if *);
  72.   done := FALSE;
  73.   RETURN FALSE
  74. END ValidDate;
  75.  
  76. PROCEDURE LeapDays(FromYear,ToYear: CARDINAL):CARDINAL;
  77. (*****************)
  78. (* tested 31/12/1995 *)
  79. VAR days,i :CARDINAL;
  80.  
  81. BEGIN
  82.  days := 0;
  83.  FOR  i := FromYear TO ToYear DO
  84.    IF Leapyear(i) THEN
  85.      INC(days)
  86.    END
  87.  END;
  88.  RETURN days
  89. END LeapDays;
  90.      
  91. PROCEDURE Date2Num(date: DATE):LONGCARD;
  92. (*****************)
  93. (* tested 31/12/1995 *)
  94. VAR month         : CARDINAL;
  95.     yeardays, days: LONGCARD;
  96. BEGIN
  97.   IF ValidDate(date) THEN
  98.     days     := date.day;
  99.     yeardays := LONGCARD( date.year - FirstYear ) * NormalYear + LONGCARD( LeapDays(FirstYear,date.year-1) );
  100.     IF (date.month > 2) AND NOT Leapyear(date.year) THEN
  101.       DEC(days)
  102.     END; (* if *)
  103.     FOR month := 1 TO date.month-1 DO
  104.       INC(days,dom[month-1]);
  105.     END; (* while *)
  106.     done := TRUE; 
  107.     RETURN days + yeardays
  108.   ELSE
  109.     done := FALSE;
  110.     RETURN 0 
  111.   END (* if *)
  112. END Date2Num;
  113.  
  114. PROCEDURE Num2Date(num : LONGCARD):DATE;
  115. (*****************)
  116. (* tested 31/12/1995 *)
  117. VAR Dom  : ARRAY [0..12] OF CARDINAL; 
  118.     i    : CARDINAL;
  119.     Refdate,Date : DATE;
  120.     leapdays : CARDINAL;
  121. BEGIN
  122.   FOR i := 0 TO HIGH(Dom)-1 DO
  123.     Dom[i] := dom[i];
  124.   END; 
  125.   IF (num = 0) THEN
  126.     Date.year     := FirstYear - 1;
  127.     Date.month    := 12;
  128.     Date.day      := dom[Date.month-1];
  129.   ELSE
  130.     Date.year     := CARDINAL (((Leap * (LONGINT (num) - 1)) DIV DaysIn4Years) + FirstYear);
  131.     Date.month    := 1;
  132.     Refdate.year  := Date.year;
  133.     Refdate.month := 1;
  134.     Refdate.day   := 1;
  135.     Date.day      := CARDINAL (LONGINT (num) - LONGINT (Date2Num(Refdate)-1));
  136.     IF NOT Leapyear(Date.year) THEN
  137.       Dom[1] := 28
  138.     END;
  139.     WHILE Date.day > Dom[Date.month-1] DO
  140.       DEC (Date.day, Dom[Date.month-1]);
  141.       INC(Date.month)
  142.     END;
  143.     IF Date.month > 12 THEN
  144.       Date.month := Date.month - 12;
  145.       INC(Date.year)
  146.     END 
  147.   END;
  148.   RETURN Date
  149. END Num2Date;
  150.  
  151. PROCEDURE DayOfWeek(date : DATE) : CARDINAL;
  152. (*****************)
  153. (*25/12/1995 returns day of the week as a number, ISO (monday = 1, sunday = 7)  verified , tested and OK  valid from 01/01/1583*)
  154. BEGIN
  155.   RETURN CARDINAL((Date2Num(date) -3) MOD 7)+1
  156. END DayOfWeek;
  157.  
  158. PROCEDURE Easter(Year : CARDINAL) : DATE;
  159. (***************)
  160. (* tested and OK *)
  161. (*Easter : Spencer Jones in General Astronomy (pg 73-74) Ed 1922
  162.  * Journal of the British Astronomical Association Vol. 88, pg. 91 (dec 1977)
  163.  * From original dated 1876 Butcher's Eclesiastical Calendar.
  164.  * No exceptions, valid from 1583 *)       
  165. VAR a,b,c,d,e,f,g,h,i,k,l,m,n,p : CARDINAL;
  166.       Date : DATE;
  167. BEGIN
  168. IF Year >= FirstYear THEN
  169.   a := Year MOD 19;   (* Lunar cycle = 19 years, Full moon on January 1st AD 0000*)
  170.   b := Year DIV 100;
  171.   c := Year MOD 100;
  172.   d := b DIV 4;
  173.   e := b MOD 4;
  174.   f := (b + 8) DIV 25;
  175.   g := (b - f + 1)DIV 3;
  176.   h := (19 * a + b - d - g + 15) MOD 30;
  177.   i := c DIV 4;
  178.   k := c MOD 4;
  179.   l := (32 + 2 * e + 2 * i - h - k) MOD 7;
  180.   m := (a + 11 * h + 22 * l) DIV 451;
  181.   n := (h + l - 7 * m + 114) DIV 31 ;
  182.   p := (h + l - 7 * m + 114) MOD 31;
  183.   IF (p = 0) THEN INC(p); DEC(n) END;
  184.   Date.day   := p;
  185.   Date.month := n;
  186.   Date.year  := Year; 
  187.   AddDays(Date,1);
  188.   RETURN Date
  189. ELSE
  190.   done := FALSE;
  191.   RETURN Date
  192. END
  193. END Easter;
  194.  
  195. PROCEDURE DiffDates(date1, date2 : DATE):LONGINT;
  196. (******************)
  197. BEGIN
  198.   RETURN LONGINT(Date2Num(date1)) - LONGINT(Date2Num(date2));
  199. END DiffDates;
  200.  
  201. PROCEDURE AddDays(VAR date:DATE; days : LONGINT);
  202. (****************)
  203. BEGIN
  204.   IF ValidDate(date) THEN
  205.     IF ((days + LONGINT(date.day)) < LONGINT(dom[date.month-1])) AND
  206.        ((days + LONGINT(date.day)) > 0) THEN
  207.       date.day := CARDINAL(LONGINT(date.day)+days)
  208.     ELSE
  209.       date := Num2Date(LONGCARD(LONGINT(Date2Num(date))+days))
  210.     END (* if *)
  211.   END; (* if *)
  212.   done := ValidDate(date)
  213. END AddDays;
  214.  
  215. PROCEDURE Date2String(Date :DATE; VAR Datum : ARRAY OF CHAR);
  216. (********************)
  217. VAR DayPos,MonthPos,YearPos : CARDINAL;
  218. BEGIN
  219.  IF (HIGH(Datum) >= 10) AND (ValidDate(Date)) THEN
  220.    CASE Dateformat OF
  221.    | EURO .. ISO : DayPos   := 0;
  222.             Datum[2] := '/';
  223.             MonthPos := 3;
  224.             Datum[5] := '/';
  225.             YearPos  := 6;
  226.             Datum[10]:= CHR(0);
  227.    | US   : MonthPos := 0;
  228.             Datum[2] := '-';
  229.             DayPos   := 3;
  230.             Datum[5] := '-';
  231.             YearPos  := 6;
  232.             Datum[10]:= CHR(0);
  233.    | ANSI : YearPos  := 0;
  234.             Datum[4] := '-';
  235.             MonthPos := 5;
  236.             Datum[7] := '-';
  237.             DayPos   := 8;
  238.             Datum[10]:= CHR(0);
  239.    END (* Case *); 
  240.    Datum[DayPos]     := CHR((Date.day DIV 10) + 48);
  241.    Datum[DayPos+1]   := CHR((Date.day MOD 10) + 48);
  242.    Datum[MonthPos]   := CHR((Date.month DIV 10) + 48); 
  243.    Datum[MonthPos+1] := CHR((Date.month MOD 10) + 48);
  244.    Datum[YearPos]    := CHR((Date.year DIV 1000)+ 48);
  245.    Date.year := Date.year MOD 1000;
  246.    Datum[YearPos+1]  := CHR((Date.year DIV 100) + 48);
  247.    Date.year := Date.year MOD 100;
  248.    Datum[YearPos+2]  := CHR((Date.year DIV 10)  + 48);
  249.    Datum[YearPos+3]  := CHR((Date.year MOD 10)  + 48);
  250.    done := TRUE;
  251.  ELSE
  252.    Datum[0] := CHR(0);
  253.    done     := FALSE;  
  254.  END
  255. END Date2String;
  256.  
  257. BEGIN
  258.   Dateformat := EURO;
  259. END DateFunctions.