Сортировка связанного списка

program noname;

type
  PData = ^TData;
  TData = record
    next: PData;
    Name: string[40];
    { ...другие поля данных }
  end;

var
  root: PData; { это указатель на первую запись в связанном списке }

procedure InsertRecord(var root: PData; pItem: PData);
(* вставляем запись, на которую указывает pItem в список начиная
с root и с требуемым порядком сортировки *)
var
  pWalk, pLast: PData;
begin
  if root = nil then
  begin
    (* новый список все еще пуст, просто делаем запись,
    чтобы добавить root к новому списку *)
    root := pItem;
    root^.next := nil
  end { If }
  else
  begin
    (* проходимся по списку и сравниваем каждую запись с одной
    включаемой. Нам необходимо помнить последнюю запись,
    которую мы проверили, причина этого станет ясна немного позже. *)
    pWalk := root;
    pLast := nil;

    (* условие в следующем цикле While определяет порядок сортировки!
    Это идеальное место для передачи вызова функции сравнения,
    которой вы передаете дополнительный параметр InsertRecord для
    осуществления общей сортировки, например:

    While CompareItems( pWalk, pItem ) < 0 Do Begin
    where
    Procedure InsertRecord( Var list: PData; CompareItems: TCompareItems );
    and
    Type TCompareItems = Function( p1,p2:PData ): Integer;
    and a sample compare function:
    Function CompareName( p1,p2:PData ): Integer;
    Begin
    If p1^.Name < p2^.Name Then
    CompareName := -1
    Else
    If p1^.Name > p2^.Name Then
    CompareName := 1
    Else
    CompareName := 0;
    End;
    *)
    while pWalk^.Name < pItem^.Name do
      if pWalk^.next = nil then
      begin
        (* мы обнаружили конец списка, поэтому добавляем
        новую запись и выходим из процедуры *)
        pWalk^.next := pItem;
        pItem^.next := nil;
        Exit;
      end { If }
      else
      begin
        (* следующая запись, пожалуйста, но помните,
        что одну мы только что проверили! *)
        pLast := pWalk;

        (* если мы заканчиваем в этом месте, то значит мы нашли
        в списке запись, которая >= одной включенной. Поэтому
        вставьте ее перед записью, на которую в настоящий момент
        указывает pWalk, которая расположена после pLast. *)
        if pLast = nil then
        begin
          (* Упс, мы вывалились из цикла While на самой первой итерации!
          Новая запись должна располагаться в верхней части списка,
          поэтому она становится новым корнем (root)! *)
          pItem^.next := root;
          root := pItem;
        end { If }
        else
        begin
          (* вставляем pItem между pLast и pWalk *)
          pItem^.next := pWalk;
          pLast^.next := pItem;
        end; { Else }
        (* мы сделали это! *)
      end; { Else }
  end; { InsertRecord }

procedure SortbyName(var list: PData);
var

  newtree, temp, stump: PData;
begin { SortByName }

  (* немедленно выходим, если сортировать нечего *)
  if list = nil then
    Exit;
  (* в
  newtree := Nil;

  (********
  Сортируем, просто беря записи из оригинального списка и вставляя их
  в новый, по пути "перехватывая" для определения правильной позиции в
  новом дереве. Stump используется для компенсации различий списков.
  temp используется для указания на запись, перемещаемую из одного
  списка в другой.
  ********)
  stump := list;
  while stump <> nil do
  begin
    (* временная ссылка на перемещаемую запись *)
    temp := stump;
    (* "отключаем" ее от списка *)
    stump := stump^.next;
    (* вставляем ее в новый список *)
    InsertRecord(newtree, temp);
  end; { While }

  (* теперь помещаем начало нового, сортированного
  дерева в начало старого списка *)
  list := newtree;
end; { SortByName }
begin

  New(root);
  root^.Name := 'BETA';
  New(root^.next);
  root^.next^.Name := 'ALPHA';
  New(root^.next^.next);
  root^.next^.next^.Name := 'Torture';

  WriteLn(root^.name);
  WriteLn(root^.next^.name);
  WriteLn(root^.next^.next^.name);
end.