old/PAS/!SPbSTU/2nd/3.PAS

const
  InName  = '3.txt';
  OutName = '3.out';
type
  plist = ^tlist;
  tlist = record
    s:string;
    next,prev:plist;
  end;
{----------------------------}
Function InsertBefore(aW,aB : plist):boolean;
var
  BP,WN:plist;
begin
  if aW = aB then begin InsertBefore := false; exit; end;
  InsertBefore := true;
  bp := aB^.prev; WN:=aW^.next;

  if aW^.prev <> nil then aW^.Prev^.Next := WN;
  if WN <> NIL       then WN^.Prev := aW^.prev;

  aW^.Prev := BP;
  if BP <> nil then BP^.Next := aW;

  aB^.Prev := aW;
  aW^.Next := aB;
end;{InsertBefore}
{----------------------------}
Function FindMed(a1,a2 : plist):plist;
var
 count,i : word;
 ca      : plist;
begin
  if a1 = a2 then begin FindMed := a1;exit;end;
  ca := a1;
  count := 0;
  while (ca<>nil) and (ca<>a2) do
  begin
    inc(count);
    ca:=ca^.next;
  end;
  if ca = a2 then
   begin
     for i := 1 to count div 2 do ca:=ca^.prev;
     FindMed := ca;exit;
   end
  else
   begin
    ca := a1;
    count := 0;
    while (ca<>nil) and (ca<>a2) do
    begin
      inc(count);
      ca:=ca^.prev;
    end;
    if ca = a2 then
     begin
       for i := 1 to count div 2 do ca:=ca^.next;
       FindMed := ca;exit;
     end
    else FindMed:=a1;
   end;
end;{FindMed}
{----------------------------}
Function FindPlace(aB,aE,aV:plist):plist;
var
 med : plist;
begin
  if ord(aE^.s[0]) > ord(aV^.s[0]) then begin FindPlace:=aV;exit;end;
  while (aB^.Next <> aE) and (aB <> aE) do
  begin
    med := FindMed(aB,aE);
    if ord(med^.s[0]) > ord(aV^.s[0]) then aB:=med
    else aE := med;
  end;
  if ord(aB^.s[0]) < ord(aV^.s[0]) then FindPlace := aB else FindPlace := aE;
end;{FindPlace}
{----------------------------}
Procedure Sort(var aL : plist);
var
  i : plist;
begin
  i:=aL;
  while i^.next <> nil do
  begin
    if not InsertBefore(i^.next,Findplace(aL,i,i^.next)) then i:=i^.next;
    while aL^.Prev <> nil do aL:=aL^.prev;
  end;
end;{Sort}
{----------------------------}
var
  strings,cs,ls : plist;
  INP,OUTP      : text;
  ch            : char;
begin
  Assign(INP,InName);
  {$I-}
    Reset(INP);
    If IOResult <> 0 then
    begin
      WriteLn('Ошибка открытия файла ''',InName,''', код: ', IOResult);
      Halt(200);
    end;
  Assign(OUTP,OutName);
  Rewrite(OUTP);
    If IOResult <> 0 then
    begin
      WriteLn('Ошибка открытия файла для чтения ''',OutName,''', код: ', IOResult);
      Halt(201);
    end;
  {$I+}

  New(cs);
  cs^.prev:=nil;
  strings := cs;
  while not EOF(INP) do
  begin
    ch:=#0;
    cs^.s:='';
    while (ch <> '.') and Not EOF(INP) do
    begin
     Read(inp,ch);
     cs^.s := cs^.s + ch;
    end;
    New(cs^.next);
    ls:=cs;
    cs:=cs^.next;
    cs^.prev := ls;
  end;
  Dispose(cs);
  ls^.next:=nil;
  Close(INP);
  cs:=strings;
  while cs<>nil do
  begin
    Write(OUTP,cs^.s);
    cs:=cs^.next;
  end;
  WriteLn(OUTP,'Result:');
  Sort(strings);
  cs:=strings;
  while cs<>nil do
  begin
    Write(OUTP,cs^.s);
    cs:=cs^.next;
  end;
  Close(OUTP);
end.