Технический форум
Вернуться   Технический форум > Программирование > Форум программистов > Помощь студентам


Ответ
 
Опции темы Опции просмотра
Старый 14.12.2013, 19:36   #1 (permalink)
Cassan
Member
 
Регистрация: 09.12.2013
Сообщений: 18
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
Talking Turbo Pascal: сортировка вставками

Помогите отредактировать программу, чтобы правильно заработала.
Условие было такое:Дан одномерный массив, отсортировать первую его половину по возрастанию, а вторую по убыванию.
Здесь применялась сортировка вставками, но в самой процедуре ошибки. Помогите исправить, чтобы заработало.

Код:
Uses Crt;
Const		N = 50;
Type 		T_Mas = Array [1..N] of Integer;
Var		Mas	: T_Mas;
		Kol	: Integer;

				
Procedure Count (Var Kol:Integer);
{Процедура определения размерности массива}
Var		IOR	: Word;
Begin
Write('Введите размерность массива: ');
	Repeat
		{$I-} ReadLn(Kol); {$I+}
		IOR := IOResult;
		If odd(IOR) or (Kol>N) Then
			WriteLn('Ошибка. Повторите ввод.')
	Until (Kol<=N) and (IOR=0)
End;


Procedure Filling (Kol:Integer; Var A: T_Mas);
{Процедура заполнения массива}
Var I : Integer;
Begin
	Randomize;
	For I := 1 To Kol Do A[I] := Random(N)
End;


Procedure Print (Kol:Integer; A: T_Mas);
{Процедура вывода массива}
Var I : Integer;
Begin
	For I:=1 to Kol do Write (A[I], ' ')
End;

Procedure Vstavkami (Kol:Integer; var A: T_Mas);
var k,i,j,buf:byte;
begin
k:= Kol div 2;
{сортировка вставками по возрастанию первой половины}
for i:=2 to k-1 do
  begin
    buf:=a[i];
    j:=i-1;
    while (j>=1) and (a[j]>buf) do
    begin
      a[j+1]:=a[j];
      j:=j-1;
    end;
    a[j+1]:=buf;
  end;
end;
{сортировка вставками по убыванию второй половины}
for i:=2 to Kol-1 do
  begin
    buf:=a[i];
    j:=i-1;
    while (j>=1) and (a[j]<buf) do
    begin
      a[j+1]:=a[j];
      j:=j-1;
    end;
    a[j+1]:=buf;
  end;
end;
Begin
	ClrScr;
	Count(Kol);
	Filling(Kol, Mas);
	WriteLn('Исходный массив'); Print (Kol, Mas);
	Vstavkami (Kol, Mas);
	WriteLn;
	WriteLn('Отсортированный массив'); Print (Kol, Mas);
	Repeat until KeyPressed
End.
Cassan вне форума   Ответить с цитированием

Старый 14.12.2013, 19:36
Helpmaster
Member
 
Аватар для Helpmaster
 
Регистрация: 08.03.2016
Сообщений: 0

Можно поискать нужные ответы тут

Turbo Pascal Пирамидальная сортировка
Сортировка Turbo Pascal
Turbo Pascal
Turbo Pascal
Turbo Pascal
Turbo Pascal

Старый 14.12.2013, 22:09   #2 (permalink)
Vladimir_S
Специалист
 
Аватар для Vladimir_S
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 26,304
Сказал(а) спасибо: 290
Поблагодарили 512 раз(а) в 169 сообщениях
Репутация: 93301
По умолчанию

Да... стал отлаживать, сам подзапутался, но сейчас вынужден прерваться. Завтра с утра доведу до ума.
__________________
With Mozilla Firefox - straight to communism!
Vladimir_S вне форума   Ответить с цитированием
Старый 14.12.2013, 23:53   #3 (permalink)
Cassan
Member
 
Регистрация: 09.12.2013
Сообщений: 18
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
По умолчанию

уже не нужно)
Cassan вне форума   Ответить с цитированием
Старый 15.12.2013, 10:02   #4 (permalink)
Vladimir_S
Специалист
 
Аватар для Vladimir_S
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 26,304
Сказал(а) спасибо: 290
Поблагодарили 512 раз(а) в 169 сообщениях
Репутация: 93301
По умолчанию

Цитата:
Сообщение от Cassan Посмотреть сообщение
уже не нужно)
И тем не менее (вдруг пригодится; в частности, фильтр ввода размера массива у Вас сделан безобразно):
Код:
Uses Crt;
Const
 N = 50;
Type
 T_Mas = Array [0..N+1] of Integer;
Var
 Mas: T_Mas;
 Kol: Integer;


Procedure Count (Var Kl:Integer);
Var
 IOR:Word;
 B:boolean;
Begin
 {$I-}
 Write('Enter the array dimension: ');
 Repeat
  B:=true;
  ReadLn(Kl);
  IOR:= IOResult;
  If IOR<>0 then
   begin
    Writeln('Enter the integer value!');
    B:=false;
   end;
  If B and ((Kl<2) or (Kl>N)) then
   begin
    Writeln('Value out of range!');
    B:=false;
   end;
  If B and Odd(Kl) then
   begin
    Writeln('Dimension must be even!');
    B:=false;
   end;
  If Not(B) then Write('Error. New value: ')
 Until B;
 {$I+}
End;


Procedure Filling (Kl:Integer; Var A: T_Mas);
Var
 i:Integer;
Begin
 Randomize;
 For i:= 1 to Kl do A[i]:= Random(N)
End;


Procedure Print(Kl:Integer; A: T_Mas);
Var
 i: Integer;
Begin
  For i:=1 to Kl do Write(A[i]:4)
End;

Procedure Vstavkami (Kl:integer; var A: T_Mas);
var
 k,i,j,buf,q:byte;
begin
 A[0]:=0;
 A[Kl+1]:=0;
 k:= Kl div 2;
 {First half Insert sorting}
 for i:=2 to k do
  begin
   j:=i;
   while A[j-1]>A[j] do
    begin
      buf:=A[j-1];
      A[j-1]:=A[j];
      A[j]:=buf;
      Dec(j);
    end;
  end;
 {Second half Insert sorting}
 for i:=Kl-1 downto k+1 do
  begin
   j:=i;
   while A[j+1]>A[j] do
    begin
      buf:=A[j+1];
      A[j+1]:=A[j];
      A[j]:=buf;
      Inc(j);
    end;
  end;
end;

Begin
 ClrScr;
 Count(Kol);
 Filling(Kol, Mas);
 WriteLn('Initial array:');
 Print (Kol, Mas);
 Vstavkami (Kol, Mas);
 WriteLn;
 WriteLn('Sorted array:');
 Print (Kol, Mas);
 ReadKey
End.
__________________
With Mozilla Firefox - straight to communism!
Vladimir_S вне форума   Ответить с цитированием
Ads

Яндекс

Member
 
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
Ответ

Опции темы
Опции просмотра

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Выкл.
HTML код Выкл.
Trackbacks are Вкл.
Pingbacks are Вкл.
Refbacks are Выкл.




Часовой пояс GMT +4, время: 00:21.

Powered by vBulletin® Version 6.2.5.
Copyright ©2000 - 2014, Jelsoft Enterprises Ltd.