Developing.ru

Код: Выделить всё

type pitem=^item;
     item=record
     data:integer;
     next :p item;
     end;
var head,p,p1,as :p item;
    n,k,kol,i,f:integer;
    flag:boolean;
    vybor:byte;
    cifr:integer;
procedure povtory(cif:integer);
var kol_pov:integer;
begin
p1:=head;
kol_pov:=0;
 while p1<>nil do
  begin
   if (p1^.data=cif) then
    begin
     kol_pov:=kol_pov+1;
    end;
    p1:=p1^.next;
  end;
if kol_pov>=3 then
begin
writeln('Element:',cif:3,' Vstrechaersia raz:',kol_pov:3);
end;
end;
begin
p1:=head;
repeat
povtory(p1^.data);
p1:=p1^.next;
until (p1=nil) or (keypressed);
readln;
end.

Код: Выделить всё

 
procedure add(x,ind:integer);
var j:integer;
begin
 if (ind>0) and (ind<=n+1) then
  begin
   new(p);
   p^.data:=x;
   if ind=1 then
    begin
     p^.next:=head;
     head:=p;
    end
    else
     begin
      p1:=head;
      for j:=2 to ind-1 do
      p1:=p1^.next;
      p^.next:=p1^.next;
      p1^.next:=p;
     end;
     n:=n+1;
     flag:=true;
     writeln('Element dobavlen.');
  end;
end;
 
procedure zapolnenie;
var el:integer;
begin
clrscr;
if flag=false then
 begin
  writeln('Vvedite kolichestvo elementov spiska: ');
  readln(kol);
  if kol>0 then
   begin
    for k:=1 to kol do
     begin
      write(k:3,' element -> ');
      readln(el);
      add(el,k);
     end;
     writeln;
     writeln('Spisok zapolnen.');
     readln;
   end;
 end
 else
  begin
   writeln('Spisok ne pust!');
   readln;
  end;
end;

Код: Выделить всё

 
procedure writelist;
begin
 p1:=head;
 writeln('Soderzhimoe spiska:');
 while p1<>nil do
  begin
   write(p1^.data,' ');
   p1:=p1^.next;
  end;
end;

Код: Выделить всё

type
  TData=integer;

  PItem=^TItem;
  TItem=record
    data:TData;
    next:PItem;
  end;

  TListIteratorProc=procedure(Itm:PItem;First,Last:boolean; var Cancel:boolean);

const
  TraceIsOn:boolean=false;

procedure printlog(S:string);
const n:longint=0;
begin
  inc(n); if TraceIsOn then writeln(n,':',S);
end;


procedure ForEach(Lst:Pitem; CallBackProc:TListIteratorProc);
var
  Cancel,First:boolean;
begin
  printlog('(ForEach) iterator started.');
  Cancel:=false; First:=true;
  while (Lst<>nil) and (not Cancel) do begin
    CallBackProc(Lst,First,Lst^.next=nil,Cancel);
    Lst:=Lst^.next;
    First:=false;
  end;
  printlog('(ForEach) iterator finished.');
end;

procedure WriteList(Lst:PItem);
begin
  printlog('(WriteList) started.');
  while Lst<>nil do begin
     write(Lst^.data,' ');
     Lst:=Lst^.next;
  end;
  writeln;
  printlog('(WriteList) finished.');
end;

procedure AddToBegin(var Lst:PItem; X:TData);
var
  nxt:PItem;
begin
  nxt:=Lst;
  new(Lst);
  with Lst^ do begin
    data:=X; next:=nxt;
  end;
  printlog('(AddToBegin) new item has been added to the head.');
end;

procedure AddToTail(var Lst:PItem; X:TData);
var
  prev:PItem;
begin
  if Lst=nil then begin
    printlog('(AddToTail) list is empty, new item will be added to the head.');
    AddToBegin(Lst,X);
  end else begin
    prev:=Lst;
    while prev^.next<>nil do prev:=prev^.next;
    new(prev^.next);
    with prev^.next^ do begin
      data:=X; next:=nil;
    end;
  end;
  printlog('(AddToTail) new item has been added to the tail.');
end;

function Count(Lst:PItem):longint;
var
  Cnt:longint;
begin
  Cnt:=0;
  while Lst<>nil do begin
    inc(Cnt);
    Lst:=Lst^.next;
  end;
  Count:=Cnt;
