Динамические структуры данных (списки, очереди, стеки, деревья)

Program Stek;
uses
  crt; {Для использования readkey и clrscr}
type
  Tinf=integer; {тип данных, который будет храниться в элементе стека}
  List=^TList;  {Указатель на элемент типа TList}
  TList=record {А это наименование нашего типа "запись" обычно динамические структуры описываются через запись}
    data:TInf;  {данные, хранимые в элементе}
    next:List;   {указатель на следующий элемент}
  end;
 
{Процедура добавляющая элемент в стек}
procedure AddElem(var stek1:List;znach1:TInf);
var
  tmp:List;
begin
  GetMem(tmp,sizeof(TList)); {выделяем в памяти место для нового элемента}
  tmp^.next:=stek1;  {указатель на следующий элемент "направляем" на вершину стека}
  tmp^.data:=znach1; {добавляем к элементу данные}
  stek1:=tmp; {вершина стека изменилась, надо перенести и указатели на неё}
end;
 
{Процедура вывода стека}
procedure Print(stek1:List);
begin
  if stek1=nil then {проверка на пустоту стека}
  begin
    writeln('Стек пуст.');
    exit;
  end;
  while stek1<>nil do {пока указатель stek1 не станет указывать в пустоту}
  begin   {а это произойдёт как только он перейдёт по ссылке последнего элемента}
    Write(stek1^.data, ' '); {выводить данне}
    stek1:=stek1^.next  {и переносить указатель вглубь по стеку}
  end;
end;
 
{Процедура освобождения памяти занятой стеком}
Procedure FreeStek(stek1:List);
var
  tmp:List;
begin
  while stek1<>nil do {пока stek1 не станет указывать в "пустоту" делать}
  begin
    tmp:=stek1; {указатель tmp направим на вершину стека}
    stek1:=stek1^.next; {вершину стека перенесём на следующий за данной вершиной элемент}
    FreeMem(tmp,SizeOf(Tlist)); {освободим память занятую под старую вершину}
  end;
end;
 
{Поиск элемента в стеке по значению}
Function SearchElemZnach(stek1:List;znach1:TInf):List;
begin
  if stek1<>nil then {если стек не пуст, то}
    while (Stek1<>nil) and (znach1<>stek1^.data) do {пока stek1 не укажет в "пустоту" или пока мы не нашли нужный нам элемент}
      stek1:=stek1^.next; {переносить указатель}
  SearchElemZnach:=stek1;{функция возвращает указатель на найденный элемент}
end;         {в случае если элемент не найден, она вернёт nil}
 
{Процедура удаления элемента по указателю}
Procedure DelElem(var stek1:List;tmp:List);
var
  tmpi:List;
begin
  if (stek1=nil) or (tmp=nil) then {если стек пуст или указатель никуда не указывает, то выходим}
    exit;
  if tmp=stek1 then {если мы удаляем элемент который является вершиной стека, то}
  begin
    stek1:=tmp^.next;{следует перенести вершину и}
    FreeMem(tmp,SizeOf(TList)); {высвободить память из под элемента}
  end
  else {в случае, если удаляемый элемент не вершина стека, то}
  begin
    tmpi:=stek1; {ставим указатель на вершину стека}
    while tmpi^.next<>tmp do {доходим до элемента стоящего "перед" тем, который нам следует удалить}
      tmpi:=tmpi^.next;
    tmpi^.next:=tmp^.next; {указатель элемента переносим на следующий элемент за удаляемым}
    FreeMem(tmp,sizeof(TList)); {удаляем элемент}
  end;
end;
 
{Процедура удаления элемента по значению}
procedure DelElemZnach(var Stek1:List;znach1:TInf);
var
  tmp:List;
begin
  if Stek1=nil then {Если стек пуст, то выводим сообщение и выходим}
  begin
    Writeln('Стек пуст');
    exit;
  end;
  tmp:=SearchElemZnach(stek1,znach1); {tmp указывает на удаляемый элемент}
  if tmp=nil then {если элемент не был найден, то выводим сообщение и выходим}
  begin
    writeln('Элемент с искомым значением ' ,znach1, ' отсутствует в стеке.');
    exit;
  end;
  DelElem(stek1,tmp); {удаляем элемент из стека }
  Writeln('Элемент удалён.'); {сообщаем о выполнении действия}
end;
 
{Удаление элемента по порядковому номеру (вершина имеет номер 1)}
Procedure DelElemPos(var stek1:List;posi:integer);
var
  i:integer;
  tmp:List;
begin
  if posi<1 then {проверка на ввод информации}
    exit;
  if stek1=nil then {если стек пуст}
  begin
    Write('Стек пуст');
    exit
  end;
  i:=1; {будет считать позиции}
  tmp:=stek1;
  while (tmp<>nil) and (i<>posi) do {пока tmp не укажет в "пустоту" или мы не найдём искомый элемент}
  begin
    tmp:=tmp^.next; {переходим на следующий элемент}
    inc(i)   {увеличиваем значение счётчика}
  end;
  if tmp=nil then {если элемента нет выводим соответствующие сообщения и выходим}
  begin
    Writeln('Элемента с порядковым номером ' ,posi, ' нет в стеке.');
    writeln('В стеке ' ,i-1, ' элемента(ов).');
    exit
  end;
  DelElem(stek1,tmp); {если мы не вышли, то элемент есть и его следует удалить}
  Writeln('Элемент удалён.'); {сообщаем о выполнении действия}
end;
 
{Процедура сортировки "пузырьком" с изменением только данных}
procedure SortBublInf(nach:list);
var
  tmp,rab:List;
  tmps:Tinf;
begin
  GetMem(tmp,SizeOf(Tlist)); {выделяем память для рабочего "буфера" обмена}
  rab:=nach; {рабочая ссылка, становимся на вершину стека}
  while rab<>nil do {пока мы не дойдём до конца стека делать}
  begin
    tmp:=rab^.next; {перейдём на следующий элемент}
    while tmp<>nil do {пока не конец стека делать}
    begin
      if tmp^.data<rab^.data then {проверяем следует ли менять элементы}
      begin
        tmps:=tmp^.data; {стандартная замена в 3 операции}
        tmp^.data:=rab^.data;
        rab^.data:=tmps
      end;
      tmp:=tmp^.next {переход к следующему элементу}
    end;
    rab:=rab^.next {переход к следующему элементу}
  end
end;
 
{Процедура сортировки "пузырьком" с изменением только адресов}
procedure SortBublLink(nach:List);
var
  tmp,pered,pered1,pocle,rab:List; {все рабочие ссылки}
begin
  rab:=nach; {становимся на вершину стека}
  while rab<>nil do{пока не конец стека делать}
  begin
    tmp:=rab^.next; {переходим к следующему за сортируемым элементу}
    while tmp<>nil do {пока не конец стека делать}
    begin
      if tmp^.data<rab^.data then {если следует произвести замену, то}
      begin
        pered:=nach; {становимся в вершину стека}
        pered1:=nach; {становимся в вершину стека}
        if rab<>nach then {если мы не стоим на изменяемом элементе, то}
          while pered^.next<>rab do pered:=pered^.next; {станем на элементе перед изменяемым}
        while pered1^.next<>tmp do pered1:=pered1^.next; {станем на элементе перед изменяемым, который находится за
        первым изменяемым}
        pocle:=tmp^.next; {запоминаем адрес элемента после второго изменяемого}
        if rab^.next=tmp then {если элементы "соседи", то}
        begin
          tmp^.next:=rab; {меняем ссылки, тут если не понятно рисуйте на листочке}
          rab^.next:=pocle
        end
        else {в случае если элементы не соседи, то}
        begin
          tmp^.next:=rab^.next;{меняем ссылки, тут если не понятно рисуйте на листочке}
          rab^.next:=pocle;
        end;
        if pered1<>rab then{советую просмотреть на листочке}
          pered1^.next:=rab;
        if rab<>nach then{советую просмотреть на листочке}
          pered^.next:=tmp
        else{всё советую просмотреть на листочке}
          nach:=tmp;
        pered1:=tmp;{советую просмотреть на листочке}
        tmp:=rab;{советую просмотреть на листочке}
        rab:=pered1;{советую просмотреть на листочке}
      end;
      tmp:=tmp^.next; {переходим на следующий элемент}
    end;
    rab:=rab^.next;{переходим на следующий элемент}
  end;
end;
 
var
  Stk, {переменная, которая всегда будет указывать на "вершину" стека}
  tmpl:List; {рабочая переменная}
  znach:Tinf; {данные вводимые пользователем}
  ch:char; {для работы менюшки}
