Cod sursa(job #141512)

Utilizator vrvpVlad Veigang vrvp Data 23 februarie 2008 12:36:47
Problema Ordine Scor 10
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.33 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;
{function numar3(var j:longint):longint;
var k:integer;
begin
for k:=j+1 to 30 do
           if a[k]<>0 then begin
                      inc(nr);
                              if nr=3 then begin
                                      numar3:=k;
                                      break;
                              end;
           end;
end;
function numar1(var j:longint):longint;
var k:integer;
begin
for k:=j+1 to 30 do
           if a[k]<>0 then begin
                      numar1:=k;
                      exit;
           end;
end;
function numar2(var j:longint):longint;
var k,nr,x:byte;
begin
nr:=0;
t:=0;
for k:=j+1 to 30 do
           if a[k]<>0 then begin
                      inc(nr);
                      if nr=2 then begin
                              numar2:=k;
                              exit;
                      end;
           end;
end; }
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;

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:='a';


while b[l]=0 do
      inc(l);
      k:=succ(l);
caut(k,k,ok);
repeat

if b[l]<b[k] then begin
              for i:=1 to b[l] do
                  begin
                       inc(p);
                       a[p]:=l;
                       inc(p);
                       a[p]:=k;
               end;
               b[k]:=b[k]-b[l];
               b[l]:=0;
               caut(succ(k),t,ok) ;
               l:=k;
               k:=t;
              end
else
if b[l]=b[k] then begin
             for i:=1 to b[l] do begin
                         inc(p);
                         a[p]:=l;
                         inc(p);
                         a[p]:=k;
             end;
             b[l]:=0;
             b[k]:=0;
             caut(succ(l),l,ok);
             caut(succ(l),k,ok);

end
else
begin
for i:=1 to b[k] do begin
              inc(p);
                         a[p]:=l;
                         inc(p);
                         a[p]:=k;
             end;
b[l]:=b[l]-b[k];
b[k]:=0;
caut(succ(k),k,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];

               if a[p]<>c  then begin
                           inc(p);
                           a[p]:=c;
                           nr:=nr-1;
               end;
               if nr<>0 then begin

           for i:=1 to p do
                    if a[i]=c then begin
                              poz:=i;
                              break;
                    end;
for i:=1 to poz-nr-1 do
         write(g,a[i]);
                       for i:=1 to nr do
                                write(g,c,a[poz-nr+i-1]);
                       for i:=poz to p do
                                  write(g,a[i]);
end;

end
else










 { ok:=false;
  if a[k]<>0 then begin
    inc(nr);
            if nr=2 then
              ok:=true;
            if ok then begin
              j:=k;
              break;
            end;
  inc(k);
  end
  else
  inc(i);
end;

while (a[i]<>0) or (a[j]<>0) do begin
      write(g,b[i],b[j]);
      dec(a[i]);
      dec(a[j]);
      nr2:=0;
      for p:=1 to 30 do
                    if a[p]<>0 then
                       inc(nr2);
                    if nr2=1 then
                      break;
                if (a[i]=0) and (a[j]=0) then begin
                          i:=numar1(i);
                          j:=numar2(j);
                end;
                if a[i]=0 then begin
                          i:=j;
                          j:=numar1(j);
                end
                else
                if a[j]=0 then
                          j:=numar1(j);
end;
for i:=1 to 30 do
  if a[i]<>0 then
    for k:=1 to a[i] do
    write(g,b[i]); }
for i:=1 to p do
         write(g,a[i]);
close(g);
end.