[Back to DATETIME SWAG index] [Back to Main SWAG index] [Original]

                  (* * * * * * * * * * * * * * * * * * * * * * *)
                  (*   UNIT: DTIME - By Alan Graff, Nov. 92    *)
                  (*      Compiled from routines found in:     *)
                  (*       DATEPAK4: W.G.Madison, Nov. 87      *)
                  (*       UNIXDATE: Brian Stark, Jan. 92      *)
                  (*   Plus various things of my own creation  *)
                  (*   and extracted from Fidonet PASCAL echo  *)
                  (*   messages and other sources.             *)
                  (*      Contributed to the Public Domain     *)
                  (*          Version 1.1 - Nov. 1992          *)
                  (* * * * * * * * * * * * * * * * * * * * * * *)

    UNIT DTime;
    {**************************************************************}
    INTERFACE
    uses crt,dos;

    TYPE DATETYPE = record
         day:WORD;
         MONTH:WORD;
         YEAR:WORD;
         dow:word;
         end;

     (* Sundry determinations of current date/time variables *)
    Function  DayOfYear:word;  (* Returns 1 to 365 *)
    Function DayOfMonth:word;  (* Returns 1 to 31  *)
    Function DayOfWeek:word;   (* Returns 1 to 7   *)
    Function MonthOfYear:word; (* Returns 1 to 12  *)
    Function ThisYear:word;    (* Returns current year *)
    Function ThisHour:word;    (* Returns 1 to 24  *)
    Function ThisMinute:word;  (* Returns 0 to 59  *)
      (* Calculate what day of the week a particular date falls on *)
    Procedure WkDay(Year,Month,Day:Integer; var WeekDay:Integer);
       (* Full Julian conversions *)
    Procedure GregorianToJulianDN(Year,Month,Day:Integer;var JulianDN:LongInt);
    Procedure JulianDNToGregorian(JulianDN:LongInt;var Year,Month,Day:Integer);
       (* 365 day Julian conversions *)
    Procedure GregorianToJulianDate(Year,Month,Day:Integer;var JulianDate:Integer);
    Procedure JulianToGregorianDate(JulianDate,Year:Integer;var Month,Day:Integer);
       (* Sundry string things *)
    Function  DateString:String;  (* Returns system date as "mm-dd-yy" string *)
    Function  TimeString:String;  (* Returns system time as "00:00:00" string *)
      (* Create current YYMMDD string to use as a file name *)
    Function DateAFile(dy,dm,dd:word):string;
      (* Return YY-MM-DD string from filename created by DateAFile func *)
    Function Parsefile(s:string):string;
       (* Return values of 1 day ago *)
    Procedure Yesterday(Var y,m,d:integer);
       (* Return values of 1 day ahead *)
    Procedure Tomorrow(Var y,m,d:integer);
     (* Adjust time based on "TZ" environment *)
    Function  GetTimeZone : ShortInt;
    Function  IsLeapYear(Source : Word) : Boolean;  (* What it says :-)  *)
      (* Unix date conversions *)
    Function Norm2Unix(Y,M,D,H,Min,S:Word):LongInt;
    Procedure Unix2Norm(Date:LongInt;Var Y,M,D,H,Min,S:Word);
      (* Determines what day of year Easter falls on *)
    Procedure Easter(Year:Word;Var Date:DateType);
      (* Determines what day of year Thanksgiving falls on *)
    Procedure Thanksgiving(Year:Word;Var Date:DateType);
      (* Determine what percentage of moon is lit on a particular night *)
    Function MoonPhase(Date:Datetype):Real;

    IMPLEMENTATION

    const
      D0 =    1461;
      D1 =  146097;
      D2 = 1721119;
      DaysPerMonth :  Array[1..12] of ShortInt =
    (031,028,031,030,031,030,031,031,030,031,030,031);
      DaysPerYear  :  Array[1..12] of Integer  =
    (031,059,090,120,151,181,212,243,273,304,334,365);
      DaysPerLeapYear :    Array[1..12] of Integer  =
    (031,060,091,121,152,182,213,244,274,305,335,366);
      SecsPerYear      : LongInt  = 31536000;
      SecsPerLeapYear  : LongInt  = 31622400;
      SecsPerDay       : LongInt  = 86400;
      SecsPerHour      : Integer  = 3600;
      SecsPerMinute    : ShortInt = 60;

    Procedure GregorianToJulianDN;
    var
      Century,
      XYear    : LongInt;
    begin {GregorianToJulianDN}
      If Month <= 2 then begin
        Year := pred(Year);
        Month := Month + 12;
        end;
      Month := Month - 3;
      Century := Year div 100;
      XYear := Year mod 100;
      Century := (Century * D1) shr 2;
      XYear := (XYear * D0) shr 2;
      JulianDN := ((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century;
      end; {GregorianToJulianDN}
    {**************************************************************}
    Procedure JulianDNToGregorian;
    var
      Temp,
      XYear   : LongInt;
      YYear,
      YMonth,
      YDay    : Integer;
    begin {JulianDNToGregorian}
      Temp := (((JulianDN - D2) shl 2) - 1);
      XYear := (Temp mod D1) or 3;
      JulianDN := Temp div D1;
      YYear := (XYear div D0);
      Temp := ((((XYear mod D0) + 4) shr 2) * 5) - 3;
      YMonth := Temp div 153;
      If YMonth >= 10 then begin
        YYear := YYear + 1;
        YMonth := YMonth - 12;
        end;
      YMonth := YMonth + 3;
      YDay := Temp mod 153;
      YDay := (YDay + 5) div 5;
      Year := YYear + (JulianDN * 100);
      Month := YMonth;
      Day := YDay;
      end; {JulianDNToGregorian}
    {**************************************************************}
    Procedure GregorianToJulianDate;
    var
      Jan1,
      Today : LongInt;
    begin {GregorianToJulianDate}
      GregorianToJulianDN(Year, 1, 1, Jan1);
      GregorianToJulianDN(Year, Month, Day, Today);
      JulianDate := (Today - Jan1 + 1);
      end; {GregorianToJulianDate}
    {**************************************************************}
    Procedure JulianToGregorianDate;
    var
      Jan1  : LongInt;
    begin
      GregorianToJulianDN(Year, 1, 1, Jan1);
      JulianDNToGregorian((Jan1 + JulianDate - 1), Year, Month, Day);
      end; {JulianToGregorianDate}
    {**************************************************************}
    Procedure WkDay;
    var
      DayNum : LongInt;
    begin
      GregorianToJulianDN(Year, Month, Day, DayNum);
      DayNum := ((DayNum + 1) mod 7);
      WeekDay := (DayNum) + 1;
      end; {DayOfWeek}
    {**************************************************************}
    Procedure Yesterday(Var Y,M,D:integer);
    var jdn:longint;
    begin
    GregorianToJulianDN(Y,M,D,JDN);
    JDN:=JDN-1;
    JulianDNToGregorian(JDN,Y,M,D);
    end;
    {**************************************************************}
    Procedure Tomorrow(Var Y,M,D:integer);
    var JDN:longint;
    begin
    GregorianToJulianDN(Y,M,D,JDN);
    JDN:=JDN+1;
    JulianDNToGregorian(JDN,Y,M,D);
    end;
    {**************************************************************}
    Function TimeString:string;
    var hr,mn,sec,hun:word;
    s,q:string;
    begin
      q:='';
      gettime(hr,mn,sec,hun);
      if hr<10 then q:=q+'0';
      str(hr:1,s);
      q:=q+s+':';
      if mn<10 then q:=q+'0';
      str(mn:1,s);
      q:=q+s;
      TimeString:=q;
    end;
    {**************************************************************}
    Function ThisHour:Word;
    var hr,mn,sec,hun:word;
    begin
      gettime(hr,mn,sec,hun);
      ThisHour:=hr;
    end;
    {**************************************************************}
    Function ThisMinute:Word;
    var hr,mn,sec,hun:word;
    begin
      gettime(hr,mn,sec,hun);
      ThisMinute:=mn;
    end;
    {**************************************************************}
    Function DateString:string;
    var yr,mo,dy,dow:word;
        s,q:string;
    begin
      q:='';
      getdate(yr,mo,dy,dow);
      if mo<10 then q:=q+'0';
      str(mo:1,s);
      q:=q+s+'-';
      if dy<10 then q:=q+'0';
      str(dy:1,s);
      q:=q+s+'-';
      while yr>100 do yr:=yr-100;
      if yr<10 then q:=q+'0';
      str(yr:1,s);
      q:=q+s;
      Datestring:=q;
    end;
    {**************************************************************}
    Function parsefile(s:string):string;  { Return date string from a file name }
    var mo,errcode:word;                  { in either YYMMDD.EXT or MMDDYY.EXT  }
        st:string;                        { format.                             }
    begin
    st:=copy(s,1,2)+'-'+copy(s,3,2)+'-'+copy(s,5,2);
    parsefile:=st;
    end;
    {**************************************************************}
    function dateafile(dy,dm,dd:word):string;
    var s1,s2:string;
    begin
    while dy>100 do dy:=dy-100;
    str(dy,s1);
    while length(s1)<2 do s1:='0'+s1;
    s2:=s1;
    str(dm,s1);
    while length(s1)<2 do s1:='0'+s1;
    s2:=s2+s1;
    str(dd,s1);
    while length(s1)<2 do s1:='0'+s1;
    s2:=s2+s1;
    dateafile:=s2;
    end;
    {**************************************************************}
    Function DayOfMonth:Word;
    var yr,mo,dy,dow:word;
    begin
      getdate(yr,mo,dy,dow);
      DayOfMonth:=dy;
    end;
    {**************************************************************}
    Function ThisYear:Word;
    var yr,mo,dy,dow:word;
    begin
      getdate(yr,mo,dy,dow);
      ThisYear:=yr;
    end;

    {**************************************************************}
    Function DayOfWeek:word;
    var yr,mo,dy,dow:word;
    begin
      getdate(yr,mo,dy,dow);    (* Turbo Pascal authors never saw a *)
      dow:=dow+1;               (* calendar.  Their first day of    *)
      if dow=8 then dow:=1;     (* week is Monday....               *)
      DayOfWeek:=dow;
    end;
    {**************************************************************}
    Function MonthOfYear:Word;
    var yr,mo,dy,dow:word;
    begin
      getdate(yr,mo,dy,dow);
      monthofyear:=mo;
    end;
    {**************************************************************}
    Function GetTimeZone : ShortInt;
    Var
      Environment : String;
      Index : Integer;
    Begin
      GetTimeZone := 0;                            {Assume UTC}
      Environment := GetEnv('TZ');       {Grab TZ string}
      For Index := 1 To Length(Environment) Do
        Environment[Index] := Upcase(Environment[Index]);
      If Environment =  'EST05'    Then GetTimeZone := -05; {USA EASTERN}
      If Environment =  'EST05EDT' Then GetTimeZone := -06;
      If Environment =  'CST06'    Then GetTimeZone := -06; {USA CENTRAL}
      If Environment =  'CST06CDT' Then GetTimeZone := -07;
      If Environment =  'MST07'    Then GetTimeZone := -07; {USA MOUNTAIN}
      If Environment =  'MST07MDT' Then GetTimeZone := -08;
      If Environment =  'PST08'    Then GetTimeZone := -08;
      If Environment =  'PST08PDT' Then GetTimeZone := -09;
      If Environment =  'YST09'    Then GetTimeZone := -09;
      If Environment =  'AST10'    Then GetTimeZone := -10;
      If Environment =  'BST11'    Then GetTimeZone := -11;
      If Environment =  'CET-1'    Then GetTimeZone :=  01;
      If Environment =  'CET-01'   Then GetTimeZone :=  01;
      If Environment =  'EST-10'   Then GetTimeZone :=  10;
      If Environment =  'WST-8'    Then GetTimeZone :=  08; {Perth,W.Austrailia}
      If Environment =  'WST-08'   Then GetTimeZone :=  08;
    End;
    {**************************************************************}
    Function IsLeapYear(Source : Word) : Boolean;
    Begin
      If (Source Mod 4 = 0) Then
        IsLeapYear := True
      Else
        IsLeapYear := False;
    End;
    {**************************************************************}
    Function Norm2Unix(Y,M,D,H,Min,S : Word) : LongInt;
    Var
      UnixDate : LongInt;
      Index    : Word;
    Begin
      UnixDate := 0;                                              {initialize}
      Inc(UnixDate,S);                                           {add seconds}
      Inc(UnixDate,(SecsPerMinute * Min));                       {add minutes}
      Inc(UnixDate,(SecsPerHour * H));                             {add hours}
      UnixDate := UnixDate - (GetTimeZone * SecsPerHour);         {UTC offset}
      If D > 1 Then                              {has one day already passed?}
        Inc(UnixDate,(SecsPerDay * (D-1)));
      If IsLeapYear(Y) Then
        DaysPerMonth[02] := 29
      Else
        DaysPerMonth[02] := 28;                          {Check for Feb. 29th}
      Index := 1;
      If M > 1 Then For Index := 1 To (M-1) Do {has one month already passed?}
        Inc(UnixDate,(DaysPerMonth[Index] * SecsPerDay));
      While Y > 1970 Do
      Begin
        If IsLeapYear((Y-1)) Then
          Inc(UnixDate,SecsPerLeapYear)
        Else
          Inc(UnixDate,SecsPerYear);
        Dec(Y,1);
      End;
      Norm2Unix := UnixDate;
    End; Procedure Unix2Norm(Date : LongInt; Var Y, M, D, H, Min, S : Word);
    {}
    Var
      LocalDate : LongInt; Done : Boolean; X : ShortInt; TotDays : Integer;
    Begin
      Y   := 1970; M := 1; D := 1; H := 0; Min := 0; S := 0;
      LocalDate := Date + (GetTimeZone * SecsPerHour);      {Local time date}
      Done := False;
      While Not Done Do
      Begin
        If LocalDate >= SecsPerYear Then
        Begin
          Inc(Y,1);
          Dec(LocalDate,SecsPerYear);
        End
        Else
          Done := True;
        If (IsLeapYear(Y+1)) And (LocalDate >= SecsPerLeapYear) And
           (Not Done) Then
        Begin
          Inc(Y,1);
          Dec(LocalDate,SecsPerLeapYear);
        End;
      End;
      M := 1; D := 1;
      Done := False;
      TotDays := LocalDate Div SecsPerDay;
      If IsLeapYear(Y) Then
      Begin
        DaysPerMonth[02] := 29;
        X := 1;
        Repeat
          If (TotDays <= DaysPerLeapYear[x]) Then
          Begin
            M := X;
            Done := True;
            Dec(LocalDate,(TotDays * SecsPerDay));
            D := DaysPerMonth[M]-(DaysPerLeapYear[M]-TotDays) + 1;
          End
          Else
            Done := False;
          Inc(X);
        Until (Done) or (X > 12);
      End
      Else
      Begin
        DaysPerMonth[02] := 28;
        X := 1;
        Repeat
          If (TotDays <= DaysPerYear[x]) Then
          Begin
            M := X;
            Done := True;
            Dec(LocalDate,(TotDays * SecsPerDay));
            D := DaysPerMonth[M]-(DaysPerYear[M]-TotDays) + 1;
          End
          Else
            Done := False;
          Inc(X);
        Until Done = True or (X > 12);
      End;
      H := LocalDate Div SecsPerHour;
        Dec(LocalDate,(H * SecsPerHour));
      Min := LocalDate Div SecsPerMinute;
        Dec(LocalDate,(Min * SecsPerMinute));
      S := LocalDate;
    End;
    {**************************************************************}
    Function DayOfYear;
    var
      HCentury,Century,Xyear,
      Ripoff,HXYear    : LongInt;
      Holdyear,Holdmonth,Holdday:Integer;
      year,month,day,dofwk:word;
    begin {DayofYear}
      getdate(year,month,day,dofwk);
      Holdyear:=year-1;
      Holdmonth:=9;
      Holdday:=31;
      HCentury := HoldYear div 100;
      HXYear := HoldYear mod 100;
      HCentury := (HCentury * D1) shr 2;
      HXYear := (HXYear * D0) shr 2;
      Ripoff := ((((HoldMonth * 153) + 2) div 5) + HoldDay) + D2 + HXYear +
    HCentury;
      If Month <= 2 then begin
        Year := pred(Year);
        Month := Month + 12;
        end;
      Month := Month - 3;
      Century := Year div 100;
      XYear := Year mod 100;
      Century := (Century * D1) shr 2;
      XYear := (XYear * D0) shr 2;
      DayofYear := (((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century)-
    ripoff;
      end; {DayOfYear}
    Procedure Easter(Year : Word; Var Date : DateType);
       (* Calculates what day Easter falls on in a given year         *)
       (* Set desired Year and result is returned in Date variable    *)
    Var
       GoldenNo,
       Sun,
       Century,
       LeapCent,
       LunarCorr,
       Epact,
       FullMoon : Integer;
    Begin
       Date.Year := Year;
       GoldenNo := (Year Mod 19) + 1;
       Century := (Year Div 100) + 1;
       LeapCent := (3 * Century Div 4) - 12;
       LunarCorr := ((8 * Century + 5) Div 25) - 5;
       Sun := (5 * Year Div 4) - LeapCent - 10;
       Epact := Abs(11 * GoldenNo + 20 + LunarCorr - LeapCent) Mod 30;
       If ((Epact = 25) And (GoldenNo > 11)) Or (Epact = 24) then
          Inc(Epact);
       FullMoon := 44 - Epact;
       If FullMoon < 21 then
          Inc(FullMoon, 30);
       Date.Day := FullMoon + 7 - ((Sun + FullMoon) Mod 7);
       If Date.Day > 31 then
          Begin
             Dec(Date.Day, 31);
             Date.Month := 4;
          End
       Else
          Date.Month := 3;
       Date.DOW := 0;
    End;
    {**************************************************************}
    Procedure Thanksgiving(Year : Word; Var Date : DateType);
       (* Calculates what day Thanksgiving falls on in a given year   *)
       (* Set desired Year and result is returned in Date variable    *)
    Var
      Counter,WeekDay:Word;
      Daynum:longint;
    Begin
       Date.Year := Year;
       Date.Month := 11;
       counter:=29;
       repeat
         dec(counter);
         GregorianToJulianDN(Date.Year, Date.Month, Counter, DayNum);
         DayNum := ((DayNum + 1) mod 7);
         WeekDay := (DayNum) + 1;
       Until Weekday = 5;
       Date.Day:=Counter;
    End;
    {*************************************************************}
    Function MoonPhase(Date:Datetype):Real;
      (* Determines APPROXIMATE phase of the moon (percentage lit)   *)
      (* 0.00 = New moon, 1.00 = Full moon                           *)
      (* Due to rounding, full values may possibly never be reached  *)
      (* Valid from Oct. 15, 1582 to Feb. 28, 4000                   *)
      (* Calculations adapted to Turbo Pascal from routines found in *)
      (* "119 Practical Programs For The TRS-80 Pocket Computer"     *)
      (* John Clark Craig, TAB Books, 1982                      (Ag) *)
    VAR j:longint; m:real;
    Begin
      GregorianToJulianDN(Date.Year,Date.Month,Date.Day,J);
      M:=(J+4.867)/ 29.53058;
      M:=2*(M-Int(m))-1;
      MoonPhase:=Abs(M);
    end;

    END.

[Back to DATETIME SWAG index] [Back to Main SWAG index] [Original]