найти общее слово

[denis_stell]

Доброй ночи!Помогите пожалуйста вот с такой задачей:
Даны 2 предложения(вводятся с клавиатуры через пробел),найти для них самое длинное общее слово.

например
1-ое предложение- университет расположен возле дома
2-ое предложение- университет был в другом городе
должно вывести университет

как то так наверно ищется самое длинное в тексте
а как сделать чтобы искало в предложениях и находило общее я не знаю,очень нужно помогите пожалуйста!!!
Uses
Crt;
Var
St, pretender, longword: String;
i: Byte;
begin
ClrScr;
Write('введите предложение: ');
Readln(St);
St := St + ' ';
longword := '';
for i:=1 to Length(St) do begin
if St[i] <> ' ' then begin
pretender := pretender + St[i];
Continue;
end;
if St[i] = ' ' then begin
if Length(longword) < Length(pretender) then begin
longword := pretender;
end;
pretender := '';
end;
end;
Write('Found long word: ', longword);
readkey;
end.

[ROMA2PVT]

var
  a,b:string;
  e,f:string;
begin
  write('Введите первое предложение: ');
  readln(a);
  write('Введите второе предложение: ');
  readln(b);
  a:=a + ' ';
  b:=b + ' ';
  while pos('  ',a)>0 do
    delete(a,pos('  ',a),1);
  while pos('  ',b)>0 do
    delete(a,pos('  ',b),1);
  begin
      e:='';
      repeat
        f:=copy(a,1,pos(' ',a));
        if (pos(f,b)>0)and(length(f)>length(e)) then e:=f;
        delete(a,1,pos(' ',a))
      until length(a)=0;
    end;
  writeln('Самое длинное общее слово => : ',e);
  readln;
  end.

Ну вот как то так.

[denis_stell]

Сообщение от ROMA2PVT

var
  a,b:string;
  e,f:string;
begin
  write('Введите первое предложение: ');
  readln(a);
  write('Введите второе предложение: ');
  readln(b);
  a:=a + ' ';
  b:=b + ' ';
  while pos('  ',a)>0 do
    delete(a,pos('  ',a),1);
  while pos('  ',b)>0 do
    delete(a,pos('  ',b),1);
  begin
      e:='';
      repeat
        f:=copy(a,1,pos(' ',a));
        if (pos(f,b)>0)and(length(f)>length(e)) then e:=f;
        delete(a,1,pos(' ',a))
      until length(a)=0;
    end;
  writeln('Самое длинное общее слово => : ',e);
  readln;
  end.

Ну вот как то так.

спасибо!
а подскажите пожалуйста,вот если ввести в первую строку- университет
а во вторую ауниверситет,то выдает что общее слово университет,как сделать чтобы убрать эту ошибку?

[ROMA2PVT]

uses crt;
type k = array [1..100] of string[40];
var
p1,p2 : k;
i,j: integer;
n,m:byte;
a,b,w : string;
procedure Words(s:string; var mas:k; var c:byte);
var
i: byte;
s1 : string;
j: byte;
begin
s := s+' ';
j:=0;
for i := 1 to length(s) do
begin
if s[ i]=' ' then
begin inc(j);
mas[j ]:=s1;
s1:='';
end
else s1:=s1+s[i ];
end;
c := j;
end;
begin
ClrScr;
write('Введите первое предложение: ');
Readln(a);
words(a,p1,n);
write('Введите второе предложение: ');
Readln(b);
words(b,p2,m);
begin
w:='';
for i := 1 to n do
for j := 1 to m do
If (p1[ i] = p2[ j])
then
begin
w := p1[ i];
if (length(p1[ i])>length(w)) then w := p1[ i];
end;
Writeln('Самое длинное общее слово =>: ',w);
readln;
end;
end.

Вроди правильно щас.

[denis_stell]

Сообщение от ROMA2PVT

uses crt;
type k = array [1..100] of string[40];
var
p1,p2 : k;
i,j: integer;
n,m:byte;
a,b,w : string;
procedure Words(s:string; var mas:k; var c:byte);
var
i: byte;
s1 : string;
j: byte;
begin
s := s+' ';
j:=0;
for i := 1 to length(s) do
begin
if s[ i]=' ' then
begin inc(j);
mas[j ]:=s1;
s1:='';
end
else s1:=s1+s[i ];
end;
c := j;
end;
begin
ClrScr;
write('Введите первое предложение: ');
Readln(a);
words(a,p1,n);
write('Введите второе предложение: ');
Readln(b);
words(b,p2,m);
begin
w:='';
for i := 1 to n do
for j := 1 to m do
If (p1[ i] = p2[ j])
then
begin
w := p1[ i];
if (length(p1[ i])>length(w)) then w := p1[ i];
end;
Writeln('Самое длинное общее слово =>: ',w);
readln;
end;
end.

Вроди правильно щас.

