Сортировка естественным слиянием

@maxla91 · Регистрация: 04.12.2009

Студворк — интернет-сервис помощи студентам

вот задача:

Pascal
1
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
uses crt;
procedure sort(name:string;var f:text);
var s1,s2,a1,a2,where,tmp:integer;
f1,f2:text;
begin
s1:=5;
s2:=5;
assign(f,name);
assign(f1,' ');
assign(f2,' ');
while(s1>1) and(s2>=1)do
begin
where:=1;
s1:=0;
s2:=0;
reset(f);Rewrite(f1);rewrite(f2);
read(f,a1);
write(f1,a1,' ');
while not EOF(f) do
begin
read(f,a2);
if(a2<a1)then
begin
case where of
1:begin
where:=2;
inc(s1);
end;
2:begin
where:=1;
inc(s2);
end;end;end;
case where of
1:write(f1,a2,' ');
2:write(f2,a2,' ');
end;
a1:=a2;
end;
if where=2 then
inc(s2)
else inc(s1);
close(f);
close(f1);
close(f2);
rewrite(f);
reset(f1);
reset(f2);
read(f1,a1);
read(f2,a2);
while(not EOF(f1)) and (not EOF(f2)) do
begin
if(a1<=a2)then
begin
write(f,a1,' ');
read(f1,a1);
end
else
begin
write(f,a2,' ');
read(f2,a2);
end;
end;
while not EOF(f1)do
begin
tmp:=a1;
read(f1,a1);
if not EOF(f1) then
write(f,tmp);
end;
while not EOF(f2) do
begin
tmp:=a2;
if not EOF(f2) then
write(f,tmp,' ')
else
write(f,tmp);
end;
close(f);
close(f1);
close(f2);
end;
Erase(f1);

она 4его-то не работает на ABC Паскале=( помогите доделать... и если кто может комменты напишите..хелп

@Puporev · 14.12.2009, 09:48

maxla91 Во первых это не программа, а лишь процедура сортировки слиянием. Кроме того там, где Вы ее списали, она с ошибочками.

Pascal
1
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
uses crt;
Procedure Sort(name: string; var f: text);
Var s1,s2,a1,a2,where,tmp: integer;
      f1,f2: text;
Begin
s1:=5; s2:=5; {Можно задать любые числа, которые запустят цикл while}
Assign(f,name);
Assign(f1,'{имя 1-го вспомогательного файла}');
Assign(f2,'{имя 2-го вспомогательного файла}');
While (s1>1) and (s2>=1) do
 begin
  where:=1;
  s1:=0; s2:=0;
  Reset(f);
  Rewrite(f1);
  Rewrite(f2);
  Read(f,a1);
  Write(f1,a1,' ');
  While not EOF(f) do
   begin
    read(f,a2);
    If (a2<a1) then
    begin
      Case where of
    1: begin
       where:=2;
       inc(s1);
       End;
    2: begin
       where:=1;
       inc(s2);
         End;
      End;
    End;
    Case where of
    1: write(f1,a2,' ');
    2: write(f2,a2,' ');
    End;
     a1:=a2;
    End;
   If where=2 then inc(s2) else inc(s1);
   Close(f);
   Close(f1);
   Close(f2);
   Rewrite(f);
   Reset(f1);
   Reset(f2);
   Read(f1,a1);
   Read(f2,a2);
   While (not EOF(f1)) and (not EOF(f2)) do
    begin
     If (a1<=a2) then
    begin
     Write(f,a1,' ');
     Read(f1,a1);
    End
     else
    begin
     Write(f,a2,' ');
     Read(f2,a2);
      End;
     End;
    While not EOF(f1) do
     begin
      tmp:=a1;
    Read(f1,a1);
    If not EOF(f1) then Write(f,tmp,' ')
    else Write(f,tmp);
     End;
    While not EOF(f2) do
     begin
    tmp:=a2;
    Read(f2,a2);
    If not EOF(f2) then Write(f,tmp,' ')
      else Write(f,tmp);
     End;
    Close(f);
    Close(f1);
    Close(f2);
   End;
 Erase(f1);
 Erase(f2);
End;
 
var g:text;
    s:string;
begin
clrscr;
write('Имя файла: ');
readln(s);
s:=s+'.txt';
Sort(s,g);
write('Файл отсортирован!');
readln
end.

@maxla91 · 18.12.2009, 14:21 **[ТС]**

пасиб....народ можете кто объяснить эту задачу...?=) распишите плз..

