Procedure Poisk(p, s: string);
var i: integer;
w: string;
begin
{v procedure v peremennuyu P peredaetsya stroka poiska, v nei do
pervogo probela mi ishem konec pervogo slova, sohranyaem ego v
peremennuyu W, udalyaem eto slovo iz P. Proveryaem na nalichie
slova v stroke spiska. I tak delaem, poka dlina stroki P ne bud
et ravna 0}

{parametr S: nuzhen dlay togo chtobi posle preobrazovaniya strok
v verhnii registr (UpCase) vivesti Stroku iz spiska v pervonach
al'nom vide (smain)}

for i := 1 to length(s) do
s[i] := UpCase(s[i]);

for i := 1 to length(p) do
p[i] := UpCase(p[i]);

while length(p) <> 0 do
for i := 1 to length(p) do
begin
if (p[i] = ' ') then
begin
w := copy(p, 1, i - 1);
delete(p, 1, i);
if pos(w, s) <> 0 then
begin
writeln(smain);
exit;
end;
end;
if i = length(p) then
begin
w := copy(p, 1, i);
delete(p, 1, i);
if pos(w, s) <> 0 then
begin
writeln(smain);
exit;
end;
end;
end;
end;

begin
clrscr;
writeln('Vvedite cto hotite naiti:');
readln(pmain);
writeln(#10#13, 'Resultati poiska:');

assign(t, 'spisok.txt');
reset(t);

{cikl: chitaem stroku iz faila spiska i zapuskaem proceduru Poisk,
kotoraya proveryaet nalichie klyuchevogo slova v stroke, esli nah
odit, to vivodit na ekran i procedura prekrashaet svoe vipolnenie}
while not Eof(t) do
begin
readln(t, smain);
Poisk(pmain, smain);
end;
{oformlenie proceduri nuzno chtobi ne vivodit' povtoryayushiesya
stroki iz spiska. Naprimer, esli b v klyuchevih slovah bilo dva
slova, soderzhashihsya v stroke spiska, to eta stroka vivelas' b
i dva raza. Ne nuzhnii vivod blokiruet v procedure Exit}

close(t);

readkey;
end.

Источник: