Сортирование масивов за один проход

[NightWishMaster]

Суть задания.

Есть 2-а массива integer. Нада их отсортировать в третий массив по возрастанию используя один цыкл.
Паскаль / Консольная дельфа.

[zetrix]

За один проход? Хм... А первые 2 массива сортированы?
Если нет, то я затрудняюсь...

[KORT]

 
uses crt;
Type Tmas=array[1..100] of integer;
var
   X,Y,Z:Tmas;
   c,k:byte;
 
procedure zap (Var mas:Tmas; var Dl:byte);
var i:byte;
begin
randomize;
Writeln('Введите длину массива и нажмите <Enter>');
readln(dl);
for i:=1 to dl do
mas[i]:=random(100);
end;
 
procedure vivod(var mas:Tmas; var Dl:byte);
var i:byte;
begin
for i:=1 to dl do
write(mas[i]:4,' ');
writeln;
end;
 
procedure sort(var mas:Tmas; var Dl:byte);
var i,j,max,i_max:byte;
begin
for i:=1 to dl-1 do
begin
max:=mas[i];
i_max:=i;
for j:=i+1 to dl do
if mas[j]>max then
begin
max:=mas[j];
i_max:=j;
end;
mas[i_max]:=mas[i];
mas[i]:=max;
end;
for i:=1 to dl do write (mas[i]:4,' ');
writeln;
end;
 
procedure sliv(var mas:Tmas; var Dlx,dly:byte);
var dx,dy,ix,iy,iz,i:integer;
begin
ix:=1;
iy:=1;
iz:=0;
While (ix<=dlx) and (iy<=dly) do
if X[ix]>Y[iy] then
begin
inc(iz);
Z[iz]:=X[ix];
inc(ix);
end
else
begin
inc(iz);
Z[iz]:=Y[iy];
inc(iy);
end;
if ix>dx then
for i:=iy to dly do
begin
inc(iz);
Z[iz]:=Y[i];
end
else
for i:=ix to dlx do
begin
inc(iz);
Z[iz]:=X[i];
end;
for i:=1 to dly+dlx do write(Z[i]:2,' ');
writeln;
end;
 
 
BEGIN
clrscr;

zap(x,c);

Write('    Массив Х:');
vivod(x,c);
write('Сортировка X:');
sort(x,c);
Writeln;
Writeln (' ');
writeln ('-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-');
Writeln (' ');
zap(y,k);
Write('    Массив Y:');
vivod(y,k);
write('Сортировка Y:');
sort(y,k);
Writeln;
Writeln (' ');
writeln ('-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-');
Writeln (' ');
write('     Слияние:  ');
sliv(z,c,k);
Writeln (' ');
writeln ('-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-');
Writeln (' ');
readkey;
END.

[Stilet]

Консольная дельфа.

А вот мой примерчик сортировки )

 
program Project1;
 
{$APPTYPE CONSOLE}
 
uses
SysUtils;
 
const a:array[1..5] of integer=(5,8,2,1,9);
b:array[1..9] of integer=(65,748,72,21,3,4,7,89,899);
var i,k:integer;
z:array of integer;
begin
//********* FOR ******************
if Length(a)<Length(b) then k:=length(b) else k:=length(a);
for i :=1 to k do
begin
 
if length(a)>=i then begin
[i] if Length(z)<=a[i] then setlength(z,a+1);
[i] z[a[i]]:=a;
end;
if length(b)>=i then begin
[i] if Length(z)<=b[i] then setlength(z,b+1);
[i] z[b[i]]:=b;
end;
end;
//********* FOR ******************
for k :=0 to length(z) do
begin
if z[k]<>0 then
write(z[k],' ');
end;
readln;
//******* END FOR ****************{}
//******* END FOR ****************{}
{ TODO -oUser -cConsole Main : Insert code here }
end.

[vit_galina]

Есть 2-а массива integer. Нада их отсортировать в третий массив по возрастанию используя один цыкл.
За один цикл не реализуется ни один метод сортировки одномерного массива. Можно использовать разные операторы цикла, но это будут все равно циклы.
Задача решается если два массива отсортированы и надо их слить, чтобы получился отсортированный массив.
Н.п. Даны массивы A[1..n] и B[1..m], массив С[1..k], где k=n+m можно получить следующим фрагментом:

 
I:=1;J:=1; K:=N+M;
FOR L:=1 TO K DO
BEGIN
IF A[i]< B[J] THEN BEGIN C[L]:=A[i]; I:=I+1; END
ELSE BEGIN C[L]:=B[J]; J:=J+1; END;
END;

[Stilet]

За один цикл не реализуется ни один метод сортировки одномерного массива

Неправда. См. мой код. Он ресурсоемок может быть, зато вполне рабочий
Это сортировка методом индексов.

[vit_galina]

Не стоит спорить, мы не знаем точной постановки задачи. В вашем примере два цикла. Реализаций может быть много.
Проверить не могу работу, в моей среде программа не будет работать. Мой пример реализован в TurboPascal 7.0
Нашла сданную давно программу и тут же при проверке обнаружила ошибки выхода за пределы массивов. Вот фрагмент из рабочего, исправленного модуля:

 
I:=1;J:=1; K1:=N+M;
FOR K:=1 TO K1 DO
BEGIN
IF (I<=N)AND (J<=M) THEN
IF A[i]< B[J] THEN BEGIN C[K]:=A[i]; I:=I+1; END
ELSE BEGIN C[K]:=B[J]; J:=J+1; END
ELSE
IF I>N THEN BEGIN C[K]:=B[J]; J:=J+1; END
ELSE BEGIN C[K]:=A[i]; I:=I+1; END;
END;