Добавлено через 10 часов 53 минуты
можете кто объяснить эту задачу...?=)

@Puporev · 18.12.2009, 14:25

maxla91, Алгоритм естественного слияния описан во множестве статей в интернете.
http://www.google.ru/search?hl... 0%B5%D1%81

@Snoopy · 18.12.2009, 14:38

была у меня лаба в универе, может пригодится, комментарии можно посмотреть только в компиляторе!

Pascal
1
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
program Sort;
Uses Crt;
Const NMax=100;
Type Rec=Record
    Name: String[15];
    Area: Integer;
   end;
   Table=array [1..NMax] of Rec;
 
 
Var T: Table;
    n: Integer;
   ch: Byte;
 
 procedure InTab (var T: Table; var n: integer);
  var  ch: char;
    fname: string;
        i: integer;
        f: file of rec;
      cod: Byte;
 
  begin
   ClrScr;
   n:=0;
   repeat
     n:=n+1;
     Writeln('Введите ',n,'-ю запись таблицы!');
     Writeln('Государство');
     Readln(t[n].name);
     Writeln('Площадь: ');
     Readln(t[n].area);
     Writeln('Продолжить ввод y\n?');
     ch:=ReadKey;
    until ch in ['n','N','t','T'];
    Writeln('Сохранить введенные данные в файл? y\n');
    ch:=ReadKey;
    if ch in ['n','N','t','T'] then
     exit;
    Writeln('Введите имя файл*!');
    Readln(fname);
    Assign(f, fname);
   {$I-}
    Rewrite(f);
   {$I+}
    cod:=IOResult;
    if cod=0 then
     begin
      for i:=1 to n do
       write(f, t[i]);
      close(f);
     end
    else
     begin
      Writeln('Ошибка при создании файла!');
      ReadKey;
     end;
