Cod sursa(job #142499)

Utilizator victoria12345Victoria Secreat victoria12345 Data 24 februarie 2008 17:59:37
Problema Ordine Scor 10
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.6 kb
var a:Array[1..1000000] of char;
b:Array['a'..'z'] of longint;
f,g:text;
c,l,k,t:char;
j,min,nr,i,p,x,y,poz:longint;
ok:boolean;

{procedure caut(c:char;var d:char;var ok:boolean);
begin
d:=c;
while (b[d]=0) and (d<='z') do
      inc(d);
if d>'z' then
         ok:=false
         else
         ok:=true;
end;}

procedure caut(c:char ;var d:char;var ok:boolean);

begin
d:=c;ok:=true;
while(d>='a') and( b[d]=0) do
              dec(d);
if d>='a' then ok:=true
else ok:=false;
end;




begin
assign(f,'ordine.in');reset(f);
assign(g,'ordine.out');rewrite(g);
for l:='a' to 'z' do
    b[l]:=0;

while not eof(f) do begin
      while not eoln(f) do begin
                read(f,c);
                inc(b[c]);
      end;
readln(f);
end;
l:='z';


while b[l]=0 do
      dec(l);
      k:=pred(l);
p:=0;
repeat
caut(pred(l),k,ok);
if ok then begin
       while (b[l]<>0) and (b[k]<>0) do
             begin
             inc(p,2);
             a[p-1]:=l;a[p]:=k;
             dec(b[l]);dec(b[k]);
             end;
       if b[k]<>0 then l:=k
       else if b[l]=0  then
       caut(pred(l),l,ok);
       end;

until not ok;
c:='a';
while (c<='z') and (b[c]=0) do
               inc(c);
               if c<='z' then begin
                  nr:=b[c];

                    end;
if a[p]<>c then begin
   inc(p);a[p]:=c;dec(nr);end;
write(g,a[p]);
for i:=p-1 downto 1 do
    if (nr>0)and (a[i+1]<>c) and(a[i]<>c) then
                 begin
                 write(g,c,a[i]);dec(nr);
                 end
                 else write(g,a[i]);
    close(g);
    end.