Contributor: ALAN GRAFF
(* * * * * * * * * * * * * * * * * * * * * * *)
(* 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.