Program P7; Uses Crt;
          type List=^Celula;
                 Celula=record
                 Info:String;
                 Prec, Urm:Lista;
              end;
 var P,V:List; 
      N,m,k:byte;
  procedure Create;
         var R:List; i:byte;
            begin          
            writeln('List: ');
            P:=nil; 
            V:=nil;
                 for i:=1 to N do
                     begin
                        new®;
                        readln(R^.info);
                        R^.Prec:=nil;
                        R^.Urm:=nil;
                      if P=nil then begin
                      P:=R; 
                      V:=R; end  //If
                      else begin
                      V^.Urm:=R; 
                      R^.Prec:=V; 
                      V:=R; 
                 end //Else 
             end; //For    
     R^.Urm:=P;  //тут я не уверен если правильно сделал что-бы список был циклинчным
     P^.Prec:=V;
     P:=V;
   end; //Create
   procedure Destroy(R:List);
        begin
             if (P^.Urm=P) and (R=P) then  //процедуру взял с форума
             begin
             writeln('Leave: ',P^.Info);
             dispose(P);
             P:=nil;
             exit;
           end;
           writeln('Leave ',R^.info);
           R^.Prec^.Urm:=R^.Urm;
           R^.Urm^.Prec:=R^.Prec;
           if R=P then P:=P^.Urm;
           dispose®; R:=nil;  //пишет invalid pointer operation 
          end;
 procedure Start;
      var i:integer;  R:list;
        begin
         i:=0;
         R:=P;
         while R<>nil do  begin
             i:=i+1;
             R:=R^.Urm;
             if i=m then break;   //Находим m-ый элемент
          end;
            i:=k;  
            while R<>nil do 
            if i=k then begin 
                  Destroy®; 
                  i:=0; end
                    else 
                begin 
                   i:=i+1; R^.R.Urm;    
                end;
Begin
write('Player Number: '); readln(N);
write('Position '); readln(m);
write('Ration '); readln(k);
Create;
Start;
readln;
end.

Program P7;
Uses Crt;
type
   List = ^Celula;
   Celula =
   record
      Info : String;
      prev, next : List;
   end;

var
   N, m, k : byte;

procedure Create (var root : List);
var
   s : string;
   q, adding : List;
begin
   {
      В любом случае надо выделять память и получать данные,
      так что сделаем это один раз, вместо дублирования кода
   }
   write ('info = '); readln (s);

   new (adding);
   adding^.info := s;

   if root = nil then { Добавляем самый первый элемент в "кольцо" }
   begin
      {
         Тут все просто: он ссылается обоими связями сам на себя. Ну, и установим
         Root, чтоб знать, где у кольца символическое "начало"
      }
      adding^.prev := adding;
      adding^.next := adding;
      root := adding;
   end
   else { Нет, уже не первое значение. В "кольце" уже были элементы }
   begin
      {
         В таком случае поступаем следующим образом: добавляем элемент перед
         "началом": то есть, так, чтобы новый элемент полем next указывал на Root...
         Не надо спрашивать почему, подумай сам, если ты будешь печатать список,
         я не уверен, что постоянно меняющееся "начало" тебе понравится. А так
         добавляться элементы будут в "конец".
      }

      q := root^.prev; { Вот Q и есть тот элемент, ПОСЛЕ которого надо добавить новый }

      {
         Добавляем. Чтобы понять, что происходит - чертишь на листе бумаги два элемента, 
         и устанавливаешь между ними связи, как делает нижеприведенный код. А потом
         точно там же, на бумаге, делаешь добавление еще одного элемента, и смотришь,
         как он становится на нужное место, перед Root-ом
      }
      adding^.next := q^.next;
      adding^.prev := q;
      adding^.next^.prev := adding;
      q^.next := adding;
   end;
end;

{ Это - для отладки, и чтоб убедиться, что Create работает правильно }
procedure ShowList (root : List);
var q : list;
begin
   if root <> nil then
   begin
      q := root;
      repeat
         writeln (q^.info);
         q := q^.next;
      until (q = root)
   end
   else
      writeln('Empty ring');
end;

{
   Это еще одна проблема, которая у тебя была. Удаление элемента, на который указывает node.
   Хочешь спросить, зачем сюда передается еще и Root? Очень просто: я не стал описывать
   переменную для обозначения "начала" в самом верху, чтобы снизить вероятность появления
   побочных эффектов. А при удалении жлемента надо быть внимательным, ведь может удаляться
   и сам Root, тогда надо сделать кое-что, чтоб программа продолжала работать правильно.
}
procedure Delete (var root, node : List);
var T : List;
begin
   writeln ('Leaving : ', node^.info);
   if node^.next = node then { Итак, вариант №1 - удаляем единственный оставшийся элемент }
   begin
      {
         Тут как раз проще всего: раз он последний - то после его удаления
         Root должен сброситься в nil, что будет сигнализировать о пустом "кольце"
      }
      root := nil;
      dispose (node);
   end
   else { Случай второй: после удаления в кольце еще останутся элементы }
   begin
      {
         Для начала - проверим, не наступил ли тот особый случай, о котором я говорил выше:
         не удаляем ли мы Root. Если да, то надо Root-ом назначить какой-то другой элемент.
         Я выбрал следующий, т.е., тот, на который указывает Root^.next
      }
      if node = root then
      begin
         root := root^.next;
      end;

      {
         Теперь просто удаляем элемент node. Заметь, что перед удалением делается
         node := node^.next. Это не просто так. После того, как очередной игрок вышел
         из круга, отсчет начинается со следующего. Вот поэтому и next... Если б надо
         было считать с предыдущего - можно было бы сделать node := node^.prev
      }
      node^.prev^.next := node^.next;
      node^.next^.prev := node^.prev;
      T := node;
      node := node^.next;
      dispose (T);
   end;
end;

{ Собственно, сама рабочая процедура }
procedure Start (root : List);
var i:integer;  R:list;
begin
   { Root не портим, работаем с доп. переменной. Сначала переходим
      к M-му стоящему в круге. Для этого пропускаем M-1 человек }
   R := Root;
   for i := 1 to m - 1 do
      R := R^.next;

  { А теперь, пока круг не опустеет - удаляем из него каждого K-го }
   while Root <> nil do
   begin

      for i := 1 to k do begin
         R := R^.next;
      end;
      Delete (Root, R);
   end;
end;

var
   i : integer;
   root : List;

Begin
   write('Player Number: '); readln(N);
   write('Position '); readln(m);
   write('Ration '); readln(k);
   for i := 1 to n do
   begin
      Create (Root);
   end;
   ShowList (Root);

   Start (Root);
   readln;
end.