begin
    Stk:=nil;
    repeat {цикл для нашего меню}
    clrscr; {очистка экрана, далее идёт вывод самого меню}
    Write('Программа для работы со ');
    Textcolor(4);
    Writeln('стеком.');
    Textcolor(7);
    Writeln('Выберите желаемое действие:');
    Writeln('1) Добавить элемент.');
    Writeln('2) Вывод стека.');
    Writeln('3) Удаление элемента по значению.');
    Writeln('4) Удаление элемента по порядковому номеру.');
    Writeln('5) Поиск элемента по значению');
    Writeln('6) Сортировка стека методом "Пузырька", меняя только данные.');
    Writeln('7) Сортировка стека с изменением адресов.');
    Writeln('8) Выход.');
    writeln;
    ch:=readkey; {ожидаем нажатия клавиши}
    case ch of {выбираем клавишу}
      '1':begin
            write('Введите значение добавляемого элемента: ');
            readln(znach); {считываем значение добавляемого нового элемент}
            AddElem(Stk,znach);
          end;
      '2':begin
            clrscr; {очистка экрана}
            Print(Stk); {вызов процедуры вывода}
            readkey; {ожидаем нажатия клавиши}
          end;
      '3':begin
            Write('Введите значение удаляемого элемента: ');
            readln(znach); {ввод значения удаляемого элемента}
            DelElemZnach(Stk,znach); {вызов процедуры удаления элемента по значению}
            readkey;{ожидаем нажатия клавиши}
          end;
      '4':begin
            Write('Введите порядковый номер удаляемого элемента: ');
            readln(znach); {ввод позиции удаляемого файла}
            DelElemPos(Stk,znach);{вызов процедуры удаления элемента по значению}
            readkey;{ожидаем нажатия клавиши}
          end;
      '5':begin
            write('Введите значение искомого элемента: ');
            readln(znach); {ввод искомого значения}
            tmpl:=SearchElemZnach(Stk,znach); {вызываем процедуру поиска элемента по значению}
            if tmpl=nil then {проверяем найден ли элемент и выводим соответствующие сообщения}
              write('Искомый элемент отсутствует в стеке')
            else
              write('Элемент ',tmpl^.data,' найден');
            readkey;{ожидаем нажатия клавиши}
          end;
      '6':begin
            if Stk=nil then {проверяем не пустой ли стек}
            begin
              Write('Стек пуст.');
              readkey{ожидаем нажатия клавиши}
            end
            else
            begin
              SortBublInf(Stk);{вызов процедуры сортировки стека с изменением данных}
              Write('Стек отсортирован.');
              readkey;{ожидаем нажатия клавиши}
            end
          end;
      '7':begin
            if Stk=nil then{проверяем не пустой ли стек}
            begin
              Write('Стек пуст.');
              readkey{ожидаем нажатия клавиши}
            end
            else
            begin
              SortBublLink(Stk);{вызов процедуры сортировки стека с изменением адресов}
              Write('Стек отсортирован.');
              readkey;{ожидаем нажатия клавиши}
            end
          end;
    end;
  until ch='8';
  FreeStek(Stk); {освобождаем память занятую стеком}
end.

Program Spisok;
uses
  crt; {Для использования readkey и clrscr}
type
  Tinf=integer; {тип данных, который будет храниться в элементе списка}
  List=^TList;  {Указатель на элемент типа TList}
  TList=record {А это наименование нашего типа "запись" обычно динамические структуры описываются через запись}
    data:TInf;  {данные, хранимые в элементе}
    next:List;   {указатель на следующий элемент списка}
  end;
 
{Процедура добавления нового элемента в односвязный список}
procedure AddElem(var spis1:List;znach1:TInf);
var
  tmp:List;
begin
  if spis1=nil then {Проверяем не пуст ли список, если пуст, то }
  begin
    GetMem(spis1,sizeof(TList));  {создаём его первый элемент}
    tmp:=spis1;
  end
  else {в случае если список не пуст}
  begin
    tmp:=spis1;
    while tmp^.next<>nil do
      tmp:=tmp^.next; {ставим tmp на последний элемент списка}
    GetMem(tmp^.next,sizeof(TList)); {создаём следующий элемент}
    tmp:=tmp^.next;   {переносим tmp на новый элемент}
  end;
  tmp^.next:=nil; {зануляем указатель}
  tmp^.data:=znach1; {заносим значение}
end;
 
{процедура печати списка
полностью расписана при работе со стеком}
procedure Print(spis1:List);
begin
  if spis1=nil then
  begin
    writeln('Список пуст.');
    exit;
  end;
  while spis1<>nil do
  begin
    Write(spis1^.data, ' ');
    spis1:=spis1^.next
  end;
end;
 
{процедура удаления списка
 полностью расписана при работе со стеком}
Procedure FreeStek(spis1:List);
var
  tmp:List;
begin
  while spis1<>nil do
  begin
    tmp:=spis1;
    spis1:=spis1^.next;
    FreeMem(tmp,SizeOf(Tlist));
  end;
end;
 
{процедура поиска в списке
 полностью расписана при работе со стеком}
Function SearchElemZnach(spis1:List;znach1:TInf):List;
begin
  if spis1<>nil then
    while (Spis1<>nil) and (znach1<>spis1^.data) do
      spis1:=spis1^.next;
  SearchElemZnach:=spis1;
end;
 
{процедура удаления элемента
 полностью расписана при работе со стеком}
Procedure DelElem(var spis1:List;tmp:List);
var
  tmpi:List;
begin
  if (spis1=nil) or (tmp=nil) then
    exit;
  if tmp=spis1 then
  begin
    spis1:=tmp^.next;
    FreeMem(tmp,SizeOf(TList));
  end
  else
  begin
    tmpi:=spis1;
    while tmpi^.next<>tmp do
      tmpi:=tmpi^.next;
    tmpi^.next:=tmp^.next;
    FreeMem(tmp,sizeof(TList));
  end;
end;
 
{процедура удаления элемента по значению
 полностью расписана при работе со стеком}
procedure DelElemZnach(var Spis1:List;znach1:TInf);
var
  tmp:List;
begin
  if Spis1=nil then
  begin
    Writeln('Список пуст');
    exit;
  end;
  tmp:=SearchElemZnach(spis1,znach1);
  if tmp=nil then
  begin
    writeln('Элемент с искомым значением ' ,znach1, ' отсутствует в списке.');
    exit;
  end;
  DelElem(spis1,tmp);
  Writeln('Элемент удалён.');
end;
 
{процедура удаления элемента по позиции
 полностью расписана при работе со стеком}
Procedure DelElemPos(var spis1:List;posi:integer);
var
  i:integer;
  tmp:List;
begin
  if posi<1 then
    exit;
  if spis1=nil then
  begin
    Write('Список пуст');
    exit
  end;
  i:=1;
  tmp:=spis1;
  while (tmp<>nil) and (i<>posi) do
  begin
    tmp:=tmp^.next;
    inc(i)
  end;
  if tmp=nil then
  begin
    Writeln('Элемента с порядковым номером ' ,posi, ' нет в списке.');
    writeln('В списке всего ' ,i-1, ' элемента(ов).');
    exit
  end;
  DelElem(spis1,tmp);
  Writeln('Элемент удалён.');
end;
 
{Процедура сортировки "пузырьком" с изменением только данных
 полностью расписана при работе со стеком}
procedure SortBublInf(nach:list);
var
  tmp,rab:List;
  tmps:Tinf;
begin
  GetMem(tmp,SizeOf(Tlist));
  rab:=nach;
  while rab<>nil do
  begin
    tmp:=rab^.next;
    while tmp<>nil do
    begin
      if tmp^.data<rab^.data then
      begin
        tmps:=tmp^.data;
        tmp^.data:=rab^.data;
        rab^.data:=tmps
      end;
      tmp:=tmp^.next
    end;
    rab:=rab^.next
  end
end;
 
{Процедура сортировки "пузырьком" с изменением только адресов
 полностью расписана при работе со стеком}
procedure SortBublLink(nach:List);
var
  tmp,pered,pered1,pocle,rab:List;
begin
  rab:=nach;
  while rab<>nil do
  begin
    tmp:=rab^.next;
    while tmp<>nil do
    begin
      if tmp^.data<rab^.data then
      begin
        pered:=nach;
        pered1:=nach;
        if rab<>nach then
          while pered^.next<>rab do pered:=pered^.next;
        while pered1^.next<>tmp do pered1:=pered1^.next;
        pocle:=tmp^.next;
        if rab^.next=tmp then
        begin
          tmp^.next:=rab;
          rab^.next:=pocle
        end
        else
        begin
          tmp^.next:=rab^.next;
          rab^.next:=pocle;
        end;
        if pered1<>rab then
          pered1^.next:=rab;
        if rab<>nach then
          pered^.next:=tmp
        else
          nach:=tmp;
        pered1:=tmp;
        tmp:=rab;
        rab:=pered1;
      end;
      tmp:=tmp^.next;
    end;
    rab:=rab^.next;
  end;