Большое вам спасибо!Я дико извиняюсь,помогите,вот если ввожу
1: универ возле дома
2: универ возле трассы
программа мне выдает,что самое длиное слово -возле,хотя должно быть -универ
Я ещё раз извиняюсь ,что отнимаю ваше драгоценное время!!!!

[Филантроп]

вариант 1

Uses
	Crt;
Const
	MaxIndex = 100;
	TestSt1: String = 'Argenti na manit negra';
	TestSt2: String = 'A roza upala na lapu Azora';
Type
	TAr = Array[1..MaxIndex] of String;
Var
	StAr1, StAr2: TAr;
	result, St1, St2: String;

procedure clear(var Ar: TAr);
var
	i: Byte;
begin
	for i:=1 to MaxIndex do
		Ar[i]:='';
end;
	
procedure split(st: String; var Ar: TAr);
var
	i, start, finish: Byte;
	tmpst: String;
begin
	tmpst := st + ' ';
	start := 1;
	finish := 1;
	i := 1;
	While (finish <= Length(tmpst)) do begin
		if tmpst[finish] = ' ' then begin
			Ar[i] := Copy(tmpst, start, finish-start);
			Inc(i);
			start := finish + 1;
			finish := start;
		end else begin
			Inc(finish);
		end;
	end;
end;

procedure sort(var Ar: TAr);
var
	tmp: String;
	i, j, maxi: Byte;
begin
	maxi := 1;
	While Ar[maxi] <> '' do begin
		Inc(maxi);
	end;
	for i := 1 to maxi - 1 do begin
		for j := i + 1 to maxi do begin
			if Length(Ar[i]) < Length(Ar[j]) then begin
				tmp := Ar[i];
				Ar[i] := Ar[j];
				Ar[j] := tmp;
				Continue;
			end;
			if (Length(Ar[i]) = Length(Ar[j])) and (Ar[i] < Ar[j]) then begin
				tmp := Ar[i];
				Ar[i] := Ar[j];
				Ar[j] := tmp;
			end;
		end;
	end;
end;

function find(var Ar1, Ar2: TAr): String;
var
	i1, i2: Byte;
begin
	i1 := 1;
	i2 := 1;
	find := '';
	repeat
		if (Length(Ar1[i1]) > Length(Ar2[i2])) or 
			((Length(Ar1[i1]) = Length(Ar2[i2])) and (Ar1[i1] > Ar2[i2])) then begin
			Inc(i1);
			Continue;
		end;
		if (Length(Ar1[i1]) < Length(Ar2[i2])) or
			((Length(Ar1[i1]) = Length(Ar2[i2])) and (Ar1[i1] < Ar2[i2]))then begin
			Inc(i2);
			Continue;
		end;
		if Ar1[i1] = Ar2[i2] then begin
			find := Ar1[i1];
			Break;
		end;
	until (Ar1[i1] = '') or (Ar2[i2] = '');
end;
	
begin
	ClrScr;
	Write('1-st: '); readln(St1);
	Write('2-nd: '); readln(St2);

	clear(StAr1);
	clear(StAr2);
	split(St1, StAr1);
	split(St2, StAr2);
	sort(StAr1);
	sort(StAr2);
	result := find(StAr1, StAr2);
	if result = '' then
		Writeln('Equals words not found.')
	else
		Writeln('Found: ' + result);
	Writeln;
	Write('Done. Press any key...');
	readkey;
end.

вариант 2

var
  a,b:string;
  {функция занимающаяся поиском максимального слова}
  function CheckString(c,d:string):string;
    var
      e,f:string;
    begin
      e:='';{пока пустая строка есть максимальное слово}
      repeat
        f:=copy(c,1,pos(' ',c));{копиреум проверяемое слово}
        if (pos(f,d)>0)and(length(f)>length(e)) then e:=f;{новое максимальное слово}
        delete(c,1,pos(' ',c)){удаляем проверенное слово}
      until length(c)=0;{продолжаем пока не переберм всю строку}
      CheckString:=e;
    end;
begin
  {вводим строку А}
  write('Enter string:');
  readln(a);
  {вводим строку В}
  write('Enter string:');
  readln(b);
  {в конец строки дописываем пробелы}
  a:=a + ' ';
  b:=b + ' ';
  {удаляем двойные пробелы}
  while pos('  ',a)>0 do
    delete(a,pos('  ',a),1);
  while pos('  ',b)>0 do
    delete(a,pos('  ',b),1);
  {вывод результата}
  writeln('Result: ',CheckString(a,b));
{контрольная проверка - поиск наоборот  writeln(CheckString(b,a));}
  readln;
  end.

[ROMA2PVT]

Гдето я уже это видел.

[Филантроп]

http://rfpro.ru/ - вот тут!

[ROMA2PVT]

Uses
Crt;
Const
MaxIndex = 100;
TestSt1: String = 'Argenti na manit negra';
TestSt2: String = 'A roza upala na lapu Azora';

Возможно.Очень запомнился этот фрагмент в памяти. Второй вариант с косяком.

[Филантроп]

Второй вариант с косяком.

самое простое - не всегда самое правильное