Power-Programmierung/CD1.mdf/pascal/library/dos/database/gsdb28/gs_date.pas

Pascal/Delphi Source File | 1992-02-24 | 8.1 KB | 305 lines

unit GS_Date;
{-----------------------------------------------------------------------------
                             Date Processor

       GS_DATE Copyright (c)  Richard F. Griffin

       02 May 1991

       102 Molded Stone Pl
       Warner Robins, GA  31088

       -------------------------------------------------------------
       This unit handles date conversion.

                   SHAREWARE  -- COMMERCIAL USE RESTRICTED



       Changes:

       03 May 91 - Added GS_Date_Century flag.  When true, the GS_Date_View
                   function will return MM/DD/YYYY.  When false, only the last
                   two digits of the year will be returned (MM/DD/YY).  The
                   default is false.

       Acknowledgements:

       An astronomers' Julian day number is a calendar system which is useful
       over a very large span of time.  (January 1, 1988 A.D. is 2,447,162 in
       this system.)  The mathematics of these procedures originally restricted
       the valid range to March 1, 0000 through February 28, 4000.  The update
       by Carley Phillips changes the valid end date to December 31, 65535.

       The basic algorithms are based on those contained in the COLLECTED
       ALGORITHMS from Communications of the ACM, algorithm number 199,
       originally submitted by Robert G. Tantzen in the August, 1963 issue
       (Volume 6, Number 8).  Note that these algorithms do not take into
       account that years divisible by 4000 are NOT leap years.  Therefore the
       calculations are only valid until 02-28-4000.  These procedures were
       modified by Carley Phillips (76630,3312) to provide a mathematically
       valid range of 03-01-0000 through 12-31-65535.

       The main part of Tantzen's original algorithm depends on treating
       January and February as the last months of the preceding year.  Then,
       one can look at a series of four years (for example, 3-1-84 through
       2-29-88) in which the last day will be either the 1460th or the 1461st
       day depending on whether the 4-year series ended in a leap day.

       By assigning a longint julian date, computing differences between
       dates, adding days to an existing date, and other mathematical actions
       become much easier.

------------------------------------------------------------------------------}

interface
{$D-}
uses
    Dos;

const
   GS_Date_JulInv  =  -1;             {constant for invalid Julian day}

type
   GS_Date_StrTyp  = string[10];
   GS_Date_ValTyp  = longint;

var
   GS_Date_Century : boolean;


function  GS_Date_Curr : GS_Date_ValTyp;
function  GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
function  GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
function  GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
function  GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);


implementation

const
   JulianConstant =  1721119;  {constant for Julian day for 02-28-0000}
   JulianMin      =  1721120;  {constant for Julian day for 03-01-0000}
   JulianMax      =  25657575; {constant for Julian day for 12-31-65535}

function LeapYearTrue (year : word)  : boolean;
begin
   LeapYearTrue := false;
   if (year mod 4 = 0) then
      if (year mod 100 <> 0) or (year mod 400 = 0) then
         if (year mod 4000 <> 0) then
            LeapYearTrue :=  true;
end;

function DateOk (month, day, year  : word) : boolean;
var
   daz : integer;
begin
   if (day <> 0) and
      ((month > 0) and (month < 13)) and
      ((year <> 0) or (month > 2)) then
   begin
      case month of
         2  : begin
                 daz := 28;
                 if (LeapYearTrue(year)) then inc(daz);
              end;
         4,
         6,
         9,
         11 : daz := 30;
         else  daz := 31;
      end;
      DateOk := day <= daz;
   end
   else DateOk := false;
end;

function GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
var
   wmm,
   wyy,
   jul  : longint;
begin
   wyy := year;
   if (month > 2) then wmm  := month - 3
      else
      begin
         wmm := month + 9;
         dec(wyy);
      end;
   jul := (wyy div 4000) * 1460969;
   wyy := (wyy mod 4000);
   jul := jul +
            (((wyy div 100) * 146097) div 4) +
            (((wyy mod 100) * 1461) div 4) +
            (((153 * wmm) + 2) div 5) +
            day +
            JulianConstant;
   if (jul < JulianMin) or (JulianMax < jul) then
      jul := GS_Date_JulInv;
   GS_Date_MDY2Jul := jul;
