program xt;

  const name                            :array[1..7] of string[3]=
                    ('mon','tue','wed','thu','fri','sat','sun');
  var a                                 :array[1..12] of integer;
      b,year,month,day,p,pp,i,t         :integer;
      use                               :array[1..7,1..6] of integer;

  procedure print;

    var i,j:integer;

    begin
      for i:=1 to 7 do
        begin
          write(name[i]);
          if use[i,1]<>day then write('...')
                           else write('.[ ');
          if use[i,1]<>0 then write(use[i,1])
                         else write('.');
          if use[i,1]=day then write(']');
        for j:=2 to t do
            begin
              if use[i,j]=0 then begin
                                   if use[i,j-1]<>day then write
('.....')
                                                      else write
('....');
                                 end
              else begin
                     if use[i,j]<>day then begin
                     if use[i,j-1]<>day then begin
                     if use[i,j]<10 then write('....')
                                    else write('...');
                                             end
                     else if use[i,j]<10 then write('...')
                                         else write('..');
                          end
                     else begin
                            if use[i,j]<10 then write('..[ ')
                                           else write('..[');
                          end;
                     write(use[i,j]);
                     if use[i,j]=day then write(']');
                   end;
            end;
          writeln;
        end;
    end;

  begin
    a[1]:=31; a[2]:=28; a[3]:=31; a[4]:=30; a[5]:=31; a[6]:=30;
    a[7]:=31; a[8]:=31; a[9]:=30; a[10]:=31; a[11]:=30; a[12]:=31;
    readln(day,month,year);
    p:=year-2002;
    b:=2+p;
    if year>2002 then begin
                        for i:=2002 to year-1 do
                          if ((i mod 4=0) and (i mod 100<>0)) or (i
mod 400=0)
                             then inc(b)
                      end
                 else for i:=year to 2002-1 do
                        if ((i mod 4=0) and (i mod 100<>0)) or (i mod
400=0)
                           then dec(b);
    b:=b mod 7;
    if b<=0 then b:=b+7;
    if ((year mod 4=0) and (year mod 100<>0)) or (year mod 400=0) then
       inc(a[2]);
    for i:=1 to month-1 do
      b:=(b+a[i]) mod 7;
    if b=0 then b:=7;
    fillchar(use,sizeof(use),0);
    t:=1; pp:=b-1;
    for i:=1 to a[month] do
      begin
        inc(pp);
        if pp>7 then begin
                       pp:=1;
                       inc(t);
                     end;
        use[pp,t]:=i;
      end;
    print;
  end.

If you have read the task very attentively, you must know that you
must print ' ' instead '.'.
Also I don't know exactly: spaces in the end of the string are
necessary or not. I have got "Accepted" whithout them.