end;
 
var
  Spis,tmpl:List;
  znach:integer;
  ch:char;
begin
  Spis:=nil;
  repeat
    clrscr;
    Write('Программа для работы со ');
    TextColor(4);
    Writeln('списком.');
    TextColor(7);
    Writeln('Выберите желаемое действие:');
    Writeln('1) Добавить элемент.');
    Writeln('2) Вывод списка.');
    Writeln('3) Удаление элемента по значению.');
    Writeln('4) Удаление элемента по порядковому номеру.');
    Writeln('5) Поиск элемента по значению.');
    Writeln('6) Сортировка списка методом "Пузырька", меняя только данные.');
    Writeln('7) Сортировка списка с изменением адресов.');
    Writeln('8) Выход.');
    writeln;
    ch:=readkey;
    case ch of
      '1':begin
            write('Введите значение добавляемого элемента: ');
            readln(znach);
            AddElem(Spis,znach);
          end;
      '2':begin
            clrscr;
            Print(Spis);
            readkey;
          end;
      '3':begin
            Write('Введите значение удаляемого элемента: ');
            readln(znach);
            DelElemZnach(Spis,znach);
            readkey;
          end;
      '4':begin
            Write('Введите порядковый номер удаляемого элемента: ');
            readln(znach);
            DelElemPos(Spis,znach);
            readkey;
          end;
      '5':begin
            write('Введите значение искомого элемента: ');
            readln(znach);
            tmpl:=SearchElemZnach(Spis,znach);
            if tmpl=nil then
              write('Искомый элемент отсутствует в списке')
            else
              write('Элемент ',tmpl^.data,' найден');
            readkey;
          end;
      '6':begin
            if Spis=nil then
            begin
              Write('Список пуст.');
              readkey
            end
            else
            begin
              SortBublInf(Spis);
              Write('Список отсортирован.');
              readkey;
            end
          end;
      '7':begin
            if Spis=nil then
            begin
              Write('Список пуст.');
              readkey
            end
            else
            begin
              SortBublLink(Spis);
              Write('Список отсортирован.');
              readkey;
            end
          end;
    end;
  until ch='8';
  FreeStek(Spis);
end.

while a<>nil do a:=a^.next {где a - указатель на элемент}
{и если, мы удалим последний элемент,например, а не "занулим" указатель с предыдущего, 
то будет очень нехорошо, т.к. мы постараемся обратится к несуществующему элементу 
и можем испортить информацию хранящуюся по данному адресу}

Program Spisok_dn;
uses
  crt; {Для использования readkey и clrscr}
type
  Tinf=integer; {тип данных, который будет храниться в элементе списка}
  List=^TList;  {Указатель на элемент типа TList}
  TList=record {А это наименование нашего типа "запись" обычно динамические структуры описываются через запись}
    data:TInf;  {данные, хранимые в элементе}
    next,    {указатель на следующий элемент списка}
    prev:List;   {указатель на предыдущий элемент списка}
  end;
 
{Процедура добавления нового элемента в двунаправленный список}
procedure AddElem(var nach,ends:List;znach1:TInf);
begin
  if nach=nil then {не пуст ли список, если пуст, то}
  begin
    Getmem(nach,SizeOf(TList)); {создаём элемент, указатель nach уже будет иметь адрес}
    nach^.next:=nil; {никогда не забываем "занулять" указатели}
    nach^.prev:=nil; {аналогично}
    ends:=nach; {изменяем указатель конца списка}
  end
  else {если список не пуст}
  begin
    GetMem(ends^.next,SizeOf(Tlist)); {создаём новый элемент}
    ends^.next^.prev:=ends; {связь нового элемента с последним элементом списка}
    ends:=ends^.next;{конец списка изменился и мы указатель "переставляем"}
    ends^.next:=nil; {не забываем "занулять" указатели}
  end;
  ends^.data:=znach1; {заносим данные}
end;
 
procedure AddElemVst(var nach:List; var ends:List;znach1:TInf);
var
  tmp,tmpL:List;
  flag:boolean;
begin
  if nach=nil then {не пуст ли список, если пуст, то}
  begin
    Getmem(nach,SizeOf(TList)); {создаём элемент, указатель nach уже будет иметь адрес}
    nach^.next:=nil; {никогда не забываем "занулять" указатели}
    nach^.prev:=nil; {аналогично}
    ends:=nach; {изменяем указатель конца списка}
    tmp:=nach;
  end
  else {если список не пуст}
  begin
    tmpl:=nach;
    flag:=true;
    while tmpl^.data<znach1 do
    begin
      tmpl:=tmpl^.next;
      if tmpl=nil then
        break;
    end;
    if tmpl<>nil then
    begin
      tmpl:=tmpl^.prev;
      if tmpl=nach then
        flag:=false;
      if tmpl=nil then
        tmpl:=nach;
    end
    else
    begin
      tmpl:=ends;
      flag:=false
    end;
    GetMem(tmp,SizeOf(TList));
    if ends=nach then
      if ends^.data<znach1 then
      begin
        ends^.next:=tmp;
        tmp^.prev:=ends;
        tmp^.next:=nil;
        ends:=tmp;
      end
      else
      begin
        nach^.prev:=tmp;
        tmp^.prev:=nil;
        tmp^.next:=nach;
        nach:=tmp;
      end
    else
    if (tmpl=nach) and (flag) then
    begin
      nach^.prev:=tmp;
      tmp^.prev:=nil;
      tmp^.next:=nach;
      nach:=tmp;
    end
    else
      if (tmpl=nach) and not(flag) then
      begin
        tmp^.next:=nach^.next;
        nach^.next^.prev:=tmp;
        tmp^.prev:=nach;
        nach^.next:=tmp;
      end
      else
      if (tmpL=ends) and not (flag) then
      begin
        ends^.next:=tmp;
        tmp^.prev:=ends;
        tmp^.next:=nil;
        ends:=tmp;
      end
      else
      begin
        tmp^.next:=tmpl^.next;
        tmpl^.next^.prev:=tmp;
        tmp^.prev:=tmpl;
        tmpl^.next:=tmp;
      end;
  end;
  tmp^.data:=znach1; {заносим данные}
end;
 
{процедура печати списка
полностью расписана при работе со стеком}
procedure Print(spis1:List);
begin
  if spis1=nil then
  begin
    writeln('Список пуст.');
    exit;
  end;
  while spis1<>nil do
  begin
    Write(spis1^.data, ' ');
    spis1:=spis1^.next
  end;
end;
 
{процедура удаления списка
 полностью расписана при работе со стеком}
Procedure FreeStek(spis1:List);
var
  tmp:List;
begin
  while spis1<>nil do
  begin
    tmp:=spis1;
    spis1:=spis1^.next;
    FreeMem(tmp,SizeOf(Tlist));
  end;
end;
 
{Функция поиска в списке
 полностью расписана при работе со стеком}
Function SearchElemZnach(spis1:List;znach1:TInf):List;
begin
  if spis1<>nil then
    while (Spis1<>nil) and (znach1<>spis1^.data) do
      spis1:=spis1^.next;
  SearchElemZnach:=spis1;
end;
 
{процедура удаления элемента в двунаправленном списке}
Procedure DelElem(var spis1,spis2:List;tmp:List);
var
  tmpi:List;
begin
  if (spis1=nil) or (tmp=nil) then
    exit;
  if tmp=spis1 then {если удаляемый элемент первый в списке, то}
  begin
    spis1:=tmp^.next; {указатель на первый элемент переставляем на следующий элемент списка}
    if spis1<>nil then {если список оказался не из одного элемента, то}
      spis1^.prev:=nil {"зануляем" указатель}
    else {в случае, если элемент был один, то}
      spis2:=nil; {"зануляем" указатель конца списка, а указатель начала уже "занулён"}
    FreeMem(tmp,SizeOf(TList));
  end
  else
    if tmp=spis2 then {если удаляемый элемент оказался последним элементом списка}
    begin
      spis2:=spis2^.prev; {указатель конца списка переставляем на предыдущий элемент}
      if spis2<>nil then {если предыдущий элемент существует,то}
        spis2^.next:=nil {"зануляем" указатель}
      else {в случае, если элемент был один в списке, то}
        spis1:=nil; {"зануляем" указатель на начало списка}
      FreeMem(tmp,SizeOf(TList));
    end
    else {если же удаляется список не из начали и не из конца, то}
    begin
      tmpi:=spis1;
      while tmpi^.next<>tmp do {ставим указатель tmpi на элемент перед удаляемым}
        tmpi:=tmpi^.next;
      tmpi^.next:=tmp^.next; {меняем связи}
      if tmp^.next<>nil then
        tmp^.next^.prev:=tmpi; {у элемента до удаляемого и после него}
      FreeMem(tmp,sizeof(TList));
    end;
