Паскаль. Быстрая сортировка массива записи.

[Лакира]

В файле содержатся сведения о веществах: название вещества, удельный вес и проводимость (проводник, полупроводник, диэлектрик).
В новый файл переписать данные, упорядочив их по убыванию удельных весов.

Проблема: сортируется только если 3 записи.

procedure Alg11(var f2:TFsubstance; a,b:byte);
var i,j,x:integer;t:real;
begin
reset(f2);
while not eof(f2) do begin

i:=a; j:=b;
x:= (filesize(f2)+1)div 2;
repeat 


while (mas[i].uweight>mas[x].uweight) do
inc(i);
while (mas[j].uweight<mas[x].uweight)do
dec(j);
if(a<=b)then begin
t:=mas[i].uweight;
mas[i].uweight:=mas[j].uweight;
mas[j].uweight:=t;
inc(a);
dec(b);end;
until i<j;
if a < j then 
        Alg11(f2, a, j); 
    if i < b then
        Alg11(f2, i, b); 
close(f2);
end;end;

[Serge_Bliznykov]

простите, а зачем Вы засунули цикл по файлу внутрь рекурсивной процедуры сортировки?!
Или Вы не понимаете, что каждый раз, когда идёт вызов
Alg11(f2, a, j);
Alg11(f2, i, b);
в цикле у Вас будет Reset(f2) - это переход к началу файл и новый цикл while not eof(f2)

скажите честно, это Вы сами придумали?
и, главное, зачем это?
Ведь чтения из файла нет, сортируется массив mas (и, кстати, тоже неверно - обменивается только одно поле uweight! если там есть другие поля, то будет каша! ) )

короче, не зачёт!
переделывать нужно.

[Лакира]

Вот я поправила, но все равно не работает

procedure Alg11(var f2:TFsubstance);
var i,j,x,a1,b1:integer;t:real;a,b,x1:Tsubstance;
begin
reset(f2);i:=a1; j:=b1;
x:= (filesize(f2)+1)div 2;
for i:=0 to x do
for j:=filesize(f2) to x do begin
seek(f2,i);
read(f2,a);
seek(f2,j);
read(f2,b);
read(f2,x1);
repeat
while (a.uweight<x1.uweight) do
inc(a1);
while (b.uweight>x1.uweight)do
dec(b1);
if(a1<=b1)then begin
t:=a.uweight;
a.uweight:=b.uweight;
b.uweight:=t;
inc(a1);
dec(b1);end;
until a1<b1;

close(f2);
end;end;

[Serge_Bliznykov]

Сообщение от Лакира

Вот я поправила, но все равно не работает

что Вы поправили? Убрали алгоритм QuickSort (aka "быстрая сортировка")?
А зачем? И как оно после этого должно работать?
И зачем вы дёргаете файл? куда делся массив mas ?



давайте начнём с начала.
Что Вам дано и что нужно сделать?
Вот прямо дословно и конкретно - какую задачу Вы пытаетесь решить?

p.s. ну и попутно, если Вас интересует конкретный ответ, то:
1) укажите, каким Паскалем Вы пользуетесь
2) приведите код полностью, с описанием типов данных.

[Лакира]

В файле содержатся сведения о веществах: название вещества, удельный вес и проводимость (проводник, полупроводник, диэлектрик). В новый файл переписать данные, упорядочив их по убыванию удельных весов.

1) Паскаль АВС
2)

uses crt;

const n=15;
type Tsubstance = record
name:string[15];
uweight:real;
spend:integer;
end;
TFsubstance = file of Tsubstance;

var sub:Tsubstance;
mas:array[1..15]of Tsubstance;
a:Tsubstance;    


procedure InputRec(var sub:Tsubstance); //Ввод данных в запись
var i:byte;
begin
with sub do begin

writeln('Введите удельный вес ');
readln(uweight);
writeln('Выберете проводимость вещества ');
writeln('1- проводник');
writeln('2- полупроводник');
writeln('3- диэлектрик');
readln(spend);
writeln('Введите название вещества ');
readln(name);

end;
end;

