
Дана последовательность слов, слова разделяются пробелом.
Нужно вывести на экран все согласные буквы которые входят только в одно слово.
uses crt;
type
main=array[1..40] of string[50];
procedure take_array(s:string; var mas:main; var n:integer);
var i:byte;
begin
n:=1;
for i:=1 to length(s) do
if (s[i]=' ') and (i<>length(s)) then
inc(n)
else
mas[n]:=mas[n]+s[i];
end;
function dif_letters(s:string):string;
var i,j:byte; buf:string;
begin
buf:='';
for i:=1 to length(s) do
if pos(s[i],buf)=0 then
buf:=buf+s[i];
dif_letters:=buf;
end;
procedure consonant(mas:main; n:integer);
const
con='zxcvbnmlkhgfdsqwrtp';
var i,j,temp:integer;
buf:string;
num:array[1..20] of integer;
begin
for i:=1 to 20 do
num[i]:=0;
for i:=1 to n do
begin
buf:=dif_letters(mas[i]);
for j:=1 to length(buf) do
begin
temp:=pos(buf[j],con);
if temp<>0 then
inc(num[temp]);
end;
end;
for i:=1 to 20 do
if num[i]=1 then
write(con[i],' ');
readln;
end;
var s:string;
mas:main;
n:integer;
begin
clrscr;
writeln('Enter string');
readln(s);
take_array(s,mas,n);
consonant(mas,n);
end.
const
c:string='bcdfghklmnpqrstvwxz';
z:set of char=[];
var
s:string;
A,B,T:set of char;
i,j:integer;
begin
Write('Type in a line: '); ReadLn(s);
A:=Z;
for i:=1 to Length© do begin
T:=Z;
for j:=1 to Length(s) do if c[i]=s[j] then
if c[i] in A then Include(B,c[i]) else Include(T,c[i])
else if s[j]=' ' then begin
A:=A+T;
T:=Z;
end;
A:=A+T
end;
A:=A-B;
for i:=1 to Length© do if c[i] in A then Write(c[i],' ')
end.
for j:=1 to Length(s) do if c[i]=s[j] then
if c[i] in A then {надо поменять A на T}
Include(B,c[i]) else Include(T,c[i])
else if s[j]=' ' then begin
uses crt;
const
sogl = 'wrtpssdfghjklzxcvbnm';
var
s : string = 'cxx xyfc xcavv';
c : set of char = [];
i, j, start : integer;
begin
i := 1;
while (i <= length(s)) do begin
while (s[i] = ' ') do inc(i);
if i <= length(s) then begin
start := i;
while (s[i] <> ' ') and (i <= length(s)) do inc(i);
for j := start to i do
if (pos(s[j], sogl) <> 0) then begin
if not(s[j] in c) and (pos(s[j], copy(s, 1, pred(start))) = 0)
and (pos(s[j], copy(s, succ(i), 255)) = 0) then
writeln(s[j]);
include(c, s[j]);
end;
end;
end;
end.
const
sogl: set of char = ['b','c','d','f','g','h','j','k','l','m','n','p','q','r','s','t','v','w','x','z'];
var
S:String;
len,p :integer;
res, slo, vto: set of char;
ch: char;
begin
writeln('Введите строку ');
readln(S);
len:=Length(S);
p:=1; {начнем с первого символа}
res:=[]; {один раз}
vto:=[]; {неск слов}
{пропустить пробелы в начале строки}
while (p<=len) and (S[p]=' ') do p:=p+1;
{выделяем слова пока не конец строки}
while (p<=len) do
begin
{смотрим слово до пробела или конца строки}
slo:=[];
while (p<=len) and (S[p]<>' ') do
begin
slo:=sogl*[S[p]] + slo; {складываем согласные}
p:=p+1; {к следующему символу}
end;
vto:=slo*res + vto; {встречалась - запоминаем}
res :=res + slo - vto; {те, что не встречались еще - добавляем} {встречалась - убираем}
{пропускаем пробелы, не выходя за пределы строки}
while (p<=len) and (S[p]=' ') do p:=p+1;
end;
{вывод}
if res=[] then writeln('нет таких')
else
for ch:='b' to 'z' do
if ch in res then write(ch,' ');
readln;
end.