Cod sursa(job #141462)

Utilizator vrvpVlad Veigang vrvp Data 23 februarie 2008 11:58:07
Problema Ordine Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.21 kb
var a:Array[1..30] of longint;
b:Array['a'..'z'] of longint;
f,g:text;
c,l,k,t:char;
j,min,nr,i,p,x,y,nr2: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
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);
repeat
k:=succ(l);
caut(k,k,ok);
if b[l]<=b[k] then begin
              for i:=1 to b[l] do
                       write(g,l,k);

               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
                      write(g,l,k);
             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
         write(g,l,k);
b[l]:=b[l]-b[k];
b[k]:=0;
caut(succ(k),k,ok);
end;
until not ok;
if b[l]=1 then
          write(g,l)
else
if b[k]=1 then
          write(g,k);











 { 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]); }
close(g);
end.