program test;

//{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes, Unit1
  { you can add units after this };

 var
  elem,i,selem:BaseType;
  Rroot:Ptr;
  ch:char;

{$IFDEF WINDOWS}{$R test.rc}{$ENDIF}

begin
 repeat
   writeln('1) Sozdat'' pustoi spisok');
   writeln('2) Dobavit'' element');
   writeln('3) Poisk elementa');
   writeln('4) Vyvesti spisok');
   writeln('5) Udalenie elementa');
   writeln('0) Vyhod');
   readln(ch);
   if ch='0' then exit else begin
   case ch of
    '1': begin
          Rroot:=NewList;
          writeln('Spisok sozdan');
         end;

    '2': begin
          writeln('vVEDITE ELEMENT KOTORYI NUJNO DOBAVIT''');
          readln(elem);
          if AddElem(elem, Rroot) then writeln('Element dobavlen')
            else writeln('Element uje est''');
         end;

    '3': begin
          writeln('Vvedite element dlya poiska');
          readln(elem);
          if search(elem,Rroot) then writeln('Takoi element est'' v spiske')
            else writeln('Takogo elementa net v spiske');
         end;
    '4': begin
          writeln('Znachenie      Klyuch');
          PrintList(Rroot);
         end;
    '5': begin
          writeln('Vvedite element kotoryi nujno udalit''');
          readln(elem);
          DelElem(elem, Rroot);
         end;
    end; end;
 until ch = '0';
  readln;
end.





unit Unit1; 

{$mode objfpc}{$H+}


interface
 type
 BaseType = integer;
 Ptr = ^PPtr;
  PPtr = record
    key:BaseType;
    count: integer;
    next :Ptr
   end;

 function  Search(x:BaseType; var roots:Ptr):Boolean;
 function  NewList:Ptr;
 function  AddElem(x:BaseType; var root:Ptr):Boolean;
 procedure PrintList(List:Ptr);
 function  CheckNil(List:Ptr):Boolean;
 procedure DelElem(x:BaseType; var root:Ptr);
implementation

 function NewList:Ptr;
  begin
   result:=nil;
  end;

 function CheckNil(List:Ptr):Boolean;
  begin
    result:=List=nil;
  end;

 function AddElem(x:BaseType; var root:Ptr):Boolean;
  var
    tmp,q,frs:Ptr;
  begin
   result:=CheckNil(root);
   if result then
     begin
       New(root);
       q:=root;
     end
    else
     begin
      tmp:=root;
      while (tmp <> nil) and (tmp^.key <> x) do tmp:=tmp^.next;
      if tmp = nil then begin
       tmp:=root;
       while (tmp^.next = nil) do tmp:=tmp^.next;
       New(tmp^.next);
       q:=tmp^.next;
      end
       else begin
         result:=False;
         exit;
       end;
     end;
    q^.key:=x;
    q^.count:=0;
    q^.next:=nil;
    result:=True;
 end;

 function  Search(x:BaseType; var roots:Ptr):Boolean;
    var
      w,w1,w2:Ptr;
   begin
    w:=roots;
    w1:=roots;
    if w = nil then begin
       writeln('Net elementov v spiske');
       result:=False;
      end
    else begin
    if roots^.key = x then begin
     result:=false;
      roots^.count:=roots^.count+1;
     end
    else begin
     w1:=nil;
      while (w<>nil) and (w^.key <> x) do begin
        w2:=w;
        w:=w2^.next;
       if (w <> nil) then
        if w^.count < w2^.count then w1:=w2;
      end;
      if w = nil then
      result:=True
      else if w1 = nil then begin
       result:=False;
       w^.count:=w^.count+1;
       w2^.next:=w^.next;
       w^.next:=roots;
       roots:=w;
      end
       else begin
        result:=False;
        w^.count:=w^.count+1;
        w2^.next:=w^.next;
        w^.next:=w1^.next;
        w1^.next:=w;
       end
    end;
    end;
   end;

 procedure PrintList(List:Ptr);
  begin
    while (List <> nil) do
     begin
      write(List^.key,'                    ');
      write(List^.count,'  ');
      writeln;
      List:=List^.next;
     end;
  end;

 procedure DelElem(x:BaseType; var root:Ptr);
  var w,w1:Ptr;
   begin
    w:=root;
    while (w <> nil) and (w^.key <> x) do begin
      w1:=w;
      w:=w1^.next;
      end;
     if w = nil then writeln('Nechego udalyat''')
       else begin
        if w = root then begin
          root:=root^.next;
          dispose(w);
        end
        else begin
        w1^.next:=w^.next;
        dispose(w);
        writeln('Element udalen');
        end;
       end;
   end;
end.