home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GSDB25.ZIP / GS_DATE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-07-28  |  8.0 KB  |  304 lines
  1. {                             Date Processor
  2.  
  3.        GS_DATE Copyright (c)  Richard F. Griffin
  4.  
  5.        02 May 1991
  6.  
  7.        102 Molded Stone Pl
  8.        Warner Robins, GA  31088
  9.  
  10.        -------------------------------------------------------------
  11.        This unit handles date conversion.
  12.  
  13.                    SHAREWARE  -- COMMERCIAL USE RESTRICTED
  14.  
  15.  
  16.  
  17.        Changes:
  18.  
  19.        03 May 91 - Added GS_Date_Century flag.  When true, the GS_Date_View
  20.                    function will return MM/DD/YYYY.  When false, only the last
  21.                    two digits of the year will be returned (MM/DD/YY).  The
  22.                    default is false.
  23.  
  24.        Acknowledgements:
  25.  
  26.        An astronomers' Julian day number is a calendar system which is useful
  27.        over a very large span of time.  (January 1, 1988 A.D. is 2,447,162 in
  28.        this system.)  The mathematics of these procedures originally restricted
  29.        the valid range to March 1, 0000 through February 28, 4000.  The update
  30.        by Carley Phillips changes the valid end date to December 31, 65535.
  31.  
  32.        The basic algorithms are based on those contained in the COLLECTED
  33.        ALGORITHMS from Communications of the ACM, algorithm number 199,
  34.        originally submitted by Robert G. Tantzen in the August, 1963 issue
  35.        (Volume 6, Number 8).  Note that these algorithms do not take into
  36.        account that years divisible by 4000 are NOT leap years.  Therefore the
  37.        calculations are only valid until 02-28-4000.  These procedures were
  38.        modified by Carley Phillips (76630,3312) to provide a mathematically
  39.        valid range of 03-01-0000 through 12-31-65535.
  40.  
  41.        The main part of Tantzen's original algorithm depends on treating
  42.        January and February as the last months of the preceding year.  Then,
  43.        one can look at a series of four years (for example, 3-1-84 through
  44.        2-29-88) in which the last day will be either the 1460th or the 1461st
  45.        day depending on whether the 4-year series ended in a leap day.
  46.  
  47.        By assigning a longint julian date, computing differences between
  48.        dates, adding days to an existing date, and other mathematical actions
  49.        become much easier.
  50.  
  51. ------------------------------------------------------------------------------}
  52. unit GS_Date;
  53.  
  54. interface
  55.  
  56. uses
  57.     Dos;
  58.  
  59. const
  60.    GS_Date_JulInv  =  -1;             {constant for invalid Julian day}
  61.  
  62. type
  63.    GS_Date_StrTyp  = string[10];
  64.    GS_Date_ValTyp  = longint;
  65.  
  66. var
  67.    GS_Date_Century : boolean;
  68.  
  69.  
  70. function  GS_Date_Curr : GS_Date_ValTyp;
  71. function  GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  72. function  GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  73. function  GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
  74. function  GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
  75. procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);
  76.  
  77.  
  78. implementation
  79.  
  80. const
  81.    JulianConstant =  1721119;  {constant for Julian day for 02-28-0000}
  82.    JulianMin      =  1721120;  {constant for Julian day for 03-01-0000}
  83.    JulianMax      =  25657575; {constant for Julian day for 12-31-65535}
  84.  
  85. function LeapYearTrue (year : word)  : boolean;
  86. begin
  87.    LeapYearTrue := false;
  88.    if (year mod 4 = 0) then
  89.       if (year mod 100 <> 0) or (year mod 400 = 0) then
  90.          if (year mod 4000 <> 0) then
  91.             LeapYearTrue :=  true;
  92. end;
  93.  
  94. function DateOk (month, day, year  : word) : boolean;
  95. var
  96.    daz : integer;
  97. begin
  98.    if (day <> 0) and
  99.       ((month > 0) and (month < 13)) and
  100.       ((year <> 0) or (month > 2)) then
  101.    begin
  102.       case month of
  103.          2  : begin
  104.                  daz := 28;
  105.                  if (LeapYearTrue(year)) then inc(daz);
  106.               end;
  107.          4,
  108.          6,
  109.          9,
  110.          11 : daz := 30;
  111.          else  daz := 31;
  112.       end;
  113.       DateOk := day <= daz;
  114.    end
  115.    else DateOk := false;
  116. end;
  117.  
  118. function GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
  119. var
  120.    wmm,
  121.    wyy,
  122.    jul  : longint;
  123. begin
  124.    wyy := year;
  125.    if (month > 2) then wmm  := month - 3
  126.       else
  127.       begin
  128.          wmm := month + 9;
  129.          dec(wyy);
  130.       end;
  131.    jul := (wyy div 4000) * 1460969;
  132.    wyy := (wyy mod 4000);
  133.    jul := jul +
  134.             (((wyy div 100) * 146097) div 4) +
  135.             (((wyy mod 100) * 1461) div 4) +
  136.             (((153 * wmm) + 2) div 5) +
  137.             day +
  138.             JulianConstant;
  139.    if (jul < JulianMin) or (JulianMax < jul) then
  140.       jul := GS_Date_JulInv;
  141.    GS_Date_MDY2Jul := jul;
  142. end;
  143.  
  144. procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);
  145. var
  146.    tmp1 : longint;
  147.    tmp2 : longint;
  148. begin
  149.    if (JulianMin <= jul) and (jul <= JulianMax) then
  150.       begin
  151.          tmp1  := jul - JulianConstant; {will be at least 1}
  152.          year  := ((tmp1-1) div 1460969) * 4000;
  153.          tmp1  := ((tmp1-1) mod 1460969) + 1;
  154.          tmp1  := (4 * tmp1) - 1;
  155.          tmp2  := (4 * ((tmp1 mod 146097) div 4)) + 3;
  156.          year  := (100 * (tmp1 div 146097)) + (tmp2 div 1461) + year;
  157.          tmp1  := (5 * (((tmp2 mod 1461) + 4) div 4)) - 3;
  158.          month :=   tmp1 div 153;
  159.          day   := ((tmp1 mod 153) + 5) div 5;
  160.          if (month < 10) then
  161.             month  := month + 3
  162.          else
  163.             begin
  164.                month  := month - 9;
  165.                year := year + 1;
  166.             end {else}
  167.       end {if}
  168.    else
  169.       begin
  170.          month := 0;
  171.          day   := 0;
  172.          year  := 0;
  173.       end; {else}
  174. end;
  175.  
  176.  
  177. function GS_Date_Curr : GS_Date_ValTyp;
  178. Var
  179.   month, day, year : word;
  180.   cw : word;
  181. begin
  182.    GetDate(year,month,day,cw);
  183.    GS_Date_Curr := GS_Date_MDY2Jul(month, day, year);
  184. end;
  185.  
  186. function GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  187. var
  188.    mm,
  189.    dd,
  190.    yy  : word;
  191.    ss  : string[8];
  192.    sg  : string[4];
  193.    i   : integer;
  194. begin
  195.    ss := '        ';
  196.    if nv > GS_Date_JulInv then
  197.    begin
  198.       GS_Date_Jul2MDY(nv,mm,dd,yy);
  199.       str(mm:2,sg);
  200.       move(sg[1],ss[5],2);
  201.       str(dd:2,sg);
  202.       move(sg[1],ss[7],2);
  203.       str(yy:4,sg);
  204.       move(sg[1],ss[1],4);
  205.       for i := 1 to 8 do if ss[i] = ' ' then ss[i] := '0';
  206.    end;
  207.    GS_Date_DBStor := ss;
  208. end;
  209.  
  210. function GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  211. var
  212.    mm,
  213.    dd,
  214.    yy  : word;
  215.    ss  : string[10];
  216.    sg  : string[4];
  217.    i   : integer;
  218. begin
  219.    ss := '  /  /    ';
  220.    if nv > GS_Date_JulInv then
  221.    begin
  222.       GS_Date_Jul2MDY(nv,mm,dd,yy);
  223.       str(mm:2,sg);
  224.       move(sg[1],ss[1],2);
  225.       str(dd:2,sg);
  226.       move(sg[1],ss[4],2);
  227.       str(yy:4,sg);
  228.       if GS_Date_Century then
  229.       begin
  230.           move(sg[1],ss[7],4);
  231.           ss[0] := #10;
  232.       end
  233.       else
  234.       begin
  235.          move(sg[3],ss[7],2);
  236.          ss[0] := #8;
  237.       end;
  238.       for i := 1 to length(ss) do if ss[i] = ' ' then ss[i] := '0';
  239.    end
  240.    else
  241.    begin
  242.       if GS_Date_Century then ss[0] := #10 else ss[0] := #8;
  243.    end;
  244.    GS_Date_View := ss;
  245. end;
  246.  
  247. function GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
  248. var
  249.    t      : string[10];
  250.    valu,
  251.    yy,
  252.    mm,
  253.    dd     : string[4];
  254.    mmn,
  255.    ddn,
  256.    yyn    : word;
  257.    rsl    : integer;
  258.    cc     : char;
  259.    okDate : boolean;
  260.    co     : longint;
  261. begin
  262.    t := sdate;
  263.    cc := t[3];
  264.    if cc in ['0'..'9'] then
  265.    begin
  266.       mm := copy(t,5,2);
  267.       dd := copy(t,7,2);
  268.       yy := copy(t,1,4);
  269.    end
  270.    else
  271.    begin
  272.       mm := copy(t,1,2);
  273.       dd := copy(t,4,2);
  274.       yy := copy(t,7,4);
  275.       if length(yy) = 2 then yy := '19'+yy;
  276.    end;
  277.    okDate := false;
  278.    val(mm,mmn,rsl);
  279.    if rsl = 0 then
  280.    begin
  281.       val(dd,ddn,rsl);
  282.       if rsl = 0 then
  283.       begin
  284.          val(yy,yyn,rsl);
  285.          if rsl = 0 then
  286.          begin
  287.             if DateOk(mmn,ddn,yyn) then okDate := true;
  288.          end;
  289.       end;
  290.    end;
  291.    if not okDate then
  292.       co := GS_Date_JulInv
  293.    else
  294.    begin
  295.       co := GS_Date_MDY2Jul(mmn, ddn, yyn);
  296.    end;
  297.    GS_Date_Juln := co;
  298. end;
  299.  
  300.  
  301. begin
  302.    GS_Date_Century := false;
  303. end.
  304.