end;
 
{процедура удаления элемента по значению
 полностью расписана при работе со стеком}
procedure DelElemZnach(var Spis1,spis2:List;znach1:TInf);
var
  tmp:List;
begin
  if Spis1=nil then
  begin
    Writeln('Список пуст');
    exit;
  end;
  tmp:=SearchElemZnach(spis1,znach1);
  if tmp=nil then
  begin
    writeln('Элемент с искомым значением ' ,znach1, ' отсутствует в списке.');
    exit;
  end;
  DelElem(spis1,spis2,tmp);
  Writeln('Элемент удалён.');
end;
 
{процедура удаления элемента по позиции
 полностью расписана при работе со стеком}
Procedure DelElemPos(var spis1,spis2:List;posi:integer);
var
  i:integer;
  tmp:List;
begin
  if posi<1 then
    exit;
  if spis1=nil then
  begin
    Write('Список пуст');
    exit
  end;
  i:=1;
  tmp:=spis1;
  while (tmp<>nil) and (i<>posi) do
  begin
    tmp:=tmp^.next;
    inc(i)
  end;
  if tmp=nil then
  begin
    Writeln('Элемента с порядковым номером ' ,posi, ' нет в списке.');
    writeln('В списке всего ' ,i-1, ' элементов.');
    exit
  end;
  DelElem(spis1,spis2,tmp);
  Writeln('Элемент удалён.');
end;
 
{Процедура сортировки "пузырьком" с изменением только данных
 полностью расписана при работе со стеком}
procedure SortBublInf(nach:list);
var
  tmp,rab:List;
  tmps:Tinf;
begin
  GetMem(tmp,SizeOf(Tlist));
  rab:=nach;
  while rab<>nil do
  begin
    tmp:=rab^.next;
    while tmp<>nil do
    begin
      if tmp^.data<rab^.data then
      begin
        tmps:=tmp^.data;
        tmp^.data:=rab^.data;
        rab^.data:=tmps
      end;
      tmp:=tmp^.next
    end;
    rab:=rab^.next
  end
end;
 
{Процедура сортировки "пузырьком" с изменением только адресов}
{Чтобы разобраться как она работает Вам точно понадобится листок
 с рисунком списка и связями между элементами. Внимательно следите
 за тем, что происходит в процедуре, описывать всё я не вижу смысла}
procedure SortBublLink(var nach,ends:List);
var
  tmp,pocle1,rab:List;
begin
  rab:=nach;
  while rab<>nil do
  begin
    tmp:=rab^.next;
    while tmp<>nil do
    begin
      if tmp^.data<rab^.data then
      begin
        pocle1:=tmp^.next;
        if rab^.next=tmp then
        begin
          if tmp^.next<>nil then
            tmp^.next^.prev:=rab;
          tmp^.next:=rab;
          tmp^.prev:=rab^.prev;
          if tmp^.prev<>nil then
            tmp^.prev^.next:=tmp;
          rab^.prev:=tmp;
          rab^.next:=pocle1;
        end
        else
        begin
          if rab^.prev<>nil then
            rab^.prev^.next:=tmp;
          tmp^.prev^.next:=rab;
          if tmp^.next<>nil then
            tmp^.next^.prev:=rab;
          rab^.next^.prev:=tmp;
          tmp^.next:=rab^.next;
          rab^.next:=pocle1;
          pocle1:=rab^.prev;
          rab^.prev:=tmp^.prev;
          tmp^.prev:=pocle1;
        end;
        if rab=nach then
        begin
          nach:=tmp;
          nach^.prev:=nil;
        end;
        if tmp=ends then
        begin
          ends:=rab;
          ends^.next:=nil
        end;
        pocle1:=rab;
        rab:=tmp;
        tmp:=pocle1;
      end;
      tmp:=tmp^.next;
    end;
    rab:=rab^.next;
  end;
end;
 
{процедура берёт часть списка и вставляет в нужную позицию списка}
Procedure Swap(var nach,ends:List;a,b,c:integer); {а-начало части, b-конец части, с-позиция}
var
  i:integer;
  yk,yk1,yk2,rab:List;
begin
  rab:=nach;
  i:=0;
  while rab<>nil do {цикл определяет количество элементов}
  begin
    inc(i);
    rab:=rab^.next
  end;
 {проверка на "нормальность" введённых данных}
  if (i+1<a) or (i+1<b) or (i+1<c) or ((c>=a) and (c<=b)) then
    exit;
  if a>b then {если "ошибочно" спутаны начало и конец части, то}
  begin
    a:=a xor b; {произведём замену переменных, т.е.}
    b:=b xor a; {значение из a поместим в b}
    a:=b xor a; {из b поместим в a}
  end;
  yk:=nach;
  for i:=1 to a-1 do
    yk:=yk^.next; {ставим указатель на нужный нам элемент}
  yk1:=nach;
  for i:=1 to b-1 do
    yk1:=yk1^.next;{ставим указатель на нужный нам элемент}
  yk2:=nach;
  for i:=1 to c-1 do
    yk2:=yk2^.next;{ставим указатель на нужный нам элемент}
  if yk=nach then {проверяем следует ли нам изменить начало списка}
  begin
   nach:=yk1^.next; {изменяем начало}
   nach^.prev:=nil; {"зануляем" указатель}
  end
  else {далее я советую смотреть по листочку}
  begin
    if yk1^.next<>nil then
      yk1^.next^.prev:=yk^.prev
    else
    begin
      ends:=yk^.prev;
      yk^.prev^.next:=nil;
    end;
    yk^.prev^.next:=yk1^.next;
  end;
  if yk2^.next=nil then
  begin
    yk1^.next:=nil;
    ends:=yk1;
  end
  else
  begin
    yk2^.next^.prev:=yk1;
    yk1^.next:=yk2^.next;;
  end;
  yk2^.next:=yk;
  yk^.prev:=yk2;
end;
 
var
  SpisNach, {указатель на начало списка и}
  SpisEnd,   {указатель на конец списка. Эти два указателя }
  tmpl:List; {неотъемлимая часть в двунаправленном списке}
  znach,a,b:integer;
  ch:char;
begin
  SpisNach:=nil;
  SpisEnd:=nil;
  repeat
    clrscr;
    Write('Программа для работы с ');
    TextColor(4);
    Writeln('двунаправленным списком.');
    TextColor(7);
    Writeln('Выберите желаемое действие:');
    Writeln('1) Добавить элемент.');
    Writeln('2) Вывод списка.');
    Writeln('3) Удаление элементов по значению.');
    Writeln('4) Удаление элементов по порядковому номеру.');
    Writeln('5) Поиск элементов по значению.');
    Writeln('6) Сортировка списка методом "Пузырька", меняя только данные.');
    Writeln('7) Сортировка списка с изменением адресов.');
    Writeln('8) Swap список.');
    Writeln('9) Выход.');
    writeln;
    ch:=readkey;
    case ch of
      '1':begin
            write('Введите значение добавляемого элемента: ');
            readln(znach);
            AddElemVst(SpisNach,SpisEnd,znach);
            {AddElem(SpisNach,SpisEnd,znach);}
          end;
      '2':begin
            clrscr;
            Print(SpisNach);
            readkey;
          end;
      '3':begin
            Write('Введите значение удаляемого элемента: ');
            readln(znach);
            DelElemZnach(SpisNach,SpisEnd,znach);
            readkey;
          end;
      '4':begin
            Write('Введите порядковый номер удаляемого элемента: ');
            readln(znach);
            DelElemPos(SpisNach,SpisEnd,znach);
            readkey;
          end;
      '5':begin
            write('Введите значение искомого элемента: ');
            readln(znach);
            tmpl:=SearchElemZnach(SpisNach,znach);
            if tmpl=nil then
              write('Искомый элемент отсутствует в списке.')
            else
            begin
              write('Элемент ');
              TextColor(4);
              Write(tmpl^.data);
              TextColor(7);
              Write(' найден');
            end;
            readkey;
          end;
      '6':begin
            if SpisNach=nil then
            begin
              Write('Список пуст.');
              readkey
            end
            else
            begin
              SortBublInf(SpisNach);
              Write('Список отсортирован.');
              readkey;
            end
          end;
      '7':begin
            if SpisNach=nil then
            begin
              Write('Список пуст.');
              readkey
            end
            else
            begin
              SortBublLink(SpisNach,SpisEnd);
              Write('Список отсортирован.');
              readkey;
            end
          end;
      '8':begin
            Writeln('Список до изменений:');
            print(SpisNach);
            writeln;
            write('Введите начальную позицию: ');
            readln(a);
            Write('Введите конечную позицию: ');
            readln(b);
            write('Введите место куда вставлять: ');
            readln(znach);
            Writeln;
            swap(SpisNach,SpisEnd,a,b,znach);
            writeln;
            Writeln('Список после изменений:');
            print(SpisNach);
            readkey;
          end;
    end;
  until ch='9';
  FreeStek(SpisNach);