procedure Alg1(var f1,f2:TFsubstance);
var i,j:integer; t:Tsubstance;
begin
reset(f1);
rewrite(f2);
while not eof(f1) do begin
read(f1,sub);
write(f2,sub);
end;close(f1);close(f2);
end;

procedure Alg11(var f2:TFsubstance);
var i,j,x,a1,b1:integer;t:real;a,b,x1:Tsubstance;
begin
reset(f2);i:=a1; j:=b1;
x:= (filesize(f2)+1)div 2;
for i:=0 to x do
for j:=filesize(f2) to x do begin
seek(f2,i);
read(f2,a);
seek(f2,j);
read(f2,b);
read(f2,x1);
repeat
while (a.uweight<x1.uweight) do
inc(a1);
while (b.uweight>x1.uweight)do
dec(b1);
if(a1<=b1)then begin
t:=a.uweight;
a.uweight:=b.uweight;
b.uweight:=t;
inc(a1);
dec(b1);end;
until a1<b1;

close(f2);
end;end;


var f1,f2:TFsubstance;,fn1,fn2:string;
begin //алгоритм 1
write('Введите имя исходного файла');
readln(fn1);
if FileExists (fn1)then begin
writeln('Введите имя результирующего файла');
readln(fn2);
assign(f1,fn1);
assign(f2,fn2);
Alg1(f1,f2);
Alg11(f2);

end
else
writeln('Файл с таким именем не существует');

[Serge_Bliznykov]

так, потихоньку проясняется...

надеюсь, что Вы эту программу сами писали.

Тогда вот ещё на три моих вопроса ответьте, пожалуйста.
1) откуда в теме появилась "быстрая сортировка"? Это просто так или это требование задания?
2) для чего описан массив записей mas:array[1..15]of Tsubstance; ?!
3) для чего процедура InputRec(var sub:Tsubstance); ?! Она же нигде не вызывается!

[Лакира]

3) InputRec(var sub:Tsubstance) вызывается перед алгоритмом 1(тут у меня ошибка)
2) изначально пробовала сделать сортировку через массив записей, после редактирования не удалила
1)Желательно выполнить быстрой сортировкой

Или покажите, пожалуйста, сортировку пузырьком для записи

Вот вариант сортировки пузырьком, который тоже не рабочий

procedure Alg111(var f1:TFsubstance);
var i,j:integer;n:real;
begin
reset(f1);
for i:=0 to 10 do
       for j:=1 to 9 do
       begin
        if mas[i].uweight<mas[j].uweight then
        begin
        n:=mas[i].uweight;
        mas[i].uweight:=mas[j].uweight;
        mas[j].uweight:=n;
        end;
          end;close(f1);end;

[Serge_Bliznykov]

ладно. давайте поступим так.

вот Вам рабочий код:

const
  MaxRecordInfile = 500;

type
  Tsubstance = record
    name: string[15];
    uweight: real;
    spend: integer;
  end;
  TFsubstance = file of Tsubstance;
  TSubstanceArray = array[1..MaxRecordInfile]of Tsubstance;

procedure CreateDemoFile(fname:string);
var f : TFsubstance;
  r : Tsubstance;
begin
  Assign(f, fname);
  Rewrite(f);
  with r do begin
     name:='Бетта'; uweight:=34.223; spend:=2;
     Write(f, r);
     name:='Gamma'; uweight:=14.122; spend:=3;
     Write(f, r);
     name:='Zet'; uweight:=2.789; spend:=1;
     Write(f, r);
     name:='Alpha'; uweight:=1.089; spend:=1;
     Write(f, r);
     name:='Yota'; uweight:=22.089; spend:=2;
     Write(f, r);
  end;
  Close(f);
  WriteLn('Демо файл с именем '+fname+' успешно создан.')
end;

procedure ReadFileToArray(fname:string; var A : TSubstanceArray; var CountOfRec : integer);
var f : TFsubstance;
  r : Tsubstance;
begin
  CountOfRec := 0;
  if FileExists(fname) then begin
    Assign(f, fname);
    Reset(f);
    while not eof(f) do begin
      Inc(CountOfRec);
      Read(f, A[CountOfRec]);
    end;
    Close(f);
  end;
  WriteLn('из файла '+fname+' считано в память ',CountOfRec,' запись(ей).')
