Developing.ru

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

type
  TItemData = string;

  CBListCallbackFunction = function(W:TItemData):boolean;

  PItem = ^TItem;
  TItem = record
    Data : TItemData;
    Next : PItem;
  end;


function IsShortWord(W:TItemData):boolean; far;
const
  vowels:set of char = ['а','е','ё','и','о','у','ы','э','ю','я',
                        'А','Е','Ё','И','О','У','Ы','Э','Ю','Я'];
var
  n,i:integer;
begin
  i:=1; n:=0;
  while (n<=1) and (i<=length(W)) do begin
    if W[i] in vowels then inc(n);
    inc(i);
  end;
  IsShortWord:= n=1;
end;

function WriteItem(W:TItemData):boolean; far;
begin
  write(W,' '); WriteItem:=true;
end;

procedure InsertAtHead(X:TItemData;var List:PItem);
var
  Item:PItem;
begin
  New(Item);
  Item^.Data:=X;
  Item^.Next:=List;
  List:=Item;
end;

function DeleteUsingCallback(var List:PItem; CBFunc:CBListCallbackFunction):boolean;
var
  Item,CurItem:PItem;
  R:boolean;
begin
  R:=false;
  while (List<>nil) and CBFunc(List^.Data) do begin
    Item:=List;
    List:=List^.Next;
    Dispose(Item);
    R:=true;
  end;
  CurItem:=List;
  if CurItem<>nil then while (CurItem^.Next<>nil) do begin
    if CBFunc(CurItem^.Next^.Data) then begin
      Item:=CurItem^.Next;
      CurItem^.Next:=CurItem^.Next^.Next;
      Dispose(Item);
      R:=true;
    end else begin
      CurItem:=CurItem^.Next;
    end;
  end;
  DeleteUsingCallback:=R;
end;

procedure ForEach(List:PItem; CBFunc:CBListCallbackFunction);
begin
  while List<>nil do begin
    CBFunc(List^.Data);
    List:=List^.Next;
  end;
end;

var
  s:string;
  Lst:PItem;
begin
  Lst:=nil;
  writeln('Вводите слова. В конце последнего слова поставьте точку');
  repeat
    readln(S);
    InsertAtHead(S,Lst);
  until S[length(S)]='.';

  writeln('Исходный список:');
  ForEach(Lst,WriteItem);
  writeln;

  if DeleteUsingCallback(Lst,IsShortWord) then begin
    writeln('Односложные слова удалены');
    ForEach(Lst,WriteItem);
    writeln;
  end else begin
    writeln('Односложных слов не найдено');
  end;

end.