end.

Program Spisok_kolco;
uses
  crt; {Для использования readkey и clrscr}
type
  Tinf=integer; {тип данных, который будет храниться в элементе списка}
  List=^TList;  {Указатель на элемент типа TList}
  TList=record  {А это наименование нашего типа "запись" обычно динамические структуры описываются через запись}
    data:TInf;  {данные, хранимые в элементе}
    next:List;  {указатель на следующий элемент списка}
  end;
 
{Процедура добавления нового элемента в двунаправленный список}
procedure AddElem(var nach:List;znach1:TInf);
var
  tmp,tmp1:List;
begin
  if nach=nil then {не пуст ли список, если пуст, то}
  begin
    Getmem(nach,SizeOf(TList)); {создаём элемент, указатель nach уже будет иметь адрес}
    nach^.next:=nach; {никогда не забываем "занулять" указатели}
    tmp:=nach;
  end
  else {если список не пуст}
  begin
    tmp:=nach;
    while tmp^.next<>nach do
      tmp:=tmp^.next;
    GetMem(tmp1,SizeOf(Tlist));
    tmp1^.next:=nach;
    tmp^.next:=tmp1;
    tmp:=tmp1;
  end;
  tmp^.data:=znach1; {заносим данные}
end;
 
{процедура печати списка
полностью расписана при работе со стеком}
procedure Print(spis1:List);
var
  nach:List;
begin
  if spis1=nil then
  begin
    writeln('Список пуст.');
    exit;
  end;
  nach:=spis1;
  Write(spis1^.data, ' ');
  spis1:=spis1^.next;
  while spis1<>nach do
  begin
    Write(spis1^.data, ' ');
    spis1:=spis1^.next;
  end;
end;
 
{процедура удаления списка
 полностью расписана при работе со стеком}
Procedure FreeStek(spis1:List);
var
  tmp,nach:List;
begin
  if spis1=nil then
    exit;
  nach:=spis1;
  tmp:=spis1;
  spis1:=spis1^.next;
  dispose(tmp);
  while spis1<>nach do
  begin
    tmp:=spis1;
    spis1:=spis1^.next;
    FreeMem(tmp,SizeOf(Tlist));
  end;
end;
 
{Функция поиска в списке
 полностью расписана при работе со стеком}
Function SearchElemZnach(spis1:List;znach1:TInf):List;
var
  tmp:List;
begin
  tmp:=spis1;
  if spis1<>nil then
    if spis1^.data=znach1 then
      SearchElemZnach:=spis1
    else
    begin
      spis1:=spis1^.next;
      while (Spis1<>tmp) and (znach1<>spis1^.data) do
        spis1:=spis1^.next;
      if spis1=tmp then
        spis1:=nil;
    end;
  SearchElemZnach:=spis1;
end;
 
{процедура удаления элемента в двунаправленном списке}
Procedure DelElem(var spis1:List;tmp:List);
var
  tmpi:List;
begin
  if tmp=spis1 then
  begin
    tmpi:=tmp;
    while tmpi^.next<>spis1 do
      tmpi:=tmpi^.next;
    if tmpi=spis1 then
    begin
      spis1^.next:=nil;
      dispose(spis1);
      spis1:=nil
    end
    else
    begin
      tmpi^.next:=tmp^.next;
      spis1:=spis1^.next;
      dispose(tmp)
    end;
  end
  else
  begin
    tmpi:=spis1;
    while tmpi^.next<>tmp do
      tmpi:=tmpi^.next;
    tmpi^.next:=tmp^.next;
    dispose(tmp);
  end;
end;
 
{процедура удаления элемента по значению
 полностью расписана при работе со стеком}
procedure DelElemZnach(var Spis1:List;znach1:TInf);
var
  tmp:List;
begin
  tmp:=spis1;
  if znach1=tmp^.data then
  begin
    DelElem(spis1,tmp);
    exit;
  end;
  tmp:=tmp^.next;
  while tmp<>Spis1 do
  begin
    if tmp^.data=znach1 then
    begin
      DelElem(spis1,tmp);
      exit
    end;
    tmp:=tmp^.next;
  end;
end;
 
{процедура удаления элемента по позиции
 полностью расписана при работе со стеком}
Procedure DelElemPos(var spis1:List;posi:integer);
var
  i:integer;
  tmp:List;
begin
  if spis1=nil then
  begin
    writeln('Список пуст.');
    readkey;
    exit
  end;
  tmp:=spis1^.next;
  i:=1;
  while tmp<>spis1 do
  begin
    tmp:=tmp^.next;
    inc(i)
  end;
  if (posi<1) or (posi>i) then
  begin
    writeln('В списке ',i, ' элемента(ов).');
    writeln('Элемент ',posi,' отсутствует в списке.');
    readkey;
    exit
  end
  else
  begin
    i:=1;
    tmp:=spis1;
    while i<posi do
    begin
      tmp:=tmp^.next;
      inc(i)
    end;
    DelElem(spis1,tmp);
  end;
end;
 
{Процедура сортировки "пузырьком" с изменением только данных
 полностью расписана при работе со стеком}
procedure SortBublInf(nach:list);
var
  tmp,rab:List;
  tmps:Tinf;
begin
  GetMem(tmp,SizeOf(Tlist));
  rab:=nach;
  while rab^.next<>nach do
  begin
    tmp:=rab^.next;
    while tmp<>nach do
    begin
      if tmp^.data<rab^.data then
      begin
        tmps:=tmp^.data;
        tmp^.data:=rab^.data;
        rab^.data:=tmps
      end;
      tmp:=tmp^.next
    end;
    rab:=rab^.next
  end
end;
 
{procedure SortBublLink(var nach:List);
var
  tmp,pocle1,rab:List;
begin
  if nach=nil then
    exit;
  rab:=nach;
  while rab^.next<>nach do
  begin
    tmp:=rab^.next;
    while tmp<>nach do
    begin
      if tmp^.data<rab^.data then
      begin
 
      end;
      tmp:=tmp^.next;
    end;
    rab:=rab^.next;
  end;
end;}
 
var
  SpisNach, {указатель на начало списка и}
  tmpl:List; {неотъемлимая часть в двунаправленном списке}
  znach,a,b:integer;
  ch:char;
begin
  SpisNach:=nil;
  repeat
    clrscr;
    Write('Программа для работы с ');
    TextColor(4);
    Writeln('кольцевым списком.');
    TextColor(7);
    Writeln('Выберите желаемое действие:');
    Writeln('1) Добовить элемент.');
    Writeln('2) Вывод списка.');
    Writeln('3) Удаление элемента по значению.');
    Writeln('4) Удаление элемента по порядковому номеру.');
    Writeln('5) Поиск элемента по значению.');
    Writeln('6) Сортировка списка методом "Пузырька", меняя только данные.');
    Writeln('7) Выход.');
    writeln;
    ch:=readkey;
    case ch of
      '1':begin
            write('Введите значение добавляемого элемента: ');
            readln(znach);
            AddElem(SpisNach,znach);
          end;
      '2':begin
            clrscr;
            Print(SpisNach);
            readkey;
          end;
      '3':begin
            Write('Введите значение удаляемого элемента: ');
            readln(znach);
            DelElemZnach(SpisNach,znach);
          end;
      '4':begin
            Write('Введите порядковый номер удаляемого элемента: ');
            readln(znach);
            DelElemPos(SpisNach,znach);
            readkey;
          end;
      '5':begin
            write('Введите значение искомого элемента: ');
            readln(znach);
            tmpl:=SearchElemZnach(SpisNach,znach);
            if tmpl=nil then
              write('Искомый элемент отсутствует в списке.')
            else
              write('Элемент ',tmpl^.data,' найден.');
            readkey;
          end;
      '6':begin
            if SpisNach=nil then
            begin
              Write('Список пуст.');
              readkey
            end
            else
            begin
              SortBublInf(SpisNach);
              Write('Список отсортирован.');
              readkey;
            end
          end;
    end;
  until ch='7';
  FreeStek(SpisNach);
