Category : Files from Magazines
Archive   : PCTJ1285.ZIP
Filename : CALENDAR.PAS

{ Long-range calendrical package in standard Pascal }
{ Copyright 1985 Michael A. Covington }

function frac(x:real):real;
{ Fractional part of a real number. }
{ Turbo Pascal provides this as a built-in function. }
begin
while x < -maxint do x:=x+maxint;
while x > maxint do x:=x-maxint;
frac := x - trunc(x)
end;

function int(x:real):real;
{ Integer part of a real number. }
{ Uses real data type to accommodate large numbers. }
{ Turbo Pascal provides this as a built-in function. }
begin
int := x - frac(x)
end;

function floor(x:real):real;
{ Largest whole number not greater than x. }
{ Uses real data type to accommodate large numbers. }
begin
if (x < 0) and (frac(x) <> 0) then
floor := int(x) - 1.0
else
floor := int(x)
end;

function daynumber(year,month,day:integer):real;
{ Number of days elapsed since 1980 January 0 (1979 December 31). }
{ Note that the year should be given as (e.g.) 1985, not just 85. }
{ Switches from Julian to Gregorian calendar on Oct. 15, 1582. }
var
y,m: integer;
a,b,d: real;
begin
if year < 0 then y := year + 1
else y := year;
m := month;
if month < 3 then
begin
m := m + 12;
y := y - 1
end;
d := floor(365.25*y) + int(30.6001*(m+1)) + day - 723244.0;
if d < -145068.0 then
{ Julian calendar }
daynumber := d
else
{ convert to Gregorian calendar }
begin
a := floor(y/100.0);
b := 2 - a + floor(a/4.0);
daynumber := d + b
end
end;

procedure caldate(date:real; var year,month,day:integer);
{ Inverse of DAYNUMBER; given date, finds year, month, and day. }
{ Uses real arithmetic because numbers are too big for integers. }
var
a,aa,b,c,d,e,z: real;
y: integer;
begin
z := int(date + 2444239.0);
if date < -145078.0 then
{ Julian calendar }
a := z
else
{ Gregorian calendar }
begin
aa := floor((z-1867216.25)/36524.25);
a := z + 1 + aa - floor(aa/4.0)
end;
b := a + 1524.0;
c := int((b-122.1)/365.25);
d := int(365.25*c);
e := int((b-d)/30.6001);
day := trunc(b - d - int(30.6001*e));
if e > 13.5 then month := trunc(e - 13.0)
else month := trunc(e - 1.0);
if month > 2 then y := trunc(c - 4716.0)
else y := trunc(c - 4715.0);
if y < 1 then year := y - 1
else year := y
end;

function weekday(date:real):integer;
{ Given day number as used in the above routines, }
{ finds day of week (1 = Sunday, 2 = Monday, etc.). }
var
dd: real;
begin
dd := date;
while dd > 28000.0 do dd:=dd-28000.0;
while dd < 0 do dd:=dd+28000.0;
weekday := ((trunc(dd) + 1) mod 7) + 1
end;