Cod sursa(job #120969)

Utilizator eugen.nodeaEugen Nodea eugen.nodea Data 7 ianuarie 2008 14:53:39
Problema Ordine Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.97 kb
const fi='ordine.in';
      fo='ordine.out';
var
   f:text;
   Ap:Array['a'..'z'] of longint;
   u,k:longint;
   uc,c,ch:char;
   ok:boolean;
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);
          Ap[c]:=Ap[c]+1;
          k:=k+1;
     end;
     close(f);
     assign(f,fo);rewrite(f);
     ch:='a';
     while Ap[ch]=0 do
          ch:=succ(ch);
     u:=0; uc:=#0;
     repeat
         if (Ap[ch]<>0) then begin
         u:=u+1;
         ok:=False;
         For c:=ch to 'z' do
         begin
              if Ap[c]>=Trunc(k-u)/2+1 then begin
                                            ok:=True;
                                            break;
                    end
         end;
         if ok then begin
                               uc:=c;
                               Ap[c]:=Ap[c]-1;
                               write(f,c);
                          end
                     else begin
                               if (ch<>uc)and (ch<='z') then begin
                                                    uc:=ch;
                                                    Ap[ch]:=Ap[ch]-1;
                                                    write(f,ch);
                                               end
                                           else begin
                                                     ok:=False;
                                                     For c:=succ(ch) to 'z' do
                                                         if Ap[c]<>0 then break;
                                                     uc:=c;
                                                     Ap[c]:=Ap[c]-1;
                                                     write(f,c);
                                                end;
                          end;
           end
           else ch:=succ(ch);
       until u=k;
     close(f);
End.