(* * * * * * * * * * * * * * * * * * * * * * *)
              (*   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.