end;

procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);
var
   tmp1 : longint;
   tmp2 : longint;
begin
   if (JulianMin <= jul) and (jul <= JulianMax) then
      begin
         tmp1  := jul - JulianConstant; {will be at least 1}
         year  := ((tmp1-1) div 1460969) * 4000;
         tmp1  := ((tmp1-1) mod 1460969) + 1;
         tmp1  := (4 * tmp1) - 1;
         tmp2  := (4 * ((tmp1 mod 146097) div 4)) + 3;
         year  := (100 * (tmp1 div 146097)) + (tmp2 div 1461) + year;
         tmp1  := (5 * (((tmp2 mod 1461) + 4) div 4)) - 3;
         month :=   tmp1 div 153;
         day   := ((tmp1 mod 153) + 5) div 5;
         if (month < 10) then
            month  := month + 3
         else
            begin
               month  := month - 9;
               year := year + 1;
            end {else}
      end {if}
   else
      begin
         month := 0;
         day   := 0;
         year  := 0;
      end; {else}
end;


function GS_Date_Curr : GS_Date_ValTyp;
Var
  month, day, year : word;
  cw : word;
begin
   GetDate(year,month,day,cw);
   GS_Date_Curr := GS_Date_MDY2Jul(month, day, year);
end;

function GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
var
   mm,
   dd,
   yy  : word;
   ss  : string[8];
   sg  : string[4];
   i   : integer;
begin
   ss := '        ';
   if nv > GS_Date_JulInv then
   begin
      GS_Date_Jul2MDY(nv,mm,dd,yy);
      str(mm:2,sg);
      move(sg[1],ss[5],2);
      str(dd:2,sg);
      move(sg[1],ss[7],2);
      str(yy:4,sg);
      move(sg[1],ss[1],4);
      for i := 1 to 8 do if ss[i] = ' ' then ss[i] := '0';
   end;
   GS_Date_DBStor := ss;
end;

function GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
var
   mm,
   dd,
   yy  : word;
   ss  : string[10];
   sg  : string[4];
   i   : integer;
begin
   ss := '  /  /    ';
   if nv > GS_Date_JulInv then
   begin
      GS_Date_Jul2MDY(nv,mm,dd,yy);
      str(mm:2,sg);
      move(sg[1],ss[1],2);
      str(dd:2,sg);
      move(sg[1],ss[4],2);
      str(yy:4,sg);
      if GS_Date_Century then
      begin
          move(sg[1],ss[7],4);
          ss[0] := #10;
      end
      else
      begin
         move(sg[3],ss[7],2);
         ss[0] := #8;
      end;
      for i := 1 to length(ss) do if ss[i] = ' ' then ss[i] := '0';
   end
   else
   begin
      if GS_Date_Century then ss[0] := #10 else ss[0] := #8;
   end;
   GS_Date_View := ss;
end;

function GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
var
   t      : string[10];
   valu,
   yy,
   mm,
   dd     : string[4];
   mmn,
   ddn,
   yyn    : word;
   rsl    : integer;
   cc     : char;
   okDate : boolean;
   co     : longint;
begin
   t := sdate;
   cc := t[3];
   if cc in ['0'..'9'] then
   begin
      mm := copy(t,5,2);
      dd := copy(t,7,2);
      yy := copy(t,1,4);
   end
   else
   begin
      mm := copy(t,1,2);
      dd := copy(t,4,2);
      yy := copy(t,7,4);
      if length(yy) = 2 then yy := '19'+yy;
   end;
   okDate := false;
   val(mm,mmn,rsl);
   if rsl = 0 then
   begin
      val(dd,ddn,rsl);
      if rsl = 0 then
      begin
         val(yy,yyn,rsl);
         if rsl = 0 then
         begin
            if DateOk(mmn,ddn,yyn) then okDate := true;
         end;
      end;
   end;
   if not okDate then
      co := GS_Date_JulInv
   else
   begin
      co := GS_Date_MDY2Jul(mmn, ddn, yyn);
   end;
   GS_Date_Juln := co;
end;


begin
   GS_Date_Century := false;
end.