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

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

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль

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

Ответ
 
Опции темы Поиск в этой теме
Старый 18.04.2010, 18:27   #11
Sparky
Участник клуба
 
Аватар для Sparky
 
Регистрация: 15.05.2009
Сообщений: 1,222
По умолчанию

привязала процедуры сортировки, пузырьковая работает, а вот быстрая не работает, посмотрите пожалуйста
Код:
program get_spisok;
uses
  SysUtils;

{===============================================================================
                    описание типов и данных
===============================================================================}
  type ob_spisok=^Tob_spisok;    //абстрактный тип
  Tob_spisok=object
    constructor init;
    procedure output;virtual;
    function str:string;virtual;
  end;

  int = ^Tint;  //целые
  Tint = object(Tob_spisok)
    inf:integer;
    procedure insert(cel:integer);
    function str:string;virtual;
    procedure output;virtual;
  end;

  float = ^Tfloat;  //вещественное
  Tfloat = object(Tob_spisok)
    inf:real;
    procedure insert(vesh:real);
    function str:string;virtual;
    procedure output;virtual;
  end;

  simbol = ^Tsimbol;  //символ
  Tsimbol = object(Tob_spisok)
    inf:char;
    procedure insert(sim:char);
    function str:string;virtual;
    procedure output;virtual;
  end;

{===============================================================================
          конструкторы и процедуры
===============================================================================}
Constructor Tob_spisok.init;
begin

end;

procedure Tob_spisok.output;
begin

end;

function Tob_spisok.str;
begin

end;




//целые
procedure Tint.insert(cel:integer);
begin
  inf:=cel;
end;

procedure Tint.output;
begin
  write(inf,' ');
end;

function Tint.str;
begin
  str:=IntToStr(inf);
end;

//вещественные
procedure Tfloat.insert(vesh: Real);
begin
  inf:=vesh;
end;

procedure Tfloat.output;
begin
  write(inf:2:2,' ');
end;

function Tfloat.str;
begin
  str:=FloatToStr(inf);
end;

//символы
procedure TSimbol.insert(sim: Char);
begin
  inf:=sim;
end;

function TSimbol.str;
begin
  str:=inf;
end;

procedure Tsimbol.output;
begin
  write(inf,' ');
end;

{===============================================================================
        описание данных
===============================================================================}
type spisok = ^Tspisok;
  Tspisok = record
    inf:ob_spisok;
    next:spisok;
    prior:spisok;
  end;
var
  head:spisok;  //голова списка
  x:real; //значение инф поля
  str:string;
  i:integer;
  temp_el:spisok;
  flag_yes:Boolean;

{===============================================================================
          процедуры и функции
===============================================================================}
function countElement(start:spisok):integer;
var
  temp:integer;
begin
  temp:=0;
  while(start<>nil) do
  begin
    inc(temp);
    start:=start^.next;
  end;
  countElement:=temp;
end;

procedure remote(var start:spisok); //удаление всего списка
var
  temp:spisok;
begin
  while(start<>nil) do
  begin
    temp:=start;
    start:=start^.next;
    Dispose(temp);
  end;
end;

function GetById(i:integer):spisok;
var
  p:spisok;
  j:integer;
begin
  p:=head;
  j:=1;
  while ((p<>nil) and (j<>i)) do
  begin
    p:=p^.next;
    inc(j);
  end;
  if p=nil then GetById:=nil
  else if j=i then GetById:=p;
end;
Единственное, что ограничивает полет мысли программиста-компилятор
Sparky вне форума Ответить с цитированием
Старый 18.04.2010, 18:27   #12
Sparky
Участник клуба
 
Аватар для Sparky
 
Регистрация: 15.05.2009
Сообщений: 1,222
По умолчанию

Код:
function GetNextByValue(P:spisok):spisok;   //получение значения следующего за текущим
begin
  if (p^.next<>nil) then GetNextByValue:=p^.next
  else GetNextByValue:=nil;
end;

function cond(s1:string;s2:string):boolean; //функция сравнения
begin
  if (s1>s2) then cond:=true
  else cond:=false;
end;

procedure print(head:spisok); //печать списка
var
  temp:spisok;
begin
  temp:=head;
  while(temp<>nil) do
  begin
    temp^.inf^.output;
    temp:=temp^.next;
  end;
end;


procedure insert(var head:spisok); //процедура вставки
var
  int1:int;  //целое
  float1:float;  //вещественное
  simbol1:simbol; //символ
  new_element,temp:spisok;
  s:Variant;
  c:char;
  x:real;
  temp_str:string;
