Cod sursa(job #608453)

Utilizator ctlin04UAIC.VlasCatalin ctlin04 Data 16 august 2011 18:35:36
Problema Ordine Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.22 kb
program ordine2;
var a:array ['a'..'z'] of longint;
    b:array [1..26] of char;
    i,j,n,k,p1,p2:longint;
    c:char;
    fi,fo:text;
begin
assign(fi,'ordine.in');
 assign(fo,'ordine.out');
reset(fi);
 rewrite(fo);
while not seekeof(fi) do begin
         read(fi,c);
         inc(a[c]);
         end;
for c:='a' to 'z' do
 if a[c]>0 then begin
                  inc(n);
                  b[n]:=c;
                 end;
p1:=1; p2:=2;
while (p1<=n) and (p2<=n) do begin
     repeat
      write(fo,b[p1]);
      dec(a[b[p1]]);
      write(fo,b[p2]);
      dec(a[b[p2]]);
      until (a[b[p1]]=0) or (a[b[p2]]=0);
  if (a[b[p1]]=0) and (a[b[p2]]=0) then begin
                     if p2>p1 then begin
                                    p1:=p2+1;
                                     p2:=p2+2;
                                     end;
                     if p1>p2 then begin
                                    p1:=p1+1;
                                    p2:=p1+1;
                                    end;
                                  end
  else
    if a[b[p1]]=0 then p1:=p2+1
    else if p1>p2 then p2:=p1+1
     else inc(p2);
 end;
if (p1<=n) or (p2<=n) then write(fo,b[n]);
close(fo);
end.