end;

procedure PrintFile(fname:string);
var f : TFsubstance;
  r : Tsubstance;
begin
  if Not FileExists(fname) then WriteLn('Файл '+fname+' не найден.')
  else begin
    WriteLn('содержимое файла '+fname);
    Assign(f, fname);
    Reset(f);
    while not eof(f) do begin
      Read(f, r);
      WriteLn('name=',r.name,' weight=',r.uweight:0:4,' spend=',r.spend);
    end;
    WriteLn('-----------------------');
    Close(f);
  end;
end;


procedure swap(var a,b: Tsubstance);
var v: Tsubstance;
begin
  v:=a;   a:=b;   b:=v
end;

procedure QuickSort(var A: TSubstanceArray; n: integer);
  procedure sort(l,r: integer);
  var
    i,j: integer;
    x: Tsubstance;
  begin
    i:=l; j:=r;
    x:=A[(l+r) div 2];
    repeat
      while A[i].uweight<x.uweight do Inc(i); // ищем первый элемент >= x
      while A[j].uweight>x.uweight do Dec(j); // ищем последний элемент <= x
      if i<=j then
      begin
        swap(A[i],A[j]);
        Inc(i);
        Dec(j);
      end;
    until i>j;
    if l<j then sort(l,j);
    if i<r then sort(i,r)
  end;

begin
  sort(1,n)
end;


procedure WriteArrayToFile(fname:string; A: TSubstanceArray; n: integer);
var i : integer;
  f : TFsubstance;
  r : Tsubstance;
begin
  Assign(f, fname);
  Rewrite(f);
  for i:=1 to n do Write(f, A[i]);
  Close(f);
  WriteLn('Файл ',fname,' успешно записан.');
end;



var
  fn1, fn2: string;
  sArray : TSubstanceArray;
  n : integer;
  
begin
  write('Введите имя исходного файла: ');
  readln(fn1);
  if Not FileExists(fn1) then CreateDemoFile(fn1);
  
  ReadFileToArray(fn1, sArray, n);
  
  WriteLn('Сортируем записи алгоритмом "Быстрая сортировка"');
  QuickSort(sArray, n);

  
  writeln('Введите имя результирующего файла: ');
  readln(fn2);

  WriteArrayToFile(fn2, sArray, n);
  
  PrintFile(fn2);

end.

погоняйте его хорошо, разберите.
будут вопросы - обращайтесь!

[Лакира]

Не очень понимаю как работают эти строки. Поясните,пожалуйста.

 if l<j then sort(l,j);
    if i<r then sort(i,r)

[Serge_Bliznykov]

Сообщение от Лакира

Не очень понимаю как работают эти строки. Поясните,пожалуйста.

 if l<j then sort(l,j);
    if i<r then sort(i,r)

это рекурсивный вызов процедуры с подмножеством - частью массива либо слева от значения, либо справа.

кратенько:

Сообщение от википедия

Операция разделения массива: реорганизуем массив таким образом, чтобы все элементы со значением меньшим или равным опорному элементу, оказались слева от него, а все элементы, превышающие по значению опорный — справа от него. Обычный алгоритм операции:
Два индекса — l и r, приравниваются к минимальному и максимальному индексу разделяемого массива, соответственно.
Вычисляется значение опорного элемента m по одной из стратегий.
Индекс l последовательно увеличивается до тех пор, пока l-й элемент не окажется больше или равен опорному.
Индекс r последовательно уменьшается до тех пор, пока r-й элемент не окажется меньше или равен опорному.
Если r = l — найдена середина массива — операция разделения закончена, оба индекса указывают на опорный элемент.
Если l < r — найденную пару элементов нужно обменять местами и продолжить операцию разделения с тех значений l и r, которые были достигнуты. Следует учесть, что если какая-либо граница (l или r) дошла до опорного элемента, то при обмене значение m изменяется на r-й или l-й элемент соответственно, так же изменяется индекс опорного элемента и алгоритм продолжает своё выполнение.
Рекурсивно упорядочиваем подмассивы, лежащие слева и справа от опорного элемента.

подробнее:
Быстрая сортировка (algolist)


Быстрая сортировка (википедия)