Cod sursa(job #138072)

Utilizator vrvpVlad Veigang vrvp Data 17 februarie 2008 20:27:42
Problema Ordine Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.33 kb
var a:Array[1..30] of longint;
b:Array[1..30] of char;
f,g:text;
c,l:char;
t,j,min,k,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;
begin
assign(f,'ordine.in');reset(f);
assign(g,'ordine.out');rewrite(g);
for l:='a' to 'z' do begin
    inc(t);
    b[t]:=l;
end;

while not eof(f) do
      while not eoln(f) do begin
                read(f,c);
                inc(a[ord(c)-ord('a')+1])
      end;
i:=1;
while a[i]=0 do
      inc(i);
k:=1;
while k<=30 do begin
  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.