end.

Program Ochered;
uses
  crt; {Для использования readkey и clrscr}
type
  Tinf=integer; {тип данных, который будет храниться в элементе очереди}
  List=^TList;  {Указатель на элемент типа TList}
  TList=record {А это наименование нашего типа "запись" обычно динамические структуры описываются через запись}
    data:TInf;  {данные, хранимые в элементе}
    next:List;   {указатель на следующий элемент}
  end;
 
{Процедура добавляющая элемент в очередь}
procedure AddElem(var stek1:List;znach1:TInf);
var
  tmp:List;
begin
  GetMem(tmp,sizeof(TList)); {выделяем в памяти место для нового элемента}
  tmp^.next:=stek1;  {указатель на следующий элемент "направляем" на хвост очереди}
  tmp^.data:=znach1; {добавляем к элементу данные}
  stek1:=tmp; {хвост очереди изменился, надо перенести и указатели на неё}
end;
 
{Процедура вывода очереди начиная с хвоста}
procedure Print(stek1:List);
begin
  if stek1=nil then {проверка на пустоту очереди}
  begin
    writeln('Очередь пуста.');
    exit;
  end;
  while stek1<>nil do {пока указатель stek1 не станет указывать в пустоту}
  begin   {а это произойдёт как только он перейдёт по ссылке последнего элемента}
    Write(stek1^.data, ' '); {выводить данне}
    stek1:=stek1^.next  {и переносить указатель в начало очереди}
  end;
end;
 
{Процедура освобождения памяти занятой очередью}
Procedure FreeStek(stek1:List);
var
  tmp:List;
begin
  while stek1<>nil do {пока stek1 не станет указывать в "пустоту" делать}
  begin
    tmp:=stek1; {указатель tmp направим на хвост очереди}
    stek1:=stek1^.next; {хвост очереди перенесём на следующий за данным элементом элемент}
    FreeMem(tmp,SizeOf(Tlist)); {освободим память занятую под удаляемый элемент}
  end;
end;
 
{Поиск элемента в очереди по значению}
Function SearchElemZnach(stek1:List;znach1:TInf):List;
begin
  if stek1<>nil then {если стек не пуст, то}
    while (Stek1<>nil) and (znach1<>stek1^.data) do {пока stek1 не укажет в "пустоту" или пока мы не нашли нужный нам элемент}
      stek1:=stek1^.next; {переносить указатель}
  SearchElemZnach:=stek1;{функция возвращает указатель на найденный элемент}
end;         {в случае если элемент не найден, она вернёт nil}
 
{Процедура удаления элемента по указателю}
Procedure DelElem(var stek1:List;tmp:List);
var
  tmpi:List;
begin
  if (stek1=nil) or (tmp=nil) then {если очередь пуст или указатель никуда не указывает, то выходим}
    exit;
  if tmp=stek1 then {если мы удаляем элемент который является хвостом очереди, то}
  begin
    stek1:=tmp^.next;{следует перенести вершину и}
    FreeMem(tmp,SizeOf(TList)); {высвободить память из под элемента}
  end
  else {в случае, если удаляемый элемент не хвост очереди, то}
  begin
    tmpi:=stek1; {ставим указатель на хвост очереди}
    while tmpi^.next<>tmp do {доходим до элемента стоящего "перед" тем, который нам следует удалить}
      tmpi:=tmpi^.next;
    tmpi^.next:=tmp^.next; {указатель элемента переносим на следующий элемент за удаляемым}
    FreeMem(tmp,sizeof(TList)); {удаляем элемент}
  end;
end;
 
{Процедура удаления элемента по значению}
procedure DelElemZnach(var Stek1:List;znach1:TInf);
var
  tmp:List;
begin
  if Stek1=nil then {Если очередь пуста, то выводим сообщение и выходим}
  begin
    Writeln('Очередь пуста.');
    exit;
  end;
  tmp:=SearchElemZnach(stek1,znach1); {tmp указывает на удаляемый элемент}
  if tmp=nil then {если элемент не был найден, то выводим сообщение и выходим}
  begin
    writeln('Элемент с искомым значением ' ,znach1, ' отсутствует в очереди.');
    exit;
  end;
  DelElem(stek1,tmp); {удаляем элемент из очереди}
  Writeln('Элемент удалён.'); {сообщаем о выполнении действия}
end;
 
{Удаление элемента по порядковому номеру (хвост имеет номер 1)}
Procedure DelElemPos(var stek1:List;posi:integer);
var
  i:integer;
  tmp:List;
begin
  if posi<1 then {проверка на ввод информации}
    exit;
  if stek1=nil then {если очередь пуста}
  begin
    Write('Очередь пуста.');
    exit
  end;
  i:=1; {будет считать позиции}
  tmp:=stek1;
  while (tmp<>nil) and (i<>posi) do {пока tmp не укажет в "пустоту" или мы не найдём искомый элемент}
  begin
    tmp:=tmp^.next; {переходим на следующий элемент}
    inc(i)   {увеличиваем значение счётчика}
  end;
  if tmp=nil then {если элемента нет выводим соответствующие сообщения и выходим}
  begin
    Writeln('Элемента с порядковым номером ' ,posi, ' нет в очереди.');
    writeln('В очереди ' ,i-1, ' элементов(а).');
    exit
  end;
  DelElem(stek1,tmp); {если мы не вышли, то элемент есть и его следует удалить}
  Writeln('Элемент удалён.'); {сообщаем о выполнении действия}
end;
 
{Процедура сортировки "пузырьком" с изменением только данных}
procedure SortBublInf(nach:list);
var
  tmp,rab:List;
  tmps:Tinf;
begin
  GetMem(tmp,SizeOf(Tlist)); {выделяем память для рабочего "буфера" обмена}
  rab:=nach; {рабочая ссылка, становимся на хвост очереди}
  while rab<>nil do {пока мы не дойдём до конца стека делать}
  begin
    tmp:=rab^.next; {перейдём на следующий элемент}
    while tmp<>nil do {пока не конец очереди делать}
    begin
      if tmp^.data<rab^.data then {проверяем следует ли менять элементы}
      begin
        tmps:=tmp^.data; {стандартная замена в 3 операции}
        tmp^.data:=rab^.data;
        rab^.data:=tmps
      end;
      tmp:=tmp^.next {переход к следующему элементу}
    end;
    rab:=rab^.next {переход к следующему элементу}
  end
end;
 
{Процедура сортировки "пузырьком" с изменением только адресов}
procedure SortBublLink(nach:List);
var
  tmp,pered,pered1,pocle,rab:List; {все рабочие ссылки}
begin
  rab:=nach; {становимся на вершину стека}
  while rab<>nil do{пока не конец очереди делать}
  begin
    tmp:=rab^.next; {переходим к следующему за сортируемым элементу}
    while tmp<>nil do {пока не конец очереди делать}
    begin
      if tmp^.data<rab^.data then {если следует произвести замену, то}
      begin
        pered:=nach; {становимся на хвост очереди}
        pered1:=nach; {становимся на хвост очереди}
        if rab<>nach then {если мы не стоим на изменяемом элементе, то}
          while pered^.next<>rab do pered:=pered^.next; {станем на элементе перед изменяемым}
        while pered1^.next<>tmp do pered1:=pered1^.next; {станем на элементе перед изменяемым, который находится за
        первым изменяемым}
        pocle:=tmp^.next; {запоминаем адрес элемента после второго изменяемого}
        if rab^.next=tmp then {если элементы "соседи", то}
        begin
          tmp^.next:=rab; {меняем ссылки, тут если не понятно рисуйте на листочке}
          rab^.next:=pocle
        end
        else {в случае если элементы не соседи, то}
        begin
          tmp^.next:=rab^.next;{меняем ссылки, тут если не понятно рисуйте на листочке}
          rab^.next:=pocle;
        end;
        if pered1<>rab then{советую просмотреть на листочке}
          pered1^.next:=rab;
        if rab<>nach then{советую просмотреть на листочке}
          pered^.next:=tmp
        else{всё советую просмотреть на листочке}
          nach:=tmp;
        pered1:=tmp;{советую просмотреть на листочке}
        tmp:=rab;{советую просмотреть на листочке}
        rab:=pered1;{советую просмотреть на листочке}
      end;
      tmp:=tmp^.next; {переходим на следующий элемент}
    end;
    rab:=rab^.next;{переходим на следующий элемент}
  end;
end;
 