begin
  while (str<>'') do
  begin
   // read(x);
    if (head=nil) then  //если голова пустая вставлять туда
    begin
      new(head);
      if ((str[1]>='a') and (str[1]<='z')) then
      begin
        new(simbol1,init);
        simbol1^.insert(str[1]);
        head^.inf:=simbol1;
        head^.next:=nil;
        head^.prior:=nil;
        delete(str,1,2);
      end
      else
      begin
        i:=1;
        while((i<=Length(str)) and(str[i]<>' ')) do
          inc(i);
        temp_str:=copy(str,1,i-1);
        delete(str,1,i);
        x:=StrToFloat(temp_str);
        if frac(x)<>0 then //если вещественное
        begin
          new(float1,init);
          float1^.insert(x);
          head^.inf:=float1;
          head^.next:=nil;
          head^.prior:=nil;
        end
        else   //иначе целое
        begin
          new(int1,init);
          int1^.insert(trunc(x));
          head^.inf:=int1;
          head^.next:=nil;
          head^.prior:=nil;
        end;
      end;
    end
    else   //список не пустой
    begin
      new(temp);
      temp:=head;
      while(temp^.next<>nil) do
        temp:=temp^.next;
      new(new_element);

      if ((str[1]>='a') and (str[1]<='z')) then
      begin
        new(simbol1,init);
        simbol1^.insert(str[1]);
        new_element^.inf:=simbol1;
        new_element^.next:=nil;
        new_element^.prior:=temp;
        delete(str,1,2);
      end

      else
      begin
        i:=1;
        while((i<=Length(str)) and(str[i]<>' ')) do
          inc(i);
        temp_str:=copy(str,1,i-1);
        delete(str,1,i);
        x:=StrToFloat(temp_str);
        if frac(x)<>0 then  //если вещественное
        begin
          new(float1,init);
          float1^.insert(x);
          new_element^.inf:=float1;
          new_element^.next:=nil;
          new_element^.prior:=temp;
        end
        else //иначе целое
        begin
          new(int1,init);
          int1^.insert(trunc(x));
          new_element^.inf:=int1;
          new_element^.next:=nil;
          new_element^.prior:=temp;
        end;
      end;
      temp^.next:=new_element;
    end;
  end;
end;

procedure Swap(i,j:integer);  //процедура обмена элементов
var
  p,q,t:spisok;
begin
  if (head<>nil) then
  begin
    p:=GetById(i);
    q:=GetById(j);
    if ((p<>nil) and (q<>nil)) then
    begin
      new(t);
      t^.inf:=p^.inf;
      p^.inf:=q^.inf;
      q^.inf:=t^.inf;
    end
  end
  else;
 end;

function exist(p:spisok):boolean;  //проверка входит ли элементов
var
  start:spisok;
  flag:boolean;
begin
  flag:=false;
  start:=head;
  while ((start<>nil) and (flag=false)) do
  begin
    if start=p then flag:=true
    else start:=start^.next;
  end;
end;
Единственное, что ограничивает полет мысли программиста-компилятор
Sparky вне форума Ответить с цитированием
Старый 18.04.2010, 18:28   #13
Sparky
Участник клуба
 
Аватар для Sparky
 
Регистрация: 15.05.2009
Сообщений: 1,222
По умолчанию

Код:
procedure BubbleSort;   //пузырьковая сортировка
var
  p,q:spisok;
  i,j,n:integer;
  str1,str2:string;
  flag:boolean;
begin
  n:=countElement(head);
  for i:=2 to n do
  begin
    for j:=n downto i do
    begin
      p:=GetById(j-1);
      q:=GetById(j);
      str1:=p^.inf^.str;
      str2:=q^.inf^.str;
      flag:=cond(str1,str2);
      if(not flag) then
        Swap(j,j-1);
    end;
  end;
end;


procedure QuickSort(l:integer;r:integer);   //быстрая сортировка
var
  i,j:integer;
  X:spisok;
  str1,str2:string;
  flag:boolean;
begin
   i:=l;
   j:=r;
   x:=GetByid((l+r) div 2);
   repeat
   begin
      str1:=x^.inf^.str;
      str2:=GetById(i)^.inf^.str;
      flag:=cond(str1,str2);
      while (flag) do
      begin
        inc(i);
        str1:=x^.inf^.str;
        str2:=GetById(i)^.inf^.str;
        flag:=cond(str1,str2);
      end;

      str1:=x^.inf^.str;
      str2:=GetById(j)^.inf^.str;
      flag:=cond(str1,str2);
      while (not flag) do
      begin
        dec(j);
        str1:=x^.inf^.str;
        str2:=GetById(j)^.inf^.str;
        flag:=cond(str1,str2);
      end;

      if (i<=j) then
      begin
        Swap(i,j);
        inc(i);
        dec(j);
      end;
   end;
   until (i>j);
   if j>l then QuickSort(l,j);
   if r>i then QuickSort(i,r);
end;

{===============================================================================
            главная программа
===============================================================================}
begin
//считать начальные данные из списка
  assign(input,'input.txt');
  reset(input);
  assign(output,'output.txt');
  rewrite(output);
  read(str);
  insert(head);
//  print(head);
{===============================================================================
              проверки
===============================================================================}
 // BubbleSort;
  QuickSort(1,countElement(head));
  print(head);
end.
Единственное, что ограничивает полет мысли программиста-компилятор
Sparky вне форума Ответить с цитированием
Старый 18.04.2010, 18:31   #14
Sparky
Участник клуба
 
Аватар для Sparky
 
Регистрация: 15.05.2009
Сообщений: 1,222
По умолчанию

p.s. получилось очень изварещенно, сорри, но переделывать как советовал Stilet не стала, времени катастрофически мало еще и заболела
Единственное, что ограничивает полет мысли программиста-компилятор

Последний раз редактировалось Sparky; 18.04.2010 в 18:33.
Sparky вне форума Ответить с цитированием
Ответ


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



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
списки sergeykl Паскаль, Turbo Pascal, PascalABC.NET 8 04.08.2009 23:05
Списки Chief Паскаль, Turbo Pascal, PascalABC.NET 4 03.06.2009 18:29
Однонаправленный неоднородный (гетерогенный) список с однородными подсписками. Chudo4258 Помощь студентам 22 08.03.2009 19:11