[NightWishMaster]

Спасибо за желпние помоч. Забыл уточнить, что низя использовать процедуры. Входные массивы несортированы. Воть..

Stilet, ваш код рабочий, но только на отрицательних числах входного массива прога вылетает. Шя попробую усовершенствовать чюток код.

Так же прога не видет если в масивах есть одинаковые числа.

[KORT]

Сообщение от NightWishMaster

Спасибо за желпние помоч. Забыл уточнить, что низя использовать процедуры. Входные массивы несортированы. Воть..

Держи без процедур

uses crt;
Type Tmas=array[1..100] of integer;
var
X,Y,Z:Tmas;
i,j,max1,i_max1,max2,i_max2,dl1,dl2:byte;
dx,dy,ix,iy,iz:integer;
BEGIN
clrscr;
randomize;
Write('Введите длину массива X и нажмите <Enter>');
readln(dl1);
for i:=1 to dl1 do
X[i]:=random(100);
Write('    Массив Х:');
for i:=1 to dl1 do
write(X[i]:4,' ');
writeln;
write('Сортировка X:');
for i:=1 to dl1-1 do
begin
max1:=X[i];
i_max1:=i;
for j:=i+1 to dl1 do
if X[j]>max1 then
begin
max1:=X[j];
i_max1:=j;
end;
X[i_max1]:=X[i];
X[i]:=max1;
end;
for i:=1 to dl1 do
write (X[i]:4,' ');
writeln;
writeln ('-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\');
Writeln;
Write('Введите длину массива Y и нажмите <Enter>');
readln(dl2);
for i:=1 to dl2 do
Y[i]:=random(100);
Write('    Массив Y:');
for i:=1 to dl2 do
write(Y[i]:4,' ');
writeln;
write('Сортировка Y:');
for i:=1 to dl2-1 do
begin
max2:=Y[i];
i_max2:=i;
for j:=i+1 to dl2 do
if Y[j]>max2 then
begin
max2:=Y[j];
i_max2:=j;
end;
Y[i_max2]:=Y[i];
Y[i]:=max2;
end;
for i:=1 to dl2 do
write (Y[i]:4,' ');
writeln;
writeln ('-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\');
Writeln;
write('     Слияние:  ');
begin
ix:=1;
iy:=1;
iz:=0;
While (ix<=dl1) and (iy<=dl2) do
if X[ix]>Y[iy] then
begin
inc(iz);
Z[iz]:=X[ix];
inc(ix);
end
else
begin
inc(iz);
Z[iz]:=Y[iy];
inc(iy);
end;
if ix>dx then
for i:=iy to dl2 do
begin
inc(iz);
Z[iz]:=Y[i];
end
else
for i:=ix to dl1 do
begin
inc(iz);
Z[iz]:=X[i];
end;
for i:=1 to dl2+dl1 do write(Z[i]:2,' ');
WRITELN;
end;
readkey;
END.

[NightWishMaster]

Сообщение от KORT

Держи без процедур

uses crt;
Type Tmas=array[1..100] of integer;
var
X,Y,Z:Tmas;
i,j,max1,i_max1,max2,i_max2,dl1,dl2:byte;
dx,dy,ix,iy,iz:integer;
BEGIN
clrscr;
randomize;
Write('Введите длину массива X и нажмите <Enter>');
readln(dl1);
for i:=1 to dl1 do
X[i]:=random(100);
Write('    Массив Х:');
for i:=1 to dl1 do
write(X[i]:4,' ');
writeln;
write('Сортировка X:');
for i:=1 to dl1-1 do
begin
max1:=X[i];
i_max1:=i;
for j:=i+1 to dl1 do
if X[j]>max1 then
begin
max1:=X[j];
i_max1:=j;
end;
X[i_max1]:=X[i];
X[i]:=max1;
end;
for i:=1 to dl1 do
write (X[i]:4,' ');
writeln;
writeln ('-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\');
Writeln;
Write('Введите длину массива Y и нажмите <Enter>');
readln(dl2);
for i:=1 to dl2 do
Y[i]:=random(100);
Write('    Массив Y:');
for i:=1 to dl2 do
write(Y[i]:4,' ');
writeln;
write('Сортировка Y:');
for i:=1 to dl2-1 do
begin
max2:=Y[i];
i_max2:=i;
for j:=i+1 to dl2 do
if Y[j]>max2 then
begin
max2:=Y[j];
i_max2:=j;
end;
Y[i_max2]:=Y[i];
Y[i]:=max2;
end;
for i:=1 to dl2 do
write (Y[i]:4,' ');
writeln;
writeln ('-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\');
Writeln;
write('     Слияние:  ');
begin
ix:=1;
iy:=1;
iz:=0;
While (ix<=dl1) and (iy<=dl2) do
if X[ix]>Y[iy] then
begin
inc(iz);
Z[iz]:=X[ix];
inc(ix);
end
else
begin
inc(iz);
Z[iz]:=Y[iy];
inc(iy);
end;
if ix>dx then
for i:=iy to dl2 do
begin
inc(iz);
Z[iz]:=Y[i];
end
else
for i:=ix to dl1 do
begin
inc(iz);
Z[iz]:=X[i];
end;
for i:=1 to dl2+dl1 do write(Z[i]:2,' ');
WRITELN;
end;
readkey;
END.

Тут явно больше 1-о цыкла использовано для сортировки.