var
  Stk, {переменная, которая всегда будет указывать на "хвост" очереди}
  tmpl:List; {рабочая переменная}
  znach:Tinf; {данные вводимые пользователем}
  ch:char; {для работы с меню}
begin
  Stk:=nil;
  repeat {цикл для нашего меню}
    clrscr; {очистка экрана, далее идёт вывод самого меню}
    Writeln('Программа для работы с очередями.');
    Writeln('Выберите желаемое действие:');
    Writeln('1) Добавить элемент.');
    Writeln('2) Вывод очереди (начиная с головы).');
    Writeln('3) Удаление элемента по значению.');
    Writeln('4) Удаление элемента по порядковому номеру.');
    Writeln('5) Поиск элемента по значению.');
    Writeln('6) Сортировка очереди методом "Пузырька", меняя только данные.');
    Writeln('7) Сортировка очереди методом "Пузырька", меняя только адресс.');
    Writeln('8) Выход.');
    writeln;
    ch:=readkey; {ожидаем нажатия клавиши}
    case ch of {выбираем клавишу}
      '1':begin
            write('Введите значение добавляемого элемента: ');
            readln(znach); {считываем значение добавляемого нового элемент}
            AddElem(Stk,znach);
          end;
      '2':begin
            clrscr; {очистка экрана}
            Print(Stk); {вызов процедуры вывода}
            readkey; {ожидаем нажатия клавиши}
          end;
      '3':begin
            Write('Введите значение удаляемого элемента: ');
            readln(znach); {ввод значения удаляемого элемента}
            DelElemZnach(Stk,znach); {вызов процедуры удаления элемента по значению}
            readkey;{ожидаем нажатия клавиши}
          end;
      '4':begin
            Write('Введите порядковый номер удаляемого элемента: ');
            readln(znach); {ввод позиции удаляемого файла}
            DelElemPos(Stk,znach);{вызов процедуры удаления элемента по значению}
            readkey;{ожидаем нажатия клавиши}
          end;
      '5':begin
            write('Введите значение искомого элемента: ');
            readln(znach); {ввод искомого значения}
            tmpl:=SearchElemZnach(Stk,znach); {вызываем процедуру поиска элемента по значению}
            if tmpl=nil then {проверяем найден ли элемент и выводим соответствующие сообщения}
              write('Искомый элемент отсутствует в очереди.')
            else
              write('Элемент ',tmpl^.data,' найден.');
            readkey;{ожидаем нажатия клавиши}
          end;
      '6':begin
            if Stk=nil then {проверяем не пустой ли стек}
            begin
              Write('Очередь пуста.');
              readkey{ожидаем нажатия клавиши}
            end
            else
            begin
              SortBublInf(Stk);{вызов процедуры сортировки стека с изменением данных}
              Write('Очередь отсортирована.');
              readkey;{ожидаем нажатия клавиши}
            end
          end;
      '7':begin
            if Stk=nil then{проверяем не пустой ли стек}
            begin
              Write('Очередь пуста.');
              readkey{ожидаем нажатия клавиши}
            end
            else
            begin
              SortBublLink(Stk);{вызов процедуры сортировки стека с изменением адресов}
              Write('Очередь отсортирована.');
              readkey;{ожидаем нажатия клавиши}
            end
          end;
    end;
  until ch='8';
  FreeStek(Stk); {освобождаем память занятую очередью}
end.

uses crt;
type
PNode=^Node;  {Указатель на узел}
 Node=record  {Тип запись в котором будет храниться информация}
   data:integer;
   left,right:PNode; {Ссылки на левого и правого сыновей}
end;
 
var
  Tree,p1:PNode; {Tree адрес корня дерева, p1-вспомогательная переменная}
  n,x,i:integer;
  ch:char; {для работы менюшки}
 
{Процедура добавления элемента }
procedure AddToTree (var Tree:PNode;x:integer); {Входные параметры - адрес корня дерева и добавл элемент }
begin
 if Tree=nil then  {Если дерево пустое то создаём его корень}
   begin
     New(Tree);   {Выделяем память }
     Tree^.data:=x;     {Добавляем данные }
     Tree^.left:=nil;     {Зануляем указатели на левого }
     Tree^.right:=nil;  {и правого сыновей }
      exit;
   end;
 if x < Tree^.data then   {Доб к левому или правому поддереву это завсит от вводимого элемента}
     AddToTree(Tree^.left,x)  {если меньше корня то в левое поддерево }
  else
    AddToTree(Tree^.right,x);  {если больше то в правое}
end;
 
{Функция поиска по дереву}
function Search(Tree:PNode;x:integer):PNode; {Возвращает адрес искомого элемента, nil если не найден}
var
p:PNode;   {вспомог переменнная }
begin
  if Tree=nil then   {если дерево пустое то}
     begin
       Search:=nil;  {присваеваем функции результат нил}
       exit; {и выходим }
     end;
  if x=Tree^.data then  {если искомый элемент равен корню дерева то }
    p:=Tree  {Пзапоминаем его адрес }
     else   {иначе}
       if x < Tree^.data then {если вводимый элемент менньше корня то }
          p:=Search(Tree^.left,x) {то ищем его в левом поддереве}
       else     {иначе }
         p:=Search(Tree^.right,x);  {ищем в правом поддереве }
  Search:=p; {присваеваем переменной с именем фугкции результат работы}
end;
 
{Обход дерева по принципу Левый-корень-правый }
procedure Lkp(Tree:PNode);
begin
  if Tree=nil then  {Если дерево пустое }
   exit;      {то выход }
  Lkp(Tree^.left);  {иначе начинаем обход с левого подднрева}
  write('  ',Tree^.data); {выводим данные }
  Lkp(Tree^.right);  {обходим правое поддерево}
end;
 
{Процедура удаления дерева}
procedure DeleteTree(var Tree1:PNode );
begin
        if Tree1 <> nil then
          begin
            DeleteTree (Tree1^.LEFT);
            DeleteTree (Tree1^.RIGHT);
            Dispose(Tree1);
          end;
end;
 {основная пограмма}
begin
 Tree:=nil;
 repeat {цикл для нашего меню}
 
    Writeln('Выберете действие ');
    Textcolor(2);
    Writeln('Доступны следующие пункты:');
    Writeln('1) Создание дерева поиска');
    Writeln('2) Поиск элемента в дереве');
    Writeln('3) Вывод дерева');
    Writeln('4) ‚Выход');
    writeln;
    readln(ch); {ожидаем нажатия клавиши}
    case ch of {выбираем клавишу}
      '1': begin
            writeln(' kolv elementov');
            readln(n);
              for i:=1 to n do
                begin
                  writeln('Введите число');
                  readln(x);
                  AddToTree(Tree,x);
                end;
           end;
       '2': begin
               writeln('Элемент для поиска');
               readln(x);
               p1:=Search(Tree,x);
                  if p1 <> nil then
                    writeln('Найден')
                  else writeln('Такого элемента нет!');
            end;
        '3': begin
              writeln('Само дерево');
              Lkp(Tree);
              writeln;
             end;
        end;
   until ch='4';
   DeleteTree(Tree);
end.

program tree;
uses crt;
 
type {описание узла дерева}
  PNode = ^TNode;
  TNode = record
    value: integer;
    left: PNode;
    right: PNode;
  end;
 
var {раздел описания переменных}
  BiTree1, BiTree2: PNode;
  Node1, Node2: PNode;
  n: integer;
 
function CreateRandomBinaryTree(count_node: integer): PNode;
{построение дерева минимальной высоты}
var
  nleft, nright: integer;
  node: pnode;
  x: integer;
Begin
  if count_node = 0 then
    node:=nil
  else begin
    nleft:= count_node div 2; {построение левого поддерева}
    nright:= count_node - nleft - 1; {построение правого поддерева}
    write('vvedite element dereva: ');
    read(x); {ввод  элементов дерева}
    new(node);
    node^.value:= x;
    node^.left:= CreateRandomBinaryTree(nleft);
    node^.right:= CreateRandomBinaryTree(nright);
  end;
  CreateRandomBinaryTree:= node;
End;
 
procedure DestroyBinaryTree(root: PNode);
Begin
  if root <> nil then begin
    DestroyBinaryTree(root^.left);
    DestroyBinaryTree(root^.right);
    Dispose(root);
  end;
End;
 
function FindNodeByValue(root: PNode; value: integer): PNode;
{поиск искомого элемента дерева}
var
  temp: PNode;
Begin
  if root = nil then
    FindNodeByValue:= nil
  else
    if root^.value = value then
      FindNodeByValue:= root
    else begin
      temp:= FindNodeByValue(root^.left, value);
      if temp = nil then
        temp:= FindNodeByValue(root^.right, value);
      FindNodeByValue:= temp;  
    end;