end;

function CountOf(Lst:PItem;X:TData):longint;
var
  Cnt:longint;
begin
  Cnt:=0;
  while Lst<>nil do begin
    if Lst^.data=X then inc(Cnt);
    Lst:=Lst^.next;
  end;
  CountOf:=Cnt;
end;

function ItemExists(Lst:PItem;X:TData):boolean;
var
  NotFound:boolean;
begin
  printlog('(ItemExists) started.');
  NotFound:=true;
  while NotFound and (Lst<>nil) do begin
    NotFound:=Lst^.data<>X;
    Lst:=Lst^.next;
  end;
  if NotFound then printlog('(ItemExists) item not found.') else printlog('(ItemExists) item found.');
  ItemExists:=not NotFound;
end;



procedure AddUnique(var Lst:Pitem; X:Tdata);
begin
  printlog('(AddUnique) searching for the item.');
  if ItemExists(Lst,X)
    then printlog('(AddUnique) item ignored, already present.')
    else begin
      printlog('(AddUnique) will be added to the head.');
      AddToBegin(Lst,X)
    end;
end;


function FillFromKeyboard:PItem;
var
  Lst:Pitem; Count:longint; S:string; V:TData; k:integer;
begin
  printlog('(FillFromKeyboard) started.');
  Lst:=nil;
  Count:=0;
  repeat
    write('Input an item or press Enter to cancel: '); readln(S);
    if S<>'' then begin
      val(S,V,k);
      if k=0
        then AddToTail(Lst,V)
        else Write('Wrong input. ')
    end;
  until S='';
  FillFromKeyboard:=Lst;
  printlog('(FillFromKeyboard) finished.')
end;



const
  L1:PItem=nil;
  L2:PItem=nil;
  L3:PItem=nil;


procedure CallBackWriteItem(Itm:PItem;First,Last:boolean; var Cancel:boolean); far;
begin
  if First then write('List contains ',Count(Itm),' item(s): ');
  write(Itm^.data);
  if Last then writeln('.') else write(', ');
end;
const CallBackWriteItemPtr:TListIteratorProc=CallBackWriteItem;

procedure CallBackWriteItemIfDuplicated(Itm:PItem;First,Last:boolean; var Cancel:boolean); far;
begin
  if First then write('Items repeated more then 3 times in L2: ');
  if CountOf(L2,Itm^.data)>=3 then begin
    write(Itm^.data);
    if Last then writeln('.') else write(', ');
  end;
end;
const CallBackWriteItemIfDuplicatedPtr:TListIteratorProc=CallBackWriteItemIfDuplicated;

procedure CallBackUniqueCopyL3(Itm:PItem;First,Last:boolean; var Cancel:boolean); far;
begin
  AddUnique(L3,Itm^.data);
end;
const CallBackUniqueCopyL3Ptr:TListIteratorProc=CallBackUniqueCopyL3;

begin
  TraceIsOn:=false;
  L2:=FillFromKeyboard;
  {вывод}
  WriteList(L2);
  {вывод через итератор}
  ForEach(L2,CallBackWriteItemPtr);

  TraceIsOn:=true;
  printlog('Creating unique list');
  ForEach(L2,CallBackUniqueCopyL3); {Строим L3}
  ForEach(L3,CallBackWriteItemPtr); {L3 - это L2 без повторов}

  TraceIsOn:=false;
  ForEach(L3,CallBackWriteItemIfDuplicated); {Выводим с проверкой}
end.

Код: Выделить всё

procedure AddAtPos(var Lst:PItem; X:TData; Pos:longint);
var
  prev,itm:PItem;
begin
  if (Lst=nil) or (Pos<=1) then begin
    printlog('(AddAtPos) list is empty or pos is 1, new item will be added to the head.');
    AddToBegin(Lst,X);
  end else begin
    prev:=Lst; dec(Pos);
    while (Pos>1) and (prev^.next<>nil) do begin
      prev:=prev^.next; dec(Pos);
    end;
    if Pos=1
      then printlog('(AddAtPos) reqested position was found.')
      else printlog('(AddAtPos) reqested position was not found, adding to tail.');
    new(itm);
    with itm^ do begin
      data:=X;
      next:=prev^.next;
    end;
    prev^.next:=itm;
    printlog('(AddAtPos) item has been added.')
  end;
end;