Cod sursa(job #120914)
Utilizator | Data | 7 ianuarie 2008 10:59:10 | |
---|---|---|---|
Problema | Ordine | Scor | 0 |
Compilator | fpc | Status | done |
Runda | Arhiva de probleme | Marime | 2.11 kb |
const fi='ordine.in';
fo='ordine.out';
var
f:text;
Ap:Array['a'..'z'] of longint;
u,k:longint;
uc,c,ch:char;
ok:boolean;
Begin
for c:='a' to 'z' do
Ap[c]:=0;
assign(f,fi);reset(f);
k:=0;
while Not eof(f) do
begin
read(f,c);
Ap[c]:=Ap[c]+1;
k:=k+1;
end;
close(f);
assign(f,fo);rewrite(f);
ch:='a';
while Ap[ch]=0 do
ch:=succ(ch);
u:=0; uc:=#0;
repeat
u:=u+1;
ok:=False;
For c:=ch to 'z' do
begin
if Ap[c]>=Trunc(k-u)/2+1 then begin
ok:=True;
break;
end
end;
if ok then begin
uc:=c;
Ap[c]:=Ap[c]-1;
write(f,c);
end
else begin
if (ch<>uc)and (ch<='z') then begin
uc:=ch;
Ap[ch]:=Ap[ch]-1;
write(f,ch);
end
else begin
c:=succ(ch);
while (Ap[c]=0) and (c<='z') and (c<>uc) do
c:=succ(c);
if c<='z' then begin
uc:=c;
Ap[c]:=Ap[c]-1;
write(f,c);
end;
end;
end;
while (Ap[ch]=0) and (ch<='z') do
ch:=succ(ch);
until u>=k;
close(f);
End.