Напечатать по алфавиту определенные слова с дополнительной информацией о каждом из них

program sem2task1;
type
  list = ^chain;
  chain = record
    elem: string;
    next: list;
    end;
var
  fin,fout:text;
  j:integer;
  check:set of string;
  tempstring:string;
  spisok:list;
  tempchar:char;
procedure pasteintolist(var L:list; el:string);
var q,p:list;
begin
  if L=nil then begin
    new(L);
    L^.elem:=el;
    L^.next:=nil;
  end else
    if L^.next=nil then begin
      new(L^.next);
      L^.next^.elem:=el;
      L^.next^.next:=L;
    end else begin
      while not((el <= L^.next^.elem) and (el >= L^.elem)) do L:=L^.next;
      p:=L^.next;
      new(L^.next);
      L^.next^.elem:=el;
      L^.next^.next:=p;
    end;
end;
procedure searchandprint(L:list);
var i:integer; P,q:list; min:string;
begin
  min:=L^.elem;
  q:=L^.next;
  while L<>q do begin
    if q^.elem<min then begin min:=q^.elem; p:=q; end;
    q:=q^.next;
  end;
  check:=[min];
  L:=p;
  q:=L;
  p:=L^.next;
  i:=i+1;
  while p<>L do begin
    if p^.elem in check then i:=i+1 else begin
      if i>1 then write(fout,q^.elem,' ',i);
      i:=1;
      check:=check+[p^.elem];
    end;
  end;
end;
begin
  assign(fin,'input.txt');
  assign(fout,'output.txt');
  reset(fin);
  rewrite(fout);
  read(fin,tempchar);
  spisok:=nil;
  while tempchar<>'.' do begin
    while (tempchar<>',')and(tempchar<>'.') do begin
      tempstring:=tempstring+tempchar;
      read(fin,tempchar);
    end;
    read(fin,tempchar);
    pasteintolist(spisok,tempstring);
    tempstring:='';
  end;
  searchandprint(spisok);
end.