Programalama > PASCAL

program takvim;
uses crt;
label tekrar,aynoal;
const
     aylar:array[1..12] of string[9]=
     ('JANUARY','FEBRUARY','MARCH','APREL','MAY','JUNE','JULY','AUGUST','SEPTEMBER',
     'OCTOBER','NOVEMBER','DECEMBER');
     gunler:array[0..6] of string[3]=('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
     topgun:array[1..12] of integer=(0,31,59,90,120,151,181,212,243,273,304,334);
     aygunsay:array[1..12] of integer=(31,28,31,30,31,30,31,31,30,31,30,31);
     sutno:array[0..6] of integer=(15,23,31,39,47,55,63);
type
    st70=string[70];
var
   syil:string[4];
   yaz:string[20];
   ay,gun,yr,y,c,cn,d,l,sut,yil,jgun,artik:integer;
   tus:char;
procedure yildiz(n:integer);
var l:integer;
begin  for l:=1 to n do
       write('*');
end;
procedure bosluk(n:integer);
var l:integer;
begin  for l:=1 to n do
       write(' ');
end;
procedure gunyaz(x:integer;s:st70);
begin  gotoxy(sutno[x],sut);write(s);
end;
procedure ayyaz(x:integer;s:st70);
begin  gotoxy(x,4);write(s);
end;
procedure gyaz(x,daycount:integer);
begin  if x=0 then sut:=sut+2;
       gotoxy(sutno[x],sut);write(daycount:2);
end;
procedure ilkgunbul(m,yr:integer);
begin
     y:=yr-1801;c:=trunc((yr-1)/100);
     cn:=trunc(yr/100);
     d:=(5+y+trunc(y/4)-(c-18)+trunc((c-16)/4))mod 7;
     if yr mod 4=0 then artik:=1 else artik:=0;
     jgun:=topgun[m]+1;if m>2 then
     jgun:=jgun+artik;
     d:=d+(jgun mod 7);
end;
{************************** ANA PROGRAM ********************************}
begin
     tekrar:
     clrscr;
     highvideo;
     gotoxy(0,22);writeln('PLEASE ENTER YEAR AND MONTH WHICH BETWEEN 1801-2199 ');
     gotoxy(35,30);
     write('PLEASE ENTER YEAR:');
     readln(yil);
     if (yil>=0) and (yil<100) then yil:=yil+1900;
     str(yil,syil);
     gotoxy(1,23);
     clreol;
     if (yil<1801) or (yil>2199) then
     begin
          writeln('ERROR!! PLEASE ENTER YEAR AGAIN...');
          goto tekrar;
     end;
     aynoal:
     gotoxy(35,32);
     write('PLEASE ENTER MONTH:');
     readln(ay);
     gotoxy(1,24);
     clreol;
     if (ay<0) or (ay>12) then
     begin
          writeln('ERROR!! PLEASE ENTER MONTH AGAIN...');
          goto aynoal;
     end;
     clrscr;
     gotoxy(28,2);
     writeln;
     bosluk(5);
     yildiz(70);writeln;
     bosluk(5);
     yildiz(9);
     bosluk(18);
     write(copy(syil,1,1));
     bosluk(4);
     write(copy(syil,2,1));
     bosluk(4);
     write(copy(syil,3,1));
     bosluk(4);
     write(copy(syil,4,1));
     bosluk(18);
     yildiz(9);writeln;
     sut:=6;
     bosluk(5);
     yildiz(70);writeln;
     bosluk(5);
     yildiz(2);
     bosluk(66);
     yildiz(2);writeln;
     for l:=1 to 13 do
     begin
          gotoxy(6,6+l);yildiz(2);
          gotoxy(74,6+l);yildiz(2);
     end;
     gotoxy(6,20);yildiz(70);
     writeln;
     ilkgunbul(ay,yil);
     for l:=0 to 6 do
         gunyaz(l,gunler[l]); writeln;
         bosluk(5);yildiz(70);writeln;
         sut:=9;
         l:=length(aylar[ay]);
         ayyaz(17,aylar[ay]);
         ayyaz(65-l,aylar[ay]);
         l:=aygunsay[ay];
         if ay=2 then  l:=l+artik;
         for c:=1 to l do
         begin  cn:=(d+c-3) mod 7;
                if cn<0 then cn:=cn+7;
                gyaz(cn,c);
         end;
         gotoxy(4,24);write('THIS PROGRAM IS WRITTEN BY TALIP OZTURK.');
         gotoxy(25,60);clreol;
         write('DO YOU WANT TO CONTINUE? [Y/N]');
         repeat
               tus:=readkey;
         until  upcase(tus) in ['Y','N'];
         if upcase(tus)='Y' then
         goto tekrar;
end.