end;
 
 
 procedure InFileTab (var T: Table; var n: integer);
 var cod: Byte;
       f: file of rec;
   fname: string;
      ch: char;
  begin
   ClrScr;
   repeat
    Writeln('Введите имя файл*!');
    Readln(fname);
     Assign(f, fname);
   {$I-}
    Reset(f);
   {$I+}
    cod:=IOResult;
    if cod<>0 then
     begin
      Writeln('Невозможно найти файл!', fname);
      Writeln('Продолжоть работу?y\n');
      ch:=ReadKey;
       if ch in ['n','N','t','T'] then
         exit;
     end;
    until cod=0;
    n:=0;
    while not eof(f) do
     begin
      n:=n+1;
      read(f, T[n]);
     end;
    close(f);
    Writeln('Таблица загружена из файл* ', fname);
    Write('Нажмите любую клавишу...');
    ReadKey;
   end;
 
 procedure ShowTab (var T: Table; n: integer);
 var i:integer;
 begin
   ClrScr;
   Writeln('Записи Таблицы:');
   Writeln('-----------------------');
   Writeln('Государство  |  Площадь');
   Writeln('-----------------------');
   for i:=1 to n do
     Writeln(T[i].Name:13,'|',T[i].Area:9);
   Writeln('-----------------------');
   Writeln('Нажмите любую клавишу...');
   ReadKey;
  end;
 
 procedure PrintTab(var T: Table; n,j:integer; gr:array of integer);
 var k,i,z:integer;
 begin
  z:=0;
  writeln ('Всего групп:',j);
  for i:=1 to j do
  begin
    if (i mod 2)=0 then
      textattr:=blue*16+white
    else
      textattr:=green*16+white;
    for k:=1 to gr[i-1] do
    begin
      z:=z+1;
      write (T[z].area);
      write (' ');
    end;
  end;
  textattr:=black*16+white;
  writeln;
  readln;
 end;
 
 procedure MixdownSort (var T:table; n:integer);
 var TBuf:table;
     grps:array[1..NMax]of integer;{DLINNI GRUP}
     i,j,z,k:integer;
     ng1,ng2,gr1,gr2,l,igr1,igr2:integer;
 begin
   j:=0;
   k:=1;
   for i:=2 to n+1 do       {razbienie na gruppi}
   begin
     if (T[i].area<T[i-1].area) or (i>n) then
     begin
       j:=j+1;
       grps[j]:=k;
       k:=1;
     end
     else
       k:=k+1;
   end;
 
   while j>1 do
   begin
   PrintTab (T,n,j,grps);
   ng1:=0;
   for i:=1 to (j div 2) do
   begin
     gr1:=grps[i*2-1]; {}
     gr2:=grps[i*2]; {}
     igr1:=gr1; {}
     igr2:=gr2; {}
     l:=gr1+gr2;{dlina zoni sliyanija}
     for z:=0 to l-1 do         {formirovanie zoni sliyaniya}
     begin
 
       if ((igr1>0) and (igr2>0) and (T[ng1+igr1].area>=T[ng1+gr1+igr2].area))
                     OR ((igr1>0) and (igr2<=0)) then
       begin
         TBuf[l-z]:=T[ng1+igr1];
         igr1:=igr1-1;
       end
       else
       begin
       if ((igr1>0) and (igr2>0) and (T[ng1+igr1].area<T[ng1+gr1+igr2].area))
                     OR ((igr2>0) and (igr1<=0)) then
       begin
         TBuf[l-z]:=T[ng1+gr1+igr2];
         igr2:=igr2-1;
       end;
       end;
     end;
     for z:=1 to l do
         T[ng1+z]:=TBuf[z];
     ng1:=ng1+gr1+gr2;
   end;
   for i:=1 to (j div 2) do
   begin
     grps[i]:=grps[i*2-1]+grps[i*2];
   end;
   if (j mod 2 <> 0) and (j<>1) then
     begin
     j:=(j div 2)+1;
     grps[j]:=grps[j*2-1];
     end
   else
     j:=j div 2;
   end;
   for i:=1 to n do
     begin
     write (T[i].area);
     write (' ');
     end;
   readln;
 end;
 
  begin
   n:=0;
   repeat
    ClrScr;
    Writeln('1. Ввод данных с клавиитуры');
    Writeln('2. Загрузка таблицы из файла');
    Writeln('3. Вывод таблицы');
    Writeln('4. Сортировка');
    Writeln('----------------------------');
    Writeln('0. Выход');
    writeln;
    Write('Ваш выбор: ');
    Readln(ch);
    ClrScr;
 
    Case ch of
      0: break;
      1: InTab(T,n);
      2: InFileTab(T,n);
      3: if n<>0 then
           ShowTab(T,n)
         else
          begin
           Writeln('Таблица не создана!');
           ReadKey;
         end;
      4: if n<>0 then
          MixdownSort(T,n);
        else
         begin
          Writeln('Таблица не создана!');
          ReadKey;
          ClrScr;
         end;
      end;
   until ch=0;
end.

@Puporev · 21.05.2010, 21:26

Сообщение от Snoopy

комментарии можно посмотреть только в компиляторе!

И не только, можно и перекодировать.
После перекодировки выясняется что никаких комментариев на русском и нет....

@strawberry · 20.11.2010, 19:29

а если сортировку надо выполнить естесвенным слиянием о.4 мегабайт это как можно реализовать? помогите, пожалуста, программы мне понятны, нужен только отрывок , если код программы остается тем же...Заранее спасиобо!

@verjil · 15.01.2013, 22:24

Сообщение от Puporev

maxla91 Во первых это не программа, а лишь процедура сортировки слиянием. Кроме того там, где Вы ее списали, она с ошибочками.

Pascal
1
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
uses crt;
Procedure Sort(name: string; var f: text);
Var s1,s2,a1,a2,where,tmp: integer;
      f1,f2: text;
