Category : Pascal Source Code
Archive   : TPTSR.ZIP
Filename : CALENDAR.PAS

 
Output of file : CALENDAR.PAS contained in archive : TPTSR.ZIP

{

calendar.pas
1-19-1990

Copyright 1990
John W. Small
All rights reserved

PSW / Power SoftWare
P.O. Box 10072
McLean, Virginia 22102 8072


The Gregorian calendar is valid for September 15, 1752
to the present. It is based on a 400 year cycle with
every fourth year a leap year unless divisible by 100.
Years divisible by 400 are also leap years. There are
then 100 - 4 + 1 = 97 leap days in 400 years. 97 +
400 * 365 = 146097 days. Thus the number of days in
400 years is evenly divisible by seven.

The Julian date is the number of the days starting
from year 1 A.D.

}

unit calendar;

interface

uses crt;

const

DaysInMonth : array[1..12] of integer = (
31,28,31,30,31,30,31,31,30,31,30,31
);

months : array[1..12] of string[9] = (
'January', 'February', 'March',
'April', 'May', 'June',
'July', 'August', 'September',
'October', 'November', 'December'
);

days : array[1..7] of string[9] = (
'Sunday', 'Monday','Tuesday', 'Wednesday',
'Thursday', 'Friday', 'Saturday'
);

function DayOfTheWeek(year,month,day : integer):integer;
function LeapYear(year : integer) : boolean;
function DayOfTheYear(year,month,day : integer):integer;
procedure CalendarRC(year, month, day : integer;
var r, c : byte);
procedure WriteCalendar(year, month : integer);


implementation

function DayOfTheWeek(year,month,day : integer):integer;
var y,c,m,d : integer;
begin
{ Zeller's congruence }
dec(month,2);
if month <= 0 then begin
inc(month,12);
dec(year)
end;
y := year mod 100;
c := year div 100;
d := (26 * month - 2) div 10 +
day + y + y div 4 + c div 4 - 2 * c;
while (d < 0) do
inc(d,7);
DayOfTheWeek := d mod 7 + 1
end;

function LeapYear(year : integer) : boolean;
begin
if not boolean(year mod 4) and
boolean(year mod 100) or
not boolean(year mod 400)
then LeapYear := true
else LeapYear := false
end;

function DayOfTheYear(year,month,day : integer):integer;
var m, d : integer;
begin
d := 0;
for m := 1 to month - 1 do
inc(d,DaysInMonth[m]);
if (not boolean(year mod 4) and
boolean(year mod 100) or
not boolean(year mod 400)) and
(month > 2) then
inc(d);
DayOfTheYear := d + day
end;

procedure CalendarRC(year, month, day : integer;
var r, c : byte);
var firstOfs : integer;
begin
firstOfs := DayOfTheWeek(year,month,1) - 1;
r := (day - 1 + firstOfs) div 7 + 1;
c := (day - 1 + firstOfs) mod 7 + 1
end;

procedure WriteCalendar(year, month : integer);
const WeekDays = ' S M Tu W Th F S ';
var x, y, r, c : byte;
day : integer;
begin
x := wherex; y := wherey;
write(' ',months[month],' ',year);
inc(y);
gotoxy(x,y);
write(WeekDays);
for day := 1 to DaysInMonth[month] do begin
CalendarRC(year,month,day,r,c);
gotoxy((c-1)*3+x,r+y);
write(day:3);
end;

end;

begin
end.