Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Паскаль, Turbo Pascal, PascalABC.NET
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 19.12.2010, 00:24   #1
<<оля>>
Новичок
Джуниор
 
Регистрация: 19.12.2010
Сообщений: 1
Печаль Метод Шелла

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

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

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

Код:
{$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.
<<оля>> вне форума Ответить с цитированием
Старый 14.11.2011, 21:04   #2
Dasy
Новичок
Джуниор
 
Регистрация: 03.11.2011
Сообщений: 1
По умолчанию вот должно помочь

uses crt,timeunit;
const n=7000;
type DataItem=integer;
DataArray=array[0..n-1] of DataItem;
var a:DataArray;
i,nit:word;
f:text;
h, m, s, hund : Word;
Procedure PrintArr(a:DataArray);
begin
for i:=0 to n-1 do
write(a[i]:4);
end;
Procedure PrintArrF(s:string;k:integer;a:Data Array);
begin
write(f,nit:4,' h=',k,' ',s); nit:=nit+1;
for i:=0 to n-1 do
write(f,a[i]:4);
writeln(f);
end;
procedure Shell(var item: DataArray; n:integer);
const a:array[1..5] of byte = (9,5,3,2,1);
var i,j,k,gap:integer;
temp:DataItem;
begin
for k:=1 to 5 do
begin
gap:=a[k];
for i:=gap to n-1 do
begin
temp:=item[i];
j:=i-gap;
while (temp<item[j]) and (j>=0) do
begin
item[j+gap]:=item[j];
j:=j-gap;
{PrintArrF('j ',gap,item);}
end;
item[j+gap]:=temp;
{PrintArrF('i ',gap,item);}
end;
end;
end;
begin
writeln;
randomize;
for i:=0 to n-1 do
begin
a[i]:=random(30)-10;
end;
assign(f,'shell_rs.txt');
rewrite(f);
nit:=0;
PrintArrF('b ',0,a);
{PrintArr(a);}
ResetTimePoint; { Отметить начало отсчета времени }
Shell(a,n);
GetTimePoint(h,m,s,hund);
writeln(' Сортировка заняла ',h,' часов ',m,' минут ',s,'.',hund,' секунд.');
writeln;
{PrintArr(a);}
PrintArrF('= ',0,a);
close(f);
end.
(******************************)

{ Этот текст нужно скопировать в одтельный файл timeunit.pas }

unit timeunit;
interface
Procedure ResetTimePoint; { Отметить начало отсчета времени }
Procedure GetTimePoint(var dh, dm, ds, dhund : Word);
{ Выдать время от начала отсчета. См. процедуру SetTimePoint }
implementation
uses Dos;
type mytime=record
h, m, s, hund : Word; end;
var timebeg,timecurr:mytime;
Procedure ResetTimePoint; { Отметить начало отсчета времени }
begin
with timebeg do
GetTime(h,m,s,hund);
end;
Procedure GetTimePoint(var dh, dm, ds, dhund : Word);
Procedure DecHour(var t:mytime;dt:byte);
begin
if t.h>0 then dec(t.h);
end;
Procedure DecMin(var t:mytime;dt:byte);
begin
if t.m>dt-1 then dec(t.m,dt) else
begin
t.m:=60+t.m-dt;
DecHour(t,1);
end;
end;
Procedure DecSec(var t:mytime;dt:byte);
begin
if t.s>dt-1 then dec(t.s,dt) else
begin
t.s:=60+t.s-dt;
DecMin(t,1);
end;
end;
Procedure DecDSec(var t:mytime;dt:byte);
begin
if t.hund>dt-1 then dec(t.hund,dt) else
begin
t.hund:=60+t.hund-dt;
DecSec(t,1);
end;
end;
{ Выдать время от начала отсчета. См. процедуру SetTimePoint }
begin
with timecurr do
begin
GetTime(h,m,s,hund);
if hund>=timebeg.hund then dhund:=hund-timebeg.hund
else begin dhund:=100+hund-timebeg.hund; DecSec(timecurr,1) end;
if s>=timebeg.s then ds:=s-timebeg.s
else begin ds:=60+s-timebeg.s; DecMin(timecurr,1) end;
if m>=timebeg.m then dm:=m-timebeg.m
else begin dm:=60+m-timebeg.m; DecHour(timecurr,1) end;
if h>=timebeg.h then dh:=h-timebeg.h
else dh:=24+h-timebeg.h;
end;
end;
begin
ResetTimePoint
end.


{Все. Дальше пошли справочные материалы. Сначала текст на С, а потом неработающий на Паскале }
(*
void shall_sort(int *array, int n)
{
int i, j, k, gap, temp;
int a[] = {9, 5, 3, 2, 1};
for (k = 0; k < 5; k++) {
gap = a[k];
for (i = gap; i < n; i++) {
temp = array[i];
for (j = i-gap; temp < array[j] && j >= 0; j-=gap)
array[j+gap] = array[j];
array[j+gap] = temp;
}
}
}
*)
procedure Shell1(var item: DataArray; count:integer);
{ doesn't work }
const t = 5;
var i, j, k, s, m: integer;
h: array[1..t] of integer;
x: DataItem;
begin
h[1]:=9; h[2]:=5; h[3]:=3; h[4]:=2; h[5]:=1;
for m := 1 to t do
begin
k:=h[m];
s:=-k;
for i := k+1 to count do
begin
x := item[i];
j := i-k;
if s=0 then
begin
s := -k;
s := s+1;
item[s] := x;
end;
while (x<item[j]) and (j<count) do
begin
item[j+k] := item[j];
j := j-k;
end;
item[j+k] := x;
end;
end;
end; { конец сортировки Шелла }
Dasy вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Сортировка Шелла QuadroX Фриланс 1 29.05.2010 03:52
Задача Pascal (Сортировка метод Шелла) madmonk Помощь студентам 2 08.12.2009 17:37
Метод сортировки Шелла SVadiks Помощь студентам 2 03.11.2009 20:17
сортировка Шелла pilot76 Помощь студентам 2 17.08.2009 18:05