Помогите с программой

Hellsing · #1 27.04.2006, 00:14

Может кто шарит..... а может и нет.... но все равно спрошу.....
У меня курсач на тему: Внешняя многофазная сортировка слиянием. Можешь язык поломать(((( Не знаю как сделать..... как эту гребанную сортировку слить???? Как на зло в нете не нашел алгоритма на Delphi.
Как я понимаю тут 2 массива и необходимо отсортировать слиянием. Помогите кто знает как....
Заранее благодарен)))

shamm · #2 04.05.2009, 22:36

Голову долго ломал и в итоге сам что-то написал

shamm · #3 04.05.2009, 22:41

Код:

procedure TForm1.Button1Click(Sender: TObject); // создать и заполнить массив произвольными элементами
 
var
    i   : integer;  // параметр цикла
 
begin
  elm:=StrToInt(Edit1.Text); // кол-во элементов массива
  Randomize; // инициализация генератора псевдослучайных чисел
if  (elm < 1) then
  begin
    ShowMessage('Oшибка. Массив не создан!');
    elm:=0;
  end
else begin
  StringGrid1.colcount:=elm; // ввод размерности массива
  StringGrid2.colcount:=elm;
  StringGrid4.colcount:=elm;
  end;
for i:=1 to elm do
    StringGrid1.Cells[i-1,0]:= IntToStr(Random(max)+1); // заполнение массива элементами
Button2.Visible:=true; // кнопка сортировки видима
 
 
end;
 
procedure TForm1.Button2Click(Sender: TObject); //сортировка
const
  bf = 6; //размер буфера
var
  buf :array [1..bf] of integer; // задаем буфер
  serBeg,ser,sera,serb,seraBeg,serbBeg : integer; //начало серии в массиве
  pust,pustf :integer; // число пустых элементов, серий в промежуточном массиве
 
  f,f1,f2: integer; // числа Фибоначчи
  p1,p2,p3: integer; // число элементов в отрезках
  m : array [1..3,1..2] of integer; // хранение длины и числа серий
  a,b,c :integer;
  h, min, s, ms:word;
 
procedure BubbleSort;    // подпрограмма сортировки пузырьком
var
i,j,x : integer;
 
begin
    for i :=1 to bf-1 do
      for j := i+1 to bf do
        if buf[i]>buf[j] then
          begin x := buf[i];
            buf[i] := buf[j];
            buf[j] := x
          end;
end;
 
begin
  serBeg:=0; // начало отсчета серии
  pust:=0; // обнуление количества пустых элементов
  ser:=0; // количество серий
 
  sera:=0; // число серий в массиве a
  serb:=0; // число серий в массиве b
  seraBeg:=1; // начало первой серии в массиве а
  serbBeg:=1; // начало первой серии в массиве b
T2.ColCount:=0;
T3.ColCount:=0;
T1.ColCount:=0;
Label6.Caption:= FloatToStr(Time);
while (serbeg<elm) do
begin
  for i:=1 to bf do   // перенос первой серии в буфер
  begin
    if (serBeg+i)<= elm then
      begin
        buf[i]:= StrToInt(StringGrid1.Cells [serBeg-1+i,0]); //считываем серию и заносим в буфер
         
      end
    else
      begin
        buf[i]:= 0;   // заполнение недостающих элементов нулями
 
        pust:=pust+1;   // счетчик лишних нулей
      end;
  end;
 
 
 BubbleSort;              // сортировка буфера пузырьком
 ser:=ser+1;              // счетчик общих серий
 
      // перенос из буфера в вспомогательный массив
T1.ColCount:=serBeg+bf; //размер вспомог массива
 for i:=1 to bf do   //запись серии из буфера в a
    T1.Cells[serBeg-1+i,0]:=IntToStr(buf[i]); // вывод буфера на 2
    serBeg := serBeg+bf;      //конец след серии
 
end;
 
// вычисление чисел Фибоначчи
 
f1:=0;f2:=1; // первые числа Фибоначчи
f:=f1+f2; //след число
while(f<ser) do
  begin
    f1:=f2;
    f2:=f;
    f:=f1+f2;
  end;
pustf:=f-ser;
 
// добавляем фиктивные серии
for j:=1 to pustf do
  begin
    ser:=ser+1;              // счетчик общих серий
    T1.ColCount:=serBeg+bf; //размер вспомог массива
    for i:=1 to bf do   //запись серии из буфера в a
        begin
        T1.Cells[serBeg-1+i,0]:=IntToStr(0); // вывод буфера на 2
        pust:= pust+1;
        end;
    serBeg := serBeg+bf;      //конец след серии
 
  end;
 
 
//распределение серий по массивам в второй запишемменьшее число Фибоначчи
p1:=bf*f1; //кол -во элементов во втором массиве
p2:=bf*f2; //кол -во элементов в третьем массиве
p3:=p1+p2; //общее число элементов
 
 
T2.ColCount:=p1;
T3.ColCount:=p2;
for i:=1 to p1 do               // Перенесем в 4 массив p1 элементов
T2.Cells[i-1,0]:=T1.Cells[i-1,0];
p1:=p1;
for i:=1 to p2 do               // Перенесем в 5 массив остальные элементы
T3.Cells[i-1,0]:=T1.Cells[i-1+p1,0];
// создадим массив для размера 3х3 столбцы - ленты, 1 строка - длина серии,
// 2 строка элементов в серии, 3 строка -элементов в массиве
// заполним его элементами
 
 
 
m[1,1]:=0;   // серий в 1 массиве
m[2,1]:=f1;   // серий в 2 массиве
m[3,1]:=f2;    // серий в 3 массиве
m[1,2]:=0;   // длина серий в 1 массиве
m[2,2]:=bf;   // длина серий в 2 массиве
m[3,2]:=bf;    // длина серий в 3 массиве
 
// перематываем все ленты на начало
i:=1;
j:=1;
k:=1;
 
while m[1,1]+m[2,1]+m[3,1]<>1 do //выполняем, пока на лентах не останется только одна серия
begin
 
 
 if m[1,1]=0 then  //сливаем 2и3 ленты на 1
  begin
    k:=1;  //начало ленты
    m[1,2]:=m[2,2]+m[3,2]; //новая длина серии в 1 ленте
    if m[2,1]<m[3,1] then T1.ColCount:=m[2,1]*m[1,2]
    else T1.ColCount:=m[3,1]*m[1,2];  //новая длина 1 ленты
    while m[2,1]*m[3,1]<>0 do //пока число серий во 2 или 3 ленте не станет равным нулю
     begin
      b:=m[2,2];  //длина выбраной серии во 2-й ленте
      c:=m[3,2];  //длина выбраной серии в 3-й ленте
      while (b*c)<>0 do
        begin
          if StrToInt(T2.Cells[i-1,0]) < StrToInt(T3.Cells[j-1,0])then   //сравниваем элементы
           begin
            T1.Cells[k-1,0]:= T2.Cells[i-1,0];
            i:=i+1;
            b:=b-1;
           end
          else
           begin
            T1.Cells[k-1,0]:= T3.Cells[j-1,0];
            j:=j+1;
            c:=c-1;
           end;
          k:=k+1;
        end;
      if b=0 then
       begin
        while c<>0 do
          begin
            T1.Cells[k-1,0]:= T3.Cells[j-1,0];
            j:=j+1;
            c:=c-1;
            k:=k+1;
          end;
       end
      else
       begin
        while b<>0 do
          begin
            T1.Cells[k-1,0]:= T2.Cells[i-1,0];
            i:=i+1;
            b:=b-1;
            k:=k+1;
          end;
       end;
      m[1,1]:=m[1,1]+1;
      m[2,1]:=m[2,1]-1;
      m[3,1]:=m[3,1]-1;
     end;
 
  k:=1; //перемотка ленты на начало
  end
 
else if m[2,1]=0 then  //сливаем 1и3 ленты на 2
  begin
    i:=1; //начало ленты
    m[2,2]:=m[1,2]+m[3,2]; //новая длина серии для 2 ленты
    if m[1,1]<m[3,1] then T2.ColCount:=m[1,1]*m[2,2]
    else T2.ColCount:=m[3,1]*m[2,2];  //новая длина 2 ленты
    while m[1,1]*m[3,1]<>0 do //пока число серий в 1 или 3 ленте не станет равным нулю
     begin
      a:=m[1,2];  //длина выбраной серии во 2-й ленте
      c:=m[3,2];  //длина выбраной серии в 3-й ленте
      while (a*c)<>0 do
        begin
          if StrToInt(T1.Cells[k-1,0]) < StrToInt(T3.Cells[j-1,0])then   //сравниваем элементы
           begin
            T2.Cells[i-1,0]:= T1.Cells[k-1,0];
            k:=k+1;
            a:=a-1;
           end
          else
           begin
            T2.Cells[i-1,0]:= T3.Cells[j-1,0];
            j:=j+1;
            c:=c-1;
           end;
          i:=i+1;
        end;
      if a=0 then
       begin
        while c<>0 do
          begin
            T2.Cells[i-1,0]:= T3.Cells[j-1,0];
            j:=j+1;
            c:=c-1;
            i:=i+1;
          end;
       end
      else
       begin
        while a<>0 do
          begin
            T2.Cells[i-1,0]:= T1.Cells[k-1,0];
            k:=k+1;
            a:=a-1;
            i:=i+1;
          end;
       end;
      m[2,1]:=m[2,1]+1;
      m[1,1]:=m[1,1]-1;
      m[3,1]:=m[3,1]-1;
     end;
 
  i:=1; // перемотка ленты 2 на начало
  end
 
else if m[3,1]=0 then  //сливаем 1и 2 ленты на 3
  begin
    j:=1; //начало ленты
    m[3,2]:=m[1,2]+m[2,2]; //новая длина серии 3
    if m[1,1]<m[2,1] then T3.ColCount:=m[1,1]*m[3,2]
    else T3.ColCount:=m[2,1]*m[3,2];  //новая длина 3 ленты
    while m[1,1]*m[2,1]<>0 do //пока число серий в 1 или 2 ленте не станет равным нулю
     begin
      a:=m[1,2];  //длина выбраной серии во 2-й ленте
      b:=m[2,2];  //длина выбраной серии в 3-й ленте
      while (a*b)<>0 do
        begin
          if StrToInt(T1.Cells[k-1,0]) < StrToInt(T2.Cells[i-1,0])then   //сравниваем элементы
           begin
            T3.Cells[j-1,0]:= T1.Cells[k-1,0];
            k:=k+1;
            a:=a-1;
           end
          else
           begin
            T3.Cells[j-1,0]:= T2.Cells[i-1,0];
            i:=i+1;
            b:=b-1;
           end;
          j:=j+1;
        end;
      if a=0 then
       begin
        while b<>0 do
          begin
            T3.Cells[j-1,0]:= T2.Cells[i-1,0];
            i:=i+1;
            b:=b-1;
            j:=j+1;
          end;
       end
      else
       begin
        while a<>0 do
          begin
            T3.Cells[j-1,0]:= T1.Cells[k-1,0];
            k:=k+1;
            a:=a-1;
            j:=j+1;
          end;
       end;
      m[3,1]:=m[3,1]+1;
      m[1,1]:=m[1,1]-1;
      m[2,1]:=m[2,1]-1;
     end;
 
  j:=1; // перемотка ленты 2 на начало
 
  end;
 
  
end;
 
 
 
// отбрасываем пустые элементы, выводим результаты
if m[1,1]=1 then
for i:=1 to elm do
  begin
    StringGrid2.Cells[i-1,0]:=T1.Cells[i-1+pust,0];
    StringGrid4.Cells[elm-i,0]:=T1.Cells[i-1+pust,0];
 
 
  end;
if m[2,1]=1 then
for i:=1 to elm do
  begin
    StringGrid2.Cells[i-1,0]:=T2.Cells[i-1+pust,0];
    StringGrid4.Cells[elm-i,0]:=T2.Cells[i-1+pust,0];
 
  end;
if m[3,1]=1 then
for i:=1 to elm do
  begin
    StringGrid2.Cells[i-1,0]:=T3.Cells[i-1+pust,0];
    StringGrid4.Cells[elm-i,0]:=T3.Cells[i-1+pust,0];
 
  end;
DecodeTime(Time-StrToFloat(Label6.Caption), h, min, s, ms);
Label6.Caption:= IntToStr(s)+'s '+ IntToStr(ms)+'ms';
Edit2.Visible:=true;
 
end;
 
 
end.

PhoeniX · #4 04.05.2009, 22:56

ТЕГИ ГДЕ???

//Может, зделать меня модером... АДМ, в личку плз требования к модеру, скорее всего подойду...

Страдалецъ · #5 04.05.2009, 23:39

Просвятите неуча. Какова дальнейшая практическая цель в этой портянке?

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты