Cod sursa(job #112315)
Utilizator | Data | 4 decembrie 2007 13:55:43 | |
---|---|---|---|
Problema | Ordine | Scor | 0 |
Compilator | fpc | Status | done |
Runda | Arhiva de probleme | Marime | 2 kb |
var v:array [1..1000] of char;
f,g:text;
f1:boolean;
aux:char;
n,i,j,k:word;
begin
assign(f,'ordine.in');
reset(f);
assign(g,'ordine.out');
rewrite(g);
i:=0;
while eoln(f)=false do
begin
i:=i+1;
read(f,v[i]);
end;
n:=i;
aux:=v[1];
v[1]:=v[2];
v[2]:=aux;
i:=2;
while i<n-1 do
begin
j:=i;
if v[j]=v[j-1] then
begin
f1:=true;
k:=1;
while f1=true do
begin
if (v[j+k]<>v[j]) and (v[j+k+1]<>v[j]) then
begin
aux:=v[j];
v[j]:=v[j+k];
v[j+k]:=aux;
f1:=false;
end else k:=k+1;
end;
end;
i:=i+1;
end;
i:=n-1;
while i>1 do
begin
j:=i;
if v[j]=v[j+1] then
begin
f1:=true;
k:=1;
while f1=true do
begin
if (v[j-k]<>v[j]) and (v[j-k-1]<>v[j]) then
begin
aux:=v[j];
v[j]:=v[j-k];
v[j-k]:=aux;
f1:=false;
end else k:=k+1;
end;
end;
i:=i-1;
end;
for i:=1 to n do
write(g,v[i]);
close(f);
close(g);
end.