Cod sursa(job #120124)

Utilizator eugen.nodeaEugen Nodea eugen.nodea Data 4 ianuarie 2008 12:09:21
Problema Ordine Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.86 kb
const fi='ordine.in';
      fo='ordine.out';
var
   f:text;
   A:array[1..64000] of char;
   Ap:Array['a'..'z'] of longint;
   i,u,k:longint;
   uc,c,ch:char;
Begin
     for c:='a' to 'z' do
         Ap[c]:=0;
    assign(f,fi);reset(f);
     k:=0;
     while Not eof(f) do
     begin
          read(f,c);
          k:=k+1;
          Ap[c]:=Ap[c]+1;
     end;
     close(f);
     uc:='a';
     while Ap[uc]=0 do
          uc:=succ(uc);
     u:=0;
     while u<k do
     begin
         ch:=uc;
         while (ch<='z') and (Ap[ch]<Trunc((k-u)/2)+1) do
                ch:=succ(ch);
          if ch <='z' then
             begin
                  u:=u+1;
                  A[u]:=ch;
                  Ap[ch]:=Ap[ch]-1;
             end
             else begin
                       c:=uc;
                       while (Ap[c]=0) and (c<='z') do
                             c:=succ(c);
                       if (c=A[u]) and (c<='z') then begin
                                   ch:=Succ(c);
                                   while (Ap[ch]=0) and (ch<='z')do
                                         ch:=succ(ch);
                                   if ch<='z' then begin
                                   u:=u+1;
                                   A[u]:=ch;
                                   Ap[ch]:=Ap[ch]-1;
                                   end;
                                   end
                       else begin
                                 u:=u+1;
                                 A[u]:=c;
                                 Ap[c]:=Ap[c]-1;
                            end;
             end;
             While (Ap[uc]=0)and (uc<='d') do
                   uc:=succ(uc);
     end;
     assign(f,fo);rewrite(f);
     i:=1;
     while A[i]<>#0 do begin
         write(f,A[i]);
         i:=i+1;
         end;
     close(f);
End.