Begin
s1:=5; s2:=5; {Можно задать любые числа, которые запустят цикл while}
Assign(f,name);
Assign(f1,'{имя 1-го вспомогательного файла}');
Assign(f2,'{имя 2-го вспомогательного файла}');
While (s1>1) and (s2>=1) do
 begin
  where:=1;
  s1:=0; s2:=0;
  Reset(f);
  Rewrite(f1);
  Rewrite(f2);
  Read(f,a1);
  Write(f1,a1,' ');
  While not EOF(f) do
   begin
    read(f,a2);
    If (a2<a1) then
    begin
      Case where of
    1: begin
       where:=2;
       inc(s1);
       End;
    2: begin
       where:=1;
       inc(s2);
         End;
      End;
    End;
    Case where of
    1: write(f1,a2,' ');
    2: write(f2,a2,' ');
    End;
     a1:=a2;
    End;
   If where=2 then inc(s2) else inc(s1);
   Close(f);
   Close(f1);
   Close(f2);
   Rewrite(f);
   Reset(f1);
   Reset(f2);
   Read(f1,a1);
   Read(f2,a2);
   While (not EOF(f1)) and (not EOF(f2)) do
    begin
     If (a1<=a2) then
    begin
     Write(f,a1,' ');
     Read(f1,a1);
    End
     else
    begin
     Write(f,a2,' ');
     Read(f2,a2);
      End;
     End;
    While not EOF(f1) do
     begin
      tmp:=a1;
    Read(f1,a1);
    If not EOF(f1) then Write(f,tmp,' ')
    else Write(f,tmp);
     End;
    While not EOF(f2) do
     begin
    tmp:=a2;
    Read(f2,a2);
    If not EOF(f2) then Write(f,tmp,' ')
      else Write(f,tmp);
     End;
    Close(f);
    Close(f1);
    Close(f2);
   End;
 Erase(f1);
 Erase(f2);
End;
 
var g:text;
    s:string;
begin
clrscr;
write('Имя файла: ');
readln(s);
s:=s+'.txt';
Sort(s,g);
write('Файл отсортирован!');
readln
end.

поясни пожалуйста как она работает что делать надо ввожу файл а он пишет что не найдет

Новые блоги и статьи Все статьи Все блоги /
http://iceja.net/ сервер решения полиномов iceja 18.01.2026 Выкатила http:/ / iceja. net/ сервер решения полиномов (находит действительные корни полиномов методом Штурма). На сайте документация по API, но скажу прямо VPS слабенький и 200 000 полиномов. . .	Первый деплой lagorue 16.01.2026 Не спеша развернул своё 1ое приложение в kubernetes. А дальше мне интересно создать 1фронтэнд приложения и 2 бэкэнд приложения развернуть 2 деплоя в кубере получится 2 сервиса и что-бы они. . .	Расчёт переходных процессов в цепи постоянного тока igorrr37 16.01.2026 / * Дана цепь постоянного тока с R, L, C, k(ключ), U, E, J. Программа составляет систему уравнений по 1 и 2 законам Кирхгофа, решает её и находит: токи, напряжения и их 1 и 2 производные при t = 0;. . .	Восстановить юзерскрипты Greasemonkey из бэкапа браузера damix 15.01.2026 Если восстановить из бэкапа профиль Firefox после переустановки винды, то список юзерскриптов в Greasemonkey будет пустым. Но восстановить их можно так. Для этого понадобится консольная утилита. . .
Изучаю kubernetes lagorue 13.01.2026 А пригодятся-ли мне знания kubernetes в России?	Сукцессия микоризы: основная теория в виде двух уравнений. anaschu 11.01.2026 https:/ / rutube. ru/ video/ 7a537f578d808e67a3c6fd818a44a5c4/	WordPad для Windows 11 Jel 10.01.2026 WordPad для Windows 11 — это приложение, которое восстанавливает классический текстовый редактор WordPad в операционной системе Windows 11. После того как Microsoft исключила WordPad из. . .	Classic Notepad for Windows 11 Jel 10.01.2026 Old Classic Notepad for Windows 11 Приложение для Windows 11, позволяющее пользователям вернуть классическую версию текстового редактора «Блокнот» из Windows 10. Программа предоставляет более. . .

@maxla91 0 / 0 / 0 Регистрация: 04.12.2009 Сообщений: 16
	18.12.2009, 14:21 [ТС]
	пасиб....народ можете кто объяснить эту задачу...?=) распишите плз.. Добавлено через 10 часов 53 минуты можете кто объяснить эту задачу...?=) 0

@Puporev Почетный модератор 64314 / 47610 / 32743 Регистрация: 18.05.2008 Сообщений: 115,168
	18.12.2009, 14:25
	maxla91, Алгоритм естественного слияния описан во множестве статей в интернете. http://www.google.ru/search?hl... 0%B5%D1%81 0

@strawberry 1 / 1 / 0 Регистрация: 21.01.2010 Сообщений: 8
	20.11.2010, 19:29
	а если сортировку надо выполнить естесвенным слиянием о.4 мегабайт это как можно реализовать? помогите, пожалуста, программы мне понятны, нужен только отрывок , если код программы остается тем же...Заранее спасиобо! 0

Сортировка естественным слиянием

Решение