Метод Шелла

Тема в разделе "Pascal and Delphi", создана пользователем vihlyaev, 17 дек 2010.

Статус темы:
Закрыта.
  1. vihlyaev

    vihlyaev Гость

    :sorry: Программно реализовать алгоритм сортировки Методом Шелла. Каждая запись будет в качестве ключа содержать текстовое выражение, а в качестве информативной части некоторое число.

    Тестовый набор записей перед сортировкой необходимо загрузить в память из файла. Файл с тестовым набором необходимо создать. Затем при необходимости изменить у него кодировку (в зависимости от того, в какой ОС Вы осуществляете программную реализацию). После этого для каждой записи берем в качестве ключа слово из исходного файла, а для информативной части его порядковый номер в исходном тексте. Для преобразования текстового файла в набор записей также необходимо выполнить программную реализацию, которая к тому же должна предусматривать создания определенного количества записей.

    Пожалуйста, помогите переделать procedure mov, на метод Шелла для этой программы.

    Код (Delphi):
    {$r+}
    uses crt,dos;
    var max,Mi,Mj,bi,bj,q3:integer;
    f1:file of char;
    f2,f3:text;
    q,q1:char;
    s:string;
    BOUND,t:integer;
    a:array [1..30,1..1803] of char;
    h_h,m_m,s_s,hund_h:word;
    label B1,B2,B3,B4,B5,exit;
    Function cmp(a1,a2:integer):byte;
    var k:integer;
    begin
    cmp:=2;
    for k:=1 to 20 do
    begin
    if ord(a[k,a1])>ord(a[k,a2]) then begin cmp:=1;break;end;
    if ord(a[k,a1])<ord(a[k,a2]) then begin cmp:=0;break;end;
    end;
    end;
    procedure mov(b1,b2:integer);
    var
    tmp: array [1..20] of char;
    i1:integer;
    begin
    for i1:=1 to 20 do begin
    tmp[i1]:=a[i1,b1];
    a[i1,b1]:=a[i1,b2];
    a[i1,b2]:=tmp[i1];
    end;

    end;
    var i,j:integer;
    begin
    clrscr;
    assign (f1,'D:\PO\1.txt');
    assign (f2,'D:\PO\2.txt');
    assign (f3,'D:\PO\3.txt');
    reset (f1);
    rewrite (f2);
    rewrite (f3);
    Mj:=1;
    Mi:=1;
    i:=1;
    s:='1 ';
    q1:='1';
    while not eof(f1) do
    begin
    read (f1,q);
    if (q <> (' ')) then
    begin
    if (q <> chr(10)) and (q <> chr(13)) then
    s:=s+q;
    a[Mi,Mj]:=q;
    inc(Mi);
    end
    else if q1 <> ' ' then begin
    if s='' then continue;
    inc(i);
    inc(Mj);
    Mi:=1;
    write (f2,s);
    writeln(f2);
    write (f2,i,' ');
    s:='';
    end;
    q1:=q;
    end;
    {###################################################################}
    {niinia ?1}
    {###################################################################}
    {niinia ?2}
    {###################################################################}
    {###################################################################}
    {niinia ?3}
    begin
    writeln('__________________________________');
    writeln('Sotirovka metodom prostih vstavok');
    gettime(h_h,m_m,s_s,hund_h);
    writeln('time ',h_h,':',m_m,':',s_s,'.',hund_h);
    max:=1;
    for j:=1803 downto 2 do
    begin
    for i:=1 to 1803 do
    if cmp(i,max)=1 then max:=i;
    mov(max,j);
    end;
    end;
    gettime(h_h,m_m,s_s,hund_h);
    writeln('time ',h_h,':',m_m,':',s_s,'.',hund_h);
    writeln('__________________________________');
    {###################################################################}
    exit:
    for mj:=1 to 1803 do
    begin
    for mi:=1 to 20 do
    write(f3,a[Mi,Mj]);
    writeln(f3);
    end;
    close (f1);
    close (f2);
    close (f3);
    writeln('succesful! Press enter');
    readln;
    end.
    :rolleyes: :please: :please: :please: :please:
     
  2. nayke

    nayke Well-Known Member

    Регистрация:
    4 авг 2010
    Сообщения:
    310
    Симпатии:
    0
Загрузка...
Статус темы:
Закрыта.

Поделиться этой страницей