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.



  3 Responses to “Category : Pascal Source Code
Archive   : TPTSR.ZIP
Filename : CALENDAR.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/