Oto mój program który wysłałem na stronę 4programmers
http://download.4programmers.net/calendar1.zip
A oto inna jego wersja
uses crt,dos;
type week = (Sun,Mon,Tue,Wed,Thu,Fri,Sat);
month=array[0..6,0..6]of word;
date=record d,m,y,dow:word end;
const monseq:array[1..12]of word=(0,1,1,2,5,6,2,3,4,0,1,4);
weeknames:array[ord(Sun)..ord(Sat)]of string=('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
monthnames:array[1..12]of string=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
week7:array[1..7,1..7] of week=
((Sun,Mon,Tue,Wed,Thu,Fri,Sat),
(Sat,Sun,Mon,Tue,Wed,Thu,Fri),
(Fri,Sat,Sun,Mon,Tue,Wed,Thu),
(Thu,Fri,Sat,Sun,Mon,Tue,Wed),
(Wed,Thu,Fri,Sat,Sun,Mon,Tue),
(Tue,Wed,Thu,Fri,Sat,Sun,Mon),
(Mon,Tue,Wed,Thu,Fri,Sat,Sun));
dl:array[0..28,0..6]of string[2]=
(('C', '','E','','G','BA',''),
('B','C','D','E','F','G','A'),
('A','B','C','D','E','F','G'),
('G','A','B','C','D','E','F'),
('FE','GF','AG','BA','CB','DC','ED'),
('D','E','F','G','A','B','C'),
('C','D','E','F','G','A','B'),
('B','C','D','E','F','G','A'),
('AG','BA','CB','DC','ED','FE','GF'),
('F','G','A','B','C','D','E'),
('E','F','G','A','B','C','D'),
('D','E','F','G','A','B','C'),
('CB','DC','ED','FE','GF','AG','BA'),
('A','B','C','D','E','F','G'),
('G','A','B','C','D','E','F'),
('F','G','A','B','C','D','E'),
('ED','FE','GF','AG','BA','CB','DC'),
('C','D','E','F','G','A','B'),
('B','C','D','E','F','G','A'),
('A','B','C','D','E','F','G'),
('GF','AG','BA','CB','DC','ED','FE'),
('E','F','G','A','B','C','D'),
('D','E','F','G','A','B','C'),
('C','D','E','F','G','A','B'),
('BA','CB','DC','ED','FE','GF','AG'),
('G','A','B','C','D','E','F'),
('F','G','A','B','C','D','E'),
('E','F','G','A','B','C','D'),
('DC','ED','FE','GF','AG','BA','CB'));
function leap(y,s:word):boolean;
var a,b:word;
begin
if s=0 then a:=(y mod 700) div 100
else a:=(5+2*((y mod 400) div 100))mod 7;
b:=(y mod 100)mod 28;
if (s=0)and(b=0) then b:=b+28;
if (s<>0)and(b=0)and(y mod 100<>0) then b:=b+28;
leap:=(length(dl[b,a])=2);
end;
function dow(d,m,y,s:word):week;
var a,b,p,q:word;
begin
if s=0 then a:=(y mod 700) div 100
else a:=(5+2*((y mod 400) div 100))mod 7;
b:=(y mod 100)mod 28;
if (s=0)and(b=0) then b:=b+28;
if (s<>0)and(b=0)and(y mod 100<>0) then b:=b+28;
p:=ord(dl[b,a][1+ord(leap(y,s))*ord(m>2)])-$40;
q:=(3*monseq[m]+d)mod 7;
if q=0 then q:=q+7;
dow:=week7[p,q];
end;
function monlen(m,y,s:word):word;
begin
if (m<1)or(m>12) then monlen:=0
else if (odd(m)and(m<=7)) or (not odd(m)and(m>7)) then monlen:=31
else if m<>2 then monlen:=30
else monlen:=28+ord(leap(y,s));
end;
procedure fillmon(m,y,s,k:word;var a:month);
var i,j:word;
begin
for i:=0 to 6 do
for j:=0 to 6 do
a[i,j]:=0;
j:=0;
for i:=1 to monlen(m,y,s) do
begin
a[j,ord(dow(i,m,y,s))]:=i;
if (dow(i,m,y,s)<>week(k))and(dow(i+1,m,y,s)=week(k)) then j:=j+1;
end;
end;
procedure printmon(m,y,s,k:word;a:month);
var i,j:word;
t:string;
d:date;
begin
getdate(d.y,d.m,d.d,d.dow);
if s=0 then t:='Julian style'
else t:='Gregorian style';
writeln(t:24);
writeln(monthnames[m]:8,y:16);
for i:=ord(Sun) to ord(Sat) do
begin
if i=ord(Sat) then textcolor(red)
else textcolor(lightgray);
write(weeknames[(i+k)mod 7]:4);
end;
writeln;
for i:=0 to 6 do
begin
for j:=0 to 6 do
begin
if (j=6)and(a[i,(j+k)mod 7]<>0) then textcolor(red)
else textcolor(lightgray);
if(s<>0)and(d.y=y)and(d.m=m)and(d.d=a[i,(j+k)mod 7]) then textbackground(blue)
else textbackground(black);
if a[i,(j+k)mod 7]=0 then write('':4)
else write(a[i,(j+k)mod 7]:4);
end;
writeln;
end;
writeln;
end;
var a:month;
m,y,s,k:word;
ch:char;
d:date;
begin
clrscr;
getdate(d.y,d.m,d.d,d.dow);
m:=d.m;
y:=d.y;
s:=1;
k:=0;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
repeat
ch:=readkey;
case ch of
'Q':
begin
clrscr;
y:=y+1000;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'q':
begin
clrscr;
y:=y-1000;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'W':
begin
clrscr;
y:=y+100;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'w':
begin
clrscr;
y:=y-100;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'E':
begin
clrscr;
y:=y+10;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'e':
begin
clrscr;
y:=y-10;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'R':
begin
clrscr;
y:=y+1;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'r':
begin
clrscr;
y:=y-1;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'A':
begin
clrscr;
m:=m+1;
while m>12 do
begin
m:=m-12;
y:=y+1;
end;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'a':
begin
clrscr;
m:=m-1;
while m<1 do
begin
m:=m+12;
y:=y-1;
end;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'S':
begin
clrscr;
k:=(k+1)mod 7;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
's':
begin
clrscr;
k:=(k+6)mod 7;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
'z':
begin
clrscr;
s:=1-s;
fillmon(m,y,s,k,a);
printmon(m,y,s,k,a);
end;
end;
until ch=#27;
end.