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

  1. Нужна помощь, тема сложная улучшенные методы сортировки, метод пирамидальной сортировки, есть программа со всем необходимым, но не хватает процедуры сортировки. Условие такое: Дан одномерный массив, первую его половину элементов отсортировать по возрастанию, а вторую по убыванию. Добавить счётчик итераций(по возможности). По возрастанию есть небольшой кусок кода(просто как пример), но его нужно как-то адаптировать к программе(к моему условию) и плюс ещё добавить сортировку второй части по убыванию


textual

Код к задаче: «Пирамидальная сортировка - Turbo Pascal»

Uses Crt;
Const       N = 50;
Type        T_Mas = Array [0..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 not(Kol in [1..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 Sort(Kol: integer; var A: T_mas);
procedure Sort_1(var A: T_Mas; Count: Integer);
  procedure DownHeap(index, Count: integer; Current: integer);
  {Функция пробегает по пирамиде восстанавливая ее
  Также используется для изначального создания пирамиды
  Использование: Передать номер следующего элемента в index
  Процедура пробежит по всем потомкам и найдет нужное место для следующего элемента}
  var
    Child, k: Integer;
  begin
k:= Kol div 2;
for i:=1 to k-1 do
  begin
    while index < Count div 2 do
     begin
      Child := (index+1)*2-1;
      if (Child < Count-1) and (A[Child] < A[Child+1]) then
        Child:=Child+1;
      if Current >= A[Child] then
        break;
      A[index] := A[Child];
      index := Child;
    end;
    A[index] := Current;
  end;
 
procedure Sort_2(var A: T_Mas; Count: Integer);
  procedure DownHeap(index, Count: integer; Current: integer);
  {Функция пробегает по пирамиде восстанавливая ее
  Также используется для изначального создания пирамиды
  Использование: Передать номер следующего элемента в index
  Процедура пробежит по всем потомкам и найдет нужное место для следующего элемента}
  var
    Child, k: Integer;
  begin
k:= Kol div 2;
for i:=1 to k-1 do
  begin
    while index > Count div 2 do
     begin
      Child := (index+1)*2-1;
      if (Child > Count-1) and (A[Child] > A[Child+1]) then
        Child:=Child+1;
      if Current <= A[Child] then
        break;
      A[index] := A[Child];
      index := Child;
    end;
    A[index] := Current;
  end;
 
 
{Основная функция }
var
  i: integer;
  Current: integer;
begin
  {Собираем пирамиду}
  for i := (Count div 2)-1 downto 0 do
    DownHeap(i, Count, A[i]);
  {Пирамида собрана. Теперь сортируем}
  for i := Count downto 0 do begin
    Current := A[i];{перемещаем верхушку в начало отсортированного списка}
    A[i] := A[0];
    DownHeap(0, i, Current);{находим нужное место в пирамиде для нового элемента}
  end;
end;
{......................................................................}
Begin
ClrScr;
Count(Kol);
Filling(Kol, Mas);
WriteLn('Исходный массив');
Print (Kol, Mas);
 {................процедура пирамидальной сортировки..........}
sort(Mas,Kol);
WriteLn;
WriteLn('Отсортированный массив');
Print (Kol, Mas);
Repeat until KeyPressed
End.

СДЕЛАЙТЕ РЕПОСТ

9   голосов, оценка 4.222 из 5



Похожие ответы
  1. Помогите пожалуйста отсортировать двумерный массив по диагонали. Дано целое число N (0

  1. Есть двумерный символьный массив, [10,25], содержащий в себе строки с личными данными (условно, ФИО). Нужно эти строки отсортировать по алфавиту вставками (принципиально). Из идей только достаточно идиотская, через еще один массив, но она быстро была отброшена как несостоятельная. Прошу помощи, господа.

  1. Укажите пожалуйста на ошибку. Пытался отсортировать массив методом выбора, но что-то идет не так

  1. Отсортировать четные элементы массива с помощью простого выбора. ВНИМАНИЕ!!! Входные данные (исходный массив) и выходные данные (отсортированный массив) формировать в виде текстового файла, содержащего целые числа. есть наброски вот ...

  1. Друзья помогите. Условие задачи: Составить две программу, которые реализуют алгоритм ускоренной сортировки слов(строк) пузырьковым и слиянием. Исходные данные в водятся с клавиатуры. Я не могу понять,что такое УСКОРЕННАЯ сортировка. Я могу сделать методом пузырька например так:

  1. известна информация о 10 спортсменах фигуристах. его имя и оценки, полученные спортсменом по обязательной, произвольной и по короткой программе. вывести спортсменов в порядке возрастания полученных баллов. помогите, пожалуйста, решить

  1. Отсортировать положительные элементы одномерного массива, отрицательные оставить на местах. Пузырьковая сортировка.(Нужно сделать через 2 массива без процедур или через 1 массив.) Пример ввода массива: 1 -2 123 -3 -4 21 5 -9 0 23 После сортировки 0 -2 1 -3 -4 5 -9 21 23 123Delphi1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 program Project11;   {$APPTYPE CONSOLE} uses   SysUtils,   windows;   var mas:array [1..10] of integer; a,i,j:integer; begin SetConsoleCP(1251); SetConsoleOutputCP(1251);   for i:=1 to 10 do begin Writeln('Введите ',i,' Элемент'); readln(mas[i]); end; Writeln('Исходный Массив: '); for i:=1 to 10 do begin write(mas[i],' '); end; for i:=1 to 10-1 do begin for j:=1 to 10-1 do begin if (mas[j]>=0) and (mas[j]>mas[j+1]) then begin a:=mas[j+1]; mas[j+1]:=mas[j]; mas[j]:=a; end; end; end; Writeln; Writeln('После Сортировки: ');   for i:=1 to 10 do write(mas[i],' '); readln end.

  1. Здравствуйте , прошу помочь разобраться с сортировкой хоара. вот код из книги ( а не из инета с характерными опечатками в коде , из-за которого ломаешь голову (наболело ж) ) ) . выдает ошибку - переполнения стека (stack overflow )