{Program nie jest skomplikowany: metoda probi bledow
poprobuj i zobaczysz jak dziala, nie chce mi się komentarza pisac ;)
Shift}

Uses Crt,Dos;

Var
C:Char;S:String;
A,B,Miesiac,Rok:Integer;
W,CurY,CurM,CurD:Word;


Function Zero(s1:String;A:Integer;S:String):String;
Begin
While Length(S)< A Do S:=s1+S;
Zero:=S;
End;

{--------------------Pytanie o rok--------------------
zwroc uwage na warunki "if then else"
jest to ustawione tak aby pierwszy znak do wpisania mogl byc tylko 1 lub 2
drugi tylko 0 lub 9 co daje nam zasieg od 1900 do 2099 reszta jest dowolna :)}
Procedure Jaki_Chcesz_Rok(var Rok:Integer);
Var X,Y:Integer;C:Char;S:String;
Endo,Lev:Boolean;
Begin
Lev:=False;Endo:=False;C:=' ';
clrscr;
writeln('Podaj Rok:');
write(':');
X:=WhereX;Y:=WhereY;
writeln;
writeln('Esc- wyjscie');
if Rok< > 0 then Str(Rok,S);
gotoxy(X,Y);write(Zero(' ',4,S));
Repeat
C:=readkey;
if C=#27 then Begin NormVideo;Clrscr;Halt;end;
{a ten maly case pozwala okreslic czy uzytkownik podal nam cyfre}
case C of
'0'..'9':Lev:=true;
end;

if ((Lev)and(
((Length(S)> 1)and(Length(S)< 4))or
((Length(S)=0)and((C='1')or(C='2')))or
((Length(S)=1)and(((S[1]='1')and(C='9'))or((S[1]='2')and(C='0'))) )))then S:=S+C;
if ((C=#13)and(Length(S)=4)) then Endo:=True;
if ((C=#8)and(Length(S)> 0)) then Delete(S,Length(S),1);
if ((Lev)or(C=#8)) then begin gotoxy(X,Y);write(Zero(' ',4,S));end;
Lev:=False;
Until Endo;
Val(S,Rok,B);
End;


{--------------------Pytanie o Miesiac--------------------
tak samo sa pewne ograniczenia wpisywania: 1-9
druga liczbe mozesz postawic tyko jak juz jest wpisane 1
i druga liczba moze byc tylko 0,1 lub 2
czyli zasieg 1-12}
Procedure Jaki_Chcesz_Miesiac(var Miesiac:Integer);
Var X,Y:Integer;C:Char;S:String;
Endo,Lev:Boolean;
Begin
writeln;
writeln('Wybierz MiesiĄc:');
writeln(' 1- Styczeä');
writeln(' 2- Luty');
writeln(' 3- Marzec');
writeln(' 4- Kwiecieä');
writeln(' 5- Maj');
writeln(' 6- Czerwiec');
writeln(' 7- Lipiec');
writeln(' 8- Sierpieä');
writeln(' 9- Wrzesieä');
writeln('10- PaŤdziernik');
writeln('11- Listopad');
writeln('12- Grudzieä');
writeln;
writeln('Esc- wyjscie');
write('wybor: ');
Lev:=False;Endo:=False;
S:='';
X:=WhereX;Y:=WhereY;
Repeat
C:=readkey;
if C=#27 then Begin NormVideo;Clrscr;Halt;end;
case C of
'0'..'9':Lev:=true;
end;
if ((Lev)and
((Length(S)=1)and((S[1]='1')and ((C='0')or(C='1')or(C='2'))) )
or((Length(S)=0)and(C< > '0')) )then S:=S+C;
if ((C=#13)and(Length(S)> 0)) then Endo:=True;
if ((C=#8)and(Length(S)> 0)) then Delete(S,Length(S),1);
if ((Lev)or(C=#8)) then begin gotoxy(X,Y);write(Zero(' ',2,S));end;
Lev:=False;
Until Endo;
Val(S,Miesiac,A);
End;


Procedure WypiszKalendarz(Rok,Miesiac:Integer);

{jak widzisz nawet procedura moze miec swoja pod-procedure/funkcje}
Function Zerom(s1:String;A,B:Integer):String;
Var S:String;
Begin
Str(B,S);
While Length(S)< A Do S:=s1+S;
Zerom:=S;
End;

Var W,D,W1,W2,W3:Word;
Begin
{-------------Wypisanie Kalendarza------------}
clrscr;
case Miesiac of
1:write('Styczeä'); 2:write('Luty'); 3:write('Marzec');
4:write('Kwiecieä'); 5:write('Maj'); 6:write('Czerwiec');
7:write('Lipiec'); 8:write('Sierpieä'); 9:write('Wrzesieä');
10:write('PaŤdziernik');11:write('Listopad');12:write('Grudzieä');
end;
writeln(' ',Rok);writeln;
writeln(' Pon Wt —r Czw Pt Sob Ndz');
A:=0;B:=4;W1:=40;W3:=0;
While W1< > W3 do
Begin
Inc(A);
SetDate(Rok,Miesiac,A);{Ustawiam date}
W3:=W1;
GetDate(W,W2,D,W1);{Sprawdzam dzien tygodnia :) }
if W1=0 then W1:=7;
{O czyzby to dzisiaj? ustawmy jakis ladny kolor tekstu
bialy (15) i tlo czerwone (3)}
if ((Rok=CurY)and(Miesiac=CurM)and(A=CurD)) then Begin TextColor(15);TextBackground(Red)end
{hmm... jednak nie? to wracamy do tla czarnego (0) i jasnoszarego (7) textu}
else begin Textbackground(0);TextColor(LightGray);end;
gotoxy(W1*5-3,B);
if W1< > W3 then write(Zerom('0',2,D));
if W1=7 then Inc(B);
end;
End;





{Poczatek programu}
Begin
{GLOWNA PETLA}
Repeat
{Sprawdz dzisiejsza date}
GetDate(CurY,CurM,CurD,W);
Jaki_Chcesz_Rok(Rok);
Jaki_Chcesz_Miesiac(Miesiac);
WypiszKalendarz(Rok,Miesiac);
SetDate(CurY,CurM,CurD);
writeln;writeln;
writeln('Koniec programu? (T/N)');
repeat
C:=UpCase(Readkey);
until ((C='T')or(C='N'));
Until C='T'; {KONIEC GLOWNEJ PETLI}
End.