maxc0186@sdsu (Wintermute) (04/18/89)
program calendar (input, output);
(**********************************************)
(** **)
(** input: two integers "month" **)
(** 1 <="month"<=12 **)
(** 0 <="year" **)
(** Each number is **)
(** seaparated by a space. **)
(** output: a one-page framed calendar for **)
(** requested month or a yearly **)
(** calendar for requested year **)
(** **)
(**********************************************)
type
days = (sun,mon,tues,wed,thur,fri,sat,endweek);
var
dayname : days;
year, month, firstday, lastdate, date : integer;
choice : char;
procedure divider(length : integer);
var
counter : integer;
begin
write (lst,' ':3);
write (lst,'|');
counter := 2;
while counter < length do
begin
write (lst,'-');
counter := counter + 1;
end;
write (lst,'|');
writeln (lst);
end; (*divider*)
procedure starline (length : integer);
var
box, counter : integer;
begin
write (lst,' ':3);
counter := 2;
write (lst,'|');
while counter <= length do
begin
counter := counter + 1;
for box := 1 to 9 do
begin
write (lst,'-');
counter := counter + 1;
end;
if counter < length then
write (lst,'+')
else
write (lst,'|');
counter := counter + 1;
end;
writeln (lst);
end; (*starline*)
procedure staredges (length : integer);
begin
writeln (lst, ' ':3, '|', '|':length-1);
end; (*staredges*)
procedure stardivide (totalsections, lengthofone : integer);
var
counter : integer;
begin
write (lst,'|':4);
counter := 1;
while counter <= totalsections do
begin
write (lst,' ':lengthofone-1, '|');
counter := counter + 1;
end;
writeln (lst);
end; (*stardivide*)
procedure writetitles (month, year : integer);
procedure monthtitle;
begin
write (lst,'|':4);
case month of
1 : write (lst,'January':35);
2 : write (lst,'February':35);
3 : write (lst,'March':35);
4 : write (lst,'April':35);
5 : write (lst,'May':35);
6 : write (lst,'June':35);
7 : write (lst,'July':35);
8 : write (lst,'August':35);
9 : write (lst,'September':35);
10 : write (lst,'October':35);
11 : write (lst,'November':35);
12 : write (lst,'December':35);
end;
writeln (lst, year:6, '|':29);
end; (*monthtitle*)
procedure daytitle;
var
daymark : days;
begin
write (lst,'|':4);
daymark := sun;
while daymark <= sat do
begin
case daymark of
sun : write (lst,' Sun ');
mon : write (lst,' Mon ');
tues : write (lst,' Tues ');
wed : write (lst,' Wed ');
thur : write (lst,' Thur ');
fri : write (lst,' Fri ');
sat : write (lst,' Sat ');
end;
write (lst,'|');
daymark := succ (daymark);
end;
writeln (lst);
end; (*daytitle*)
begin (*writetitles*)
writeln (lst);
divider (71);
staredges (71);
monthtitle;
staredges (71);
divider (71);
stardivide (7, 10);
daytitle;
stardivide (7, 10);
starline (71);
end; (*writetitles*)
function realint (x : real) : real;
begin
realint := x - (x - trunc (x));
end;
function dayweek (year : integer;
month : integer;
day : integer) : integer;
var
cent, yr : integer;
temp : integer;
begin
if year < 100 then
year := year + 1900;
month := month - 2;
if (month < 1) or (month > 10) then
begin
month := month + 12;
year := year - 1;
end;
cent := year div 100;
yr := year mod 100;
temp := (trunc (realint (2.6 * month - 0.2)) + day + yr + (yr div 4) +
(cent div 4) - cent - cent) mod 7;
if temp < 0 then
temp := temp + 7;
dayweek := temp + 1;
end; {dayweek}
function dayone (firstday : integer) : days;
begin
case firstday of
1 : dayone := sun;
2 : dayone := mon;
3 : dayone := tues;
4 : dayone := wed;
5 : dayone := thur;
6 : dayone := fri;
7 : dayone := sat;
end;
end; (*dayone*)
function howmanydays (month : integer;
year : integer) : integer;
begin
case month of
1,3,5,7,8,10,12 : howmanydays := 31;
4,6,9,11 : howmanydays := 30;
2 : begin
if ((year mod 4) = 0) and ((year mod 100) <> 0) or
((year mod 400) = 0) then
howmanydays := 29
else
howmanydays := 28;
end;
end;
end; (*howmanydays*)
procedure write1line (var date : integer;
dayname : days;
lastdate : integer);
procedure writedates;
var
daymark : days;
begin
write (lst,' ':3, '|');
daymark := sun;
if date = 1 then
begin
while daymark < dayname do
begin
write (lst,' ':9, '|');
daymark := succ (daymark);
end;
repeat
write (lst,' ':5, date:3, ' ', '|');
date := date + 1;
daymark := succ (daymark);
until daymark = endweek;
end
else
begin
repeat
write (lst,' ':5, date:3, ' ', '|');
date := date + 1;
daymark := succ (daymark);
until (date > lastdate) or (daymark = endweek);
end;
while daymark < endweek do
begin
write (lst,' ':9, '|');
daymark := succ (daymark);
end;
writeln (lst);
end; (*writedates*)
begin (*write1line*)
writedates;
stardivide (7, 10);
stardivide (7, 10);
stardivide (7, 10);
starline (71);
end; (*write1line*)
begin (*MAIN*)
write ('Calendar for Month or Year (m/y): ');
readln (choice);
if (choice = 'm') or (choice = 'M') then
begin
writeln (' Print Month Calendar');
writeln (' Enter month, year: ');
read (month, year);
firstday := dayweek (year, month, 1);
write (lst,chr (12));
writeln (lst); writeln (lst);
if year > 0 then
if (month >= 1) and (month <= 12) then
begin
writetitles (month, year);
dayname := dayone (firstday);
lastdate := howmanydays (month, year);
date := 1;
while date <= lastdate do
write1line (date, dayname, lastdate);
end
else writeln (' month of year must be between 1 and 12')
else writeln (' year must be a positive integer');
end
else if (choice = 'y') or (choice = 'Y') then
begin
writeln (' Print Year Calendar');
writeln (' Enter year: ');
read (year);
if year > 0 then
begin
for month := 1 to 12 do
begin
write (lst,chr (12));
firstday := dayweek (year, month, 1);
writeln (lst); writeln (lst);
writetitles (month, year);
dayname := dayone (firstday);
lastdate := howmanydays (month, year);
date := 1;
while date <= lastdate do
write1line (date, dayname, lastdate);
end;
end
else
writeln (' year must be a positive integer');
end
else
writeln ('You must enter m or y');
end.