Cod sursa(job #290423)

Utilizator andrici_cezarAndrici Cezar andrici_cezar Data 27 martie 2009 22:11:12
Problema Ordine Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.26 kb
var f,g:text;
    suma:longint;
    z,c,i,j:char;
    a:array['a'..'z']of longint;
    b:array[1..30]of boolean;
begin
assign(f,'ordine.in');reset(f);
assign(g,'ordine.out');rewrite(g);
while not eof(f)do
      begin
      read(f,c);
      a[c]:=a[c]+1;
      end;
for i:='a'to'z'do
    begin
suma:=0;
for z:='a' to 'z' do
    if z>i then suma:=suma+a[z];
if a[i]>suma div 2+1 then begin
                 write(g,i);
                 a[i]:=a[i]-1;
                 while a[i]>0 do
                       begin
                         write(g,i);
                         a[i]:=a[i]-1;
                         for j:='a' to'z'do
                             if (a[j]>0)and(i<>j) then begin
                                                       write(g,j);
                                                       a[j]:=a[j]-1;
                                                       if (a[i]=0)and(a[j]<>0)then b[ord(j)-ord('a')]:=true;
                                                       break;
                                                       end;
                       end;
                          end else
    if (a[i]=1)and(b[ord(i)-ord('a')]=false) then begin
                   write(g,i);
                   a[i]:=0;
                   end
    else if (b[ord(i)-ord('a')]=true)then begin
                                          b[ord(i)-ord('a')]:=false;
                                          for j:='a' to'z' do
                                              if (i<>j)and(a[j]<>0)then begin
                                                                        write(g,j);
                                                                        a[j]:=a[j]-1;
                                                                        break;
                                                                        end;
                                              while a[i]>0 do
                              begin
                              write(g,i);
                              a[i]:=a[i]-1;
                              for j:='a' to'z'do
                                  if (a[j]>0)and(i<>j) then begin
                                                 write(g,j);
                                                 a[j]:=a[j]-1;
                                                 if (a[i]=0)and(a[j]<>0)then b[ord(j)-ord('a')]:=true;
                                                 break;
                                                 end;
                              end;
                        end
else if a[i]>1 then begin
                        while a[i]>0 do
                              begin
                              write(g,i);
                              a[i]:=a[i]-1;
                              for j:='a' to'z'do
                                  if (a[j]>0)and(i<>j) then begin
                                                 write(g,j);
                                                 a[j]:=a[j]-1;
                                                 if (a[i]=0)and(a[j]<>0)then b[ord(j)-ord('a')]:=true;
                                                 break;
                                                 end;
                              end;
                        end;
    end;
close(g);
end.