{Программа для чтения из файла строк и одновремменное создание линейного
тринаправленного списка, 1-й - как в файле, 2-й отсорт. по убыв, 3-й - по возр.}
{Copyright Innocenty Enikeew (YEAR-2000)084/1 17.10.2001}
type
 PList = ^TList;
 chains   = array[1..3] of PList; {Массив указателей на эл-ты}
 TList = record
   s : string;  {Значение эл-та списка.}
   next : chains; {Массив ссылок. 1-й - на следующий
                                  2-й - на сортированный по убыв
                                  3-й - --------\\--------- возрост}
 end;
Const
 msgs : array [1..3] of string = ('не отсортированный','отсортированный по убыванию','отсортированный по возростанию');
  {Массив сообщений о сортировке}
{--------------------------------------------------------}
Procedure CreateList(var F:text;var hs,ts : chains);
{Процедура чтения элементов из файла с одновременной сортировкой по убыванию
 и возростанию
 Входные:
  F  - текстовый файл, откуда считиваются данные
 Выходные
  hs - массив указателей на головы списков
  ts - ---------//--------- хвосты списков
Алгоритм работы:
 1) Считывается первый элемент, которым инициализируются ВСЕ указатели
 2) Пока файл не кончится, создаем и считываем следующий элемент. Записываем 
    в 1-й указатель
 3) Находим место по возрастанию. Вставляем туда, получая 2-ю ссылку
 4) ------\\-------- убыванию.    ----------\\-----------  3-ю
 5) Переход не 2
}
var
 i           : integer;  {Указывает номер ссылки}
 n,c         : PList;    {с - новый созданный, n - "бегунок" для поиска места}
begin                           
  New(Hs[1]);                { \ }
  Hs[2]:=Hs[1];              { | }
  Hs[3]:=Hs[1];              { | }
  for i := 1 to 3 do         { | Создание }
   begin                     { | и чтение ПЕРВОГО элемента}
    ts[i]:=hs[1];            { | }
    Hs[1]^.next[i] := nil;   { | }
   end;                      { | }
  ReadLn(F,Hs[1]^.s);        { / }
  while not EOF(F) do       {Основной цикл считывания элементов}
  begin
    New(c);for i := 1 to 3 do c^.next[i]:=nil;  {Выделение нового эл-та и
                                                 инициализация его ссылок}
    ts[1]^.Next[1] := c;     {Занесем его в конец первой цепочки}
    ts[1]:=c;                {и сдвинем ее хвост}
    ReadLn(c^.s);
    for i := 2 to 3 do
    {Данный цикл объединяет в себе одновременное создание 2 и 3-й ссылки,
     т.к они отличаются лишь знаком сравнения}
     begin 
      if ((c^.s > hs[i]^.s) and (i=2)) or ((c^.s < hs[i]^.s) and (i=3)) then
      {Проверяем, не надо ли заменить голову новым эл-том}
       begin
        c^.next[i] := hs[i];
        hs[i]:=c;
       end
      else {Иначе ищем ему место в уже созданном списке}
       begin
         n:=hs[i]; {Иниц. "бегунок"}

         while (n<>ts[i]) and
         (                                      {Пока не последний эл-т,}
          ((n^.next[i]^.s > c^.s) and (i=2)) or {и выполняется отсортированность}
          ((n^.next[i]^.s < c^.s) and (i=3))    {перемещаем "бегунок"}
         ) do n:=n^.next[i];

         c^.next[i] := n^.next[i]; {Вставляем наш эл-т между "бегунком"}
         n^.next[i] := c;          {и следующим за ним}

         if n = ts[i] then ts[i] := c; {При необходимости - смещаем хвост}
       end; {Конец добавления эл-та в сорт.список}
     end; {Конец цикла для 2-х сортировок}
  end; {Конец цикла чтения файла}
end;{CreateList}
{------------------------------}     
Procedure WriteList(var F:text;hs,ts:chains;order:integer);
{Процедура вывода списка, заданного hs и ts в файл F
 Order - номер списка, по которому бежать}
var
 c : Plist;   {Бегунок}
begin
 c:=hs[order]; {его инициализация}
 repeat
   WriteLn(c^.s);   
   c:=c^.next[order]; {продвижение по списку}
 until c = ts[order]; {Признак конца списка - вывод хвоста}
end;{WriteList}
{------------------------------}
{  ГОЛОВНОЙ МОДУЛЬ  }
var
 heads,tails : chains;   {Массивы голов и хвостов}
 ch          : integer;  {переменная выбора варианта вывода}
begin
  Assign(input,'4th.txt');
  {$I-}
    Reset(INPUT);
    if IOResult <> 0 then
     begin
       WriteLn('Error opening ''4th.txt''');
       Halt(255);
     end;
  {$I+}
  CreateList(INPUT,Heads,Tails); {Создание списка}
  Close(Input);
  Assign(Input,'con'); {Инициализация клавиатуры на место}
  Reset(Input);

  WriteLn('Список создан! Введите:');
  WriteLn('  1 - не отсортирован ');
  WriteLn('  2 - отсортирован по убыванию');       {Вывод приглашения}
  WriteLn('  3 - отсортирован по возростанию');
  ch:=0;
  repeat
    Write('Введите число от 1-го до 3-х: ');   {Запрос}
    Read(ch);
  until ch in [1..3];
  WriteLn('Вы выбрали ',msgs[ch]); {Сигнализация выбора}
  Assign(output,'4th.out');
  Rewrite(output);
  if IOResult <> 0 then
   begin
     WriteLn('Error opening ''4th.out'' for writing :( ');
     Halt(254);
   end;
  WriteLn('Оригинал:');
  WriteList(OUTPUT,heads,tails,1);  {Вывод сначала исходного списка}
  WriteLn('Результат:');
  WriteList(OUTPUT,heads,tails,ch); {Затем - выбранного пользователем}

  while Heads[1] <> nil do
  {Очистка всего списка, Heads[1] - бегунок, Tails[1] - временная переменная}
  begin
    Tails[1] := Heads[1]^.next[1];
    Dispose(heads[1]);
    Heads[1]:=tails[1];
  end;
end.