End;
 
function FindNodeWithLeftNil(root: PNode): PNode;
{проверка на то, пусто ли левое поддерево}
Begin
  if root^.left = nil then
    FindNodeWithLeftNil:= root
  else
    FindNodeWithLeftNil:= FindNodeWithLeftNil(root^.left);
End;
 
procedure PrintTree(root: PNode; h: integer); {печать дерева с отступом}
begin
 if root <> nil then begin
  Printtree(root^.right,h+2);
  writeln(' ':h, root^.value);
  PrintTree(root^.left, h+2);
 end;
end;
 
BEGIN {начало программы}
  clrscr; {очистка экрана}
  Write ('Kolichestvo uzlov 1 dereva: ');
  Readln(n); {ввод количества узлов первого дерева}
  writeln('Binarnoe derevo 1 minimalnoy visoti:');
  BiTree1:= CreateRandomBinaryTree(n);
 {построение первого дерева минимальной высоты}
  PrintTree(BiTree1, 0);
  readln; {переход на новую строку}
  Write ('Kolichestvo uzlov 2 dereva: ');
  Readln(n); {ввод количества узлов второго дерева}
  writeln('Binarnoe derevo 2 minimalnoy visoti:');
  BiTree2:= CreateRandomBinaryTree(n);
 {построение второго дерева минимальной высоты}
  PrintTree(BiTree2, 0);
  readln; {переход на новую строку}
  Write ('Iskomoe znachenie: ');
  Readln(n); {ввод искомого элемента первого дерева}
  Node1:= FindNodeByValue(BiTree1, n);
  if Node1 <> nil then begin
    Node2:= FindNodeWithLeftNil(Node1);
    Node2^.left:= BiTree2;
    PrintTree(BiTree1, 0);
  end
  else
    Write('Znachenie ne naideno');
  Readln;
  DestroyBinaryTree(BiTree1);
END. {конец программы}

type
    pStackEl = ^StackEl;
    data = Integer;
 
    StackEl = record
        Value:data;
        Prev:pStackEl;
    End;

type
    pNode = ^listEl;
 
    ListEl = record
           Name:string;
           Stack:StackOfData;
           Next:pNode;
    End;

Unit UStack;
Interface
Const
     MaxStack = 7;
type
    pStackEl = ^StackEl;
    data = Integer;
 
    StackEl = record
        Value:data;
        Prev:pStackEl;
    End;
 
    StackOfData = object
    public
        procedure Create;
        function IsEmpty:boolean;
        function IsFull:boolean;
        procedure Push(val:data);
        function Pop:data;
        procedure Print;
    private
        Top:pStackEl;
    End;
Implementation
Var
    i : Integer;
    stack1:stackOfData;
{///////////////////////////////////////////////}
procedure StackOfData.Create;
Begin
     Top:=Nil;
End;
{///////////////////////////////////////////////}
function StackOfData.IsEmpty:boolean;
Begin
     If Top = Nil Then
        IsEmpty:=True
     Else
        IsEmpty:=False;
End;
{///////////////////////////////////////////////}
function StackOfData.IsFull:boolean;
Var
   count:Integer;
   PSE:PstackEl;
Begin
   PSE:=Top;
   count:=0;
   While PSE<>Nil Do
   Begin
        count:=count+1;
        PSE:=PSE^.Prev;
   End;
   If count>=MaxStack Then
        IsFull:=True
     Else
        IsFull:=False;
End;
{///////////////////////////////////////////////}
procedure StackOfData.Push(val:data);
Var
   NewStackEl:pStackEl;
Begin
   New(NewStackEl);
   NewStackEl^.value:=val;
   NewStackEl^.prev:=Top;
   Top:=NewStackEl;
End;
{///////////////////////////////////////////////}
function StackOfData.Pop:data;
Var
   PSE:pStackEl;
Begin
     Pop:=Top^.value;
     PSE:=Top;
     Top:=Top^.prev;
     Dispose(PSE);
End;
{////////////////////////////////////////////}
procedure StackOfData.Print;
Var
   PSE:PstackEl;
Begin
   PSE:=Top;
   While PSE<>Nil Do
   Begin
        Write(PSE^.Value,' ');
        PSE:=PSE^.Prev;
   End;
End;
{///////////////////////////////////////////////}
Begin
     
End.

Unit UList;
Interface
Uses UStack,crt;
 
type
    pNode = ^listEl;
 
    ListEl = record
           Name:string;
           Stack:StackOfData;
           Next:pNode;
    End;
    ListOfStack = object
    public
        procedure Create;
        procedure AddNode(klox:string);
        procedure DelNode(var delEl:pNode);
        function Find:pNode;
        procedure ChangeStack(var ple:pNode);
   private
        head:pNode;
        tail:pNode;
    End;
 
Implementation
{////////////////////////////////////////////}
procedure ListOfStack.Create;
Begin
     head:=Nil;
     tail:=Nil;
End;
{////////////////////////////////////////////}
procedure ListOfStack.AddNode(klox:string);
var
    NewNode:pNode;
Begin
    If head<>Nil Then
    Begin
        New(NewNode);
        NewNode^.name:=klox;
        NewNode^.Stack.Create;
        NewNode^.next:=Nil;
        tail^.next:=NewNode;
        tail:=NewNode;
    End
    Else
    Begin
        New(head);
        head^.name:=klox;
        head^.Stack.Create;
        Head^.next:=Nil;
        tail:=head;;
    End;
End;
{////////////////////////////////////////////}
procedure ListOfStack.DelNode(var delEl:pNode);
var
    ple:pNode;
Begin
    If delEl<>Nil Then
    Begin
        If delEl=head Then
        Begin
           head:=head^.next;
           Dispose(delEl);
        End
        Else
        Begin
           ple:=head;
           While ((ple^.next<>delEl) and (ple <> Nil )) Do  ple:=ple^.next;
           If delEl=tail Then tail:=ple;
           ple^.next:=delEl^.next;
           Dispose(delEl);
        End;
    End;
End;
{////////////////////////////////////////////}
function ListOfStack.Find:pNode;
Var
    ple:pNode;
    c:char;
    count,m:Integer;
Begin
    ple:=head;
    count:=0;
    m:=0;
    writeln('->BACK');
    While ple<>Nil Do
    Begin
        writeln('  ',ple^.name);
        ple:=ple^.next;
        count:=count+1;
    End;
    writeln;
    repeat
        c := readkey;
        if ((c=#72) and (m>0)) Then
        Begin
             GoToXY(1,m+1);
             write('  ');
             m:=m-1;
             GoToXY(1,m+1);
             write('->');
        End;
        if ((c=#80) and (m<count)) Then
        Begin
             GoToXY(1,m+1);
             write('  ');
             m:=m+1;
             GoToXY(1,m+1);
             Write('->');
        End;
    until c=#13;
    If m = 0 Then
       Find:=Nil
    Else
    Begin
       ple:=head;
       While m>1 Do
       Begin
            ple:=ple^.next;
            m:=m-1;
       End;
       Find:=ple;
    End;
    clrscr;
End;
{////////////////////////////////////////////}
procedure ListOfStack.ChangeStack(var ple:pNode);
var
   m:Integer;
   c:char;
   val:data;
Begin
If ple<>Nil Then
Begin
m:=1;
While m<>0 Do
Begin
   clrscr;
   Writeln('->BACK');
   Writeln('  Push');
   Writeln('  Pop');
   Writeln('  Print');
   m:=0;
   repeat
        c := readkey;
        if ((c=#72) and (m>0)) Then
        Begin
             GoToXY(1,m+1);
             write('  ');
             m:=m-1;
             GoToXY(1,m+1);
             write('->');
        End;
        if ((c=#80) and (m<3)) Then
        Begin
             GoToXY(1,m+1);
             write('  ');
             m:=m+1;
             GoToXY(1,m+1);
             Write('->');
        End;
    until c=#13;
    clrscr;
    If m=1 Then
    Begin
         If Not ple^.Stack.IsFull Then
         Begin
              write('Please enter value: ');
              readln(Val);
              ple^.Stack.Push(val);
 
         End
         Else
         Begin
             Writeln('Stack is full!');
             readln;
         End;
    End;
    If m = 2 Then
    If Not ple^.Stack.IsEmpty Then
    Begin
       Writeln(ple^.Stack.Pop);
       readln;
    End
    Else
    Begin
       write('Stack is empty!');
       readln;
    End;
    If m = 3 Then
    Begin
         ple^.Stack.Print;
         readln;
    End;
End;
End;
End;
{////////////////////////////////////////////}
Begin
     
End.