Программа неожиданно корректно завершается в процедуре, без halt - Free Pascal
Формулировка задачи:
Функция WithList (строка 330) нормально выполняется, однако после ее завершения программа так же завершается. Остальные два пункта нормально работают.
Не могу пошагово выполнять ибо FP заглючивает и приходится перезагружаться.
С помощью вывода текста выяснила что после третьего пункта в цикле в основной части программы возвращения в этот цикл так и не происходит, после остальных двух пунктов все нормально.
Как это возможно и как исправить?
input.txt приложила
uses crt;
type
intfile = file of integer;
pList = ^List;
List = record
data: integer;
next: pList;
end;
//------------------------------------------------------------------
procedure Sort(var a: array of integer); overload;
var
n, i, j, tmp: integer;
begin
n := length(a);
for i := n - n mod 2 - 4 downto 0 do
if i mod 2 = 0 then
for j := 0 to i do
if j mod 2 = 0 then
if a[j]+a[j+1] > a[j+2]+a[j+3] then
begin
tmp := a[j];
a[j] := a[j+2];
a[j+2] := tmp;
tmp := a[j+1];
a[j+1] := a[j+3];
a[j+3] := tmp;
end;
end;
//------------------------------------------------------------------
function Delete(var a: array of integer; val: integer): boolean; overload;
var
n, i, j: integer;
begin
n := length(a);
for i := 0 to n-2 do
if i mod 2 = 0 then
if a[i]+a[i+1] = val then
begin
for j := i to n-3 do
a[j] := a[j+2];
Delete := true;
exit;
end;
Delete := false;
end;
//------------------------------------------------------------------
procedure Print(a: array of integer); overload;
var
i: integer;
begin
for i := 0 to length(a)-1 do
write(a[i], ' ');
writeln;
end;
//------------------------------------------------------------------
procedure WithArray(var f: text);
var
a: array of integer;
n, i, m: integer;
begin
reset(f);
read(f, n);
setlength(a, n);
for i := 0 to n-1 do
read(f, a[i]);
close(f);
write('Ishodnyi massiv: ');
Print(a);
Sort(a);
write('Posle sortirovki: ');
Print(a);
write('Vvedite summu dlea udalenia: ');
readln(m);
if Delete(a, m) then
begin
setlength(a, n-2);
write('Posle udalenia: ');
Print(a);
end
else
writeln('Para s ukazannoi summoi ne naidena!');
readkey;
end;
//------------------------------------------------------------------
procedure TextToTypeFile(var f1: text; var f2: intfile);
var
n, i, cur: integer;
begin
rewrite(f2);
read(f1, n);
for i := 1 to n do
begin
read(f1, cur);
write(f2, cur);
end;
close(f2);
end;
//------------------------------------------------------------------
procedure Sort(var f: intfile); overload;
var
cur: array [0..3] of integer;
changed: boolean;
begin
changed := true;
while changed do
begin
changed := false;
reset(f);
read(f, cur[2], cur[3]);
while not eof(f) do
begin
cur[0] := cur[2];
cur[1] := cur[3];
read(f, cur[2]);
if not eof(f) then
read(f, cur[3])
else
break;
if cur[0]+cur[1] > cur[2]+cur[3] then
begin
seek(f, filepos(f)-4);
write(f, cur[2], cur[3], cur[0], cur[1]);
changed := true;
end;
end;
end;
close(f);
end;
//------------------------------------------------------------------
function Delete(var f: intfile; m: integer): boolean; overload;
var
cur1, cur2: integer;
found: boolean;
begin
reset(f);
found := false;
while not eof(f) and not found do
begin
read(f, cur1);
if not eof(f) then
read(f, cur2)
else
break;
if cur1+cur2 = m then
begin
while not eof(f) do
begin
read(f, cur1);
if not eof(f) then
read(f, cur2)
else
begin
seek(f, filepos(f)-3);
write(f, cur1);
break;
end;
seek(f, filepos(f)-4);
write(f, cur1, cur2);
seek(f, filepos(f)+2);
if eof(f) then
begin
seek(f, filepos(f)-2);
break;
end;
end;
truncate(f);
found := true;
end;
end;
close(f);
Delete := found;
end;
//------------------------------------------------------------------
procedure Print(var f: intfile); overload;
var
cur: integer;
begin
reset(f);
while not eof(f) do
begin
read(f, cur);
write(cur, ' ');
end;
writeln;
close(f);
end;
//------------------------------------------------------------------
procedure WithTypeFile(var f: text);
var
typef: intfile;
m: integer;
begin
assign(typef, 'file_of_integer');
reset(f);
TextToTypeFile(f, typef);
write('Soderjimoe tipizirovannogo faila: ');
Print(typef);
write('Posle sortirovki: ');
Sort(typef);
Print(typef);
write('Vvedite summu dlea udalenia: ');
readln(m);
if Delete(typef, m) then
begin
write('Posle udalenia: ');
Print(typef);
end
else
writeln('Para s ukazannoi summoi ne naidena!');
readkey;
end;
//------------------------------------------------------------------
procedure FileToList(var f: text; var first: pList);
var
n, i: integer;
newelem, last: pList;
begin
first := nil;
last := nil;
reset(f);
read(f, n);
for i := 1 to n do
begin
new(newelem);
read(f, newelem^.data);
newelem^.next := nil;
if last <> nil then
last^.next := newelem
else
first := newelem;
last := newelem;
end;
close(f);
end;
//------------------------------------------------------------------
procedure Sort(first: pList); overload;
var
cur: array [0..3] of pList;
tmp: integer;
changed: boolean;
begin
changed := true;
while changed do
begin
changed := false;
cur[2] := first;
if first <> nil then
cur[3] := first^.next
else
cur[3] := nil;
while (cur[3] <> nil) and (cur[3]^.next <> nil) do
begin
cur[0] := cur[2];
cur[1] := cur[3];
cur[2] := cur[1]^.next;
cur[3] := cur[2]^.next;
if cur[3] = nil then
break;
if cur[0]^.data+cur[1]^.data > cur[2]^.data+cur[3]^.data then
begin
tmp := cur[0]^.data;
cur[0]^.data := cur[2]^.data;
cur[2]^.data := tmp;
tmp := cur[1]^.data;
cur[1]^.data := cur[3]^.data;
cur[3]^.data := tmp;
changed := true;
end;
end;
end;
end;
//------------------------------------------------------------------
function Delete(var first: pList; m: integer): boolean; overload;
var
prev, cur1, cur2: pList;
found: boolean;
begin
found := false;
prev := nil;
cur1 := first;
if cur1 <> nil then
cur2 := cur1^.next;
while not found and (cur1 <> nil) and (cur2 <> nil) do
if cur1^.data+cur2^.data = m then
begin
if prev <> nil then
prev^.next := cur2^.next
else
first := cur2^.next;
dispose(cur1);
dispose(cur2);
found := true;
end
else
begin
prev := cur2;
cur1 := cur2^.next;
if cur1 <> nil then
cur2 := cur1^.next;
end;
Delete := found;
end;
//------------------------------------------------------------------
procedure Clear(var first: pList);
var
tmp: pList;
begin
while first <> nil do
begin
tmp := first;
first := first^.next;
dispose(tmp);
end;
end;
//------------------------------------------------------------------
procedure Print(first: pList); overload;
var
cur: pList;
begin
cur := first;
while cur <> nil do
begin
write(cur^.data, ' ');
cur := cur^.next;
end;
writeln;
end;
//------------------------------------------------------------------
procedure WithList(var f: text);
var
first: pList;
m: integer;
begin
reset(f);
FileToList(f, first);
write('Ishodnyi spisok: ');
Print(first);
Sort(first);
write('Posle sortirovki: ');
Print(first);
write('Vvedite summu dlea udalenia: ');
readln(m);
if Delete(first, m) then
begin
write('Posle udalenia: ');
Print(first);
end
else
writeln('Para s ukazannoi summoi ne naidena!');
Clear(first);
writeln('Spisok ochischen');
close(f);
readkey;
end;
//------------------------------------------------------------------
function Menu: integer;
var
choice: integer;
begin
clrscr;
writeln('1 - Rabota s massivom');
writeln('2 - Rabota s tipizirovannym failom');
writeln('3 - Rabota so spiskom');
writeln('0 - Vyhod iz programmy');
write('Vash vybor: ');
readln(choice);
writeln;
Menu := choice;
end;
//------------------------------------------------------------------
var
f: text;
begin
assign(f, 'input.txt');
while true do
case Menu of
0: break;
1: WithArray(f);
2: WithTypeFile(f);
3: WithList(f);
end;
end.Решение задачи: «Программа неожиданно корректно завершается в процедуре, без halt»
textual
Листинг программы
procedure WithList(var f: text);
var
first: pList;
m: integer;
begin
reset(f);
FileToList(f, first); // в этой процедуре файл f открывается/закрывается
write('Ishodnyi spisok: ');
Print(first);
Sort(first);
write('Posle sortirovki: ');
Print(first);
write('Vvedite summu dlea udalenia: ');
readln(m);
if Delete(first, m) then
begin
write('Posle udalenia: ');
Print(first);
end
else
writeln('Para s ukazannoi summoi ne naidena!');
Clear(first);
writeln('Spisok ochischen');
close(f); // Но файл УЖЕ закрыт, не нужно перезакрывать его, чревато ошибками, ты видела какими :)
readkey;
end;
Объяснение кода листинга программы
- Объявлены следующие переменные:
- first: pList;
- m: integer;
- Вызов функции reset(f), которая открывает файл f для чтения.
- Вызов функции FileToList(f, first), которая заполняет список first содержимым файла f.
- Вывод сообщения
Ishodnyi spisok:и вызов функции Print(first), которая выводит список first на экран. - Вызов функции Sort(first), которая сортирует список first по возрастанию.
- Вывод сообщения
Posle sortirovki:и вызов функции Print(first), которая выводит отсортированный список на экран. - Вывод сообщения
Vvedite summu dlia udalenia:и вызов функции readln(m), которая считывает с клавиатуры целое число и сохраняет его в переменной m. - Проверка условия Delete(first, m) (удаление элемента из списка по индексу).
- Если условие истинно, то выполняются действия:
- Вывод сообщения
Posle udalenia:и вызов функции Print(first), которая выводит список first на экран. - Закрытие списка first с помощью функции Clear(first).
- Вывод сообщения
Spisok ochischenи закрытие файла f с помощью функции close(f). - Ожидание нажатия клавиши с помощью функции readkey.
- Если условие ложно, то выводится сообщение
Para s ukazannoi summoi ne naidena!.
- Файл УЖЕ закрыт, не нужно перезакрывать его, чревато ошибками.