Сложная задача по Pascal

← →
michael_b (2002-12-20 20:08) [0]

Подскажите принцып решения.

Дана матрица сиволов N*N. Пользователь вводит слово и координату первой буквы. Прога дожна сказать угадал ли пользователь слово.
Примечание: Слова могут быть состывлены не только повертикали и горизонтали(см. пример)

Например:
х к о х
х х р о
х х а в
Коорд первой буквы (1;2) слово корова
Ответ: Вы угадали!

← →
michael_b (2002-12-20 21:29) [1]

Что super трудная задача?!! Помогите пожалуйста завтра сдавать.

← →
AM (2002-12-20 21:43) [2]

Задача не сложная, просто алгоритм нудный. Он похож на обработку изображения. После задания пользователем координаты (i,j) начинаешь проверять (является ли он "К") сначало сам символ
a[i,j].
Потом вокруг все 4 позиций:
a[i-1, j]
a[i+1, j]
a[i, j-1]
a[i, j+1]
на возможные совпадения со значением "О"
Если некоторые позиции совпали то, запоминаешь эти позиции и поочереди тем же способом продвигаешся дальше.

При этом надо проверять чтобы i и j не выходили за заданные границы 0<=i<=n, 0<=j<=m.

← →
dmk (2002-12-20 22:36) [3]

//Алгоритм не доработан до конца
//Нету проверки на границы массива
//Попробуй доработать сам

var MyArray: array[0..100, 0..100] of char;
SomeInterestingStr:string = "Korova";

Function YouAreRight(StartX, StartY: DWord):boolean;
var x,y: Integer;
c: char;

SourceStr, DestStr: string;
Index: Integer;

//...
Function SearchForNextLetter: boolean;
var NextCharToCompare: char;
aX, aY: DWord;
mX_Vector, mY_Vector: Integer;
SearchX, SearchY: Integer;
NeedChar:char;

begin
Result := false;
NextCharToCompare := SourceStr[index] ;

mY_Vector := -1;
mX_Vector := -1;

//...
For aY := 0 to 2 do
begin
SearchY := y + mY_Vector;

//...
For aX := 0 to 2 do
begin
SearchX := x + mX_Vector;
NeedChar := MyArray[SearchX,SearchY];

If NeedChar = NextCharToCompare then
begin
x := SearchX;
y := SearchY;
//Letter is found and x & y next start position for search
DestStr := DestStr + NeedChar;
MyArray[SearchX, SearchY] := #9; //Clear founded char
end else break;

//...
mX_Vector := mX_Vector + 1;

end;//aX

//...
mY_Vector := mY_Vector + 1;
end;//aY

end;

// YouAreRight main body
begin
Result := false;
x := StartX;
y := StartY;

SourceStr := SomeInterestingStr; //May be global var
DestStr := "";
Index := 0;

c := MyArray[x,y];//Get first letter
If c <> SourceStr[Index] then exit; //First letter not right, exiting

//...
While (SourceStr <> DestStr) or (Index < Length(SourceStr)) do
begin
Inc(Index);
If not SearchForNextLetter then break;
end;

//...
If DestStr = SourceStr then YouAreRight := true;
end;//YouAreRight

← →
dmk (2002-12-20 22:38) [4]

Писал без проверок и наспех ...

← →
Sha (2002-12-21 00:43) [5]

2 dmk © (20.12.02 22:38)

> Писал без проверок и наспех ...

Можно и не проверять, и так все ясно :)
По-моему в теле функции YouAreRight циклов маловато будет...

Интересная задачка. Попробую решить завтра.

← →
dmk (2002-12-21 00:50) [6]

2 Sha © (21.12.02 00:43)
Согласен насчет циклов.
Мне просто было интересно. Помог чем мог.

Да и ведь не мне завтра сдавать? А? :D

Надеюсь автор ветки сможет подправить начатое.

← →
Sha (2002-12-21 11:31) [7]

2 dmk © (21.12.02 00:50)

Мне тоже стало интересно... Вот мое решение: function FindWord(Matrix: TStringList; const WordToFind: string; aPoint: TPoint): boolean; var MaxX, MaxY, MaxLen, CurLen: integer; Used: PChar; function Test(aPoint: TPoint; Direction: integer): boolean; var p: TPoint; u, d: integer; begin; Result:=false; p:=aPoint; case Direction of 1: inc(p.X); 2: inc(p.Y); 3: dec(p.X); 4: dec(p.Y); end; u:=p.Y * MaxX + p.X - 1; if (p.X<1) or (p.X>MaxX) or (p.Y<0) or (p.Y>MaxY) or ((Used+u)^<>#0) or (Matrix[p.Y][p.X]<>WordToFind[CurLen]) then exit; (Used+u)^:=#1; inc(CurLen); if CurLen>MaxLen then Result:=true else for d:=1 to 4 do begin; Result:=Test(p,d); if Result then break; end; dec(CurLen); (Used+u)^:=#0; end; begin; Result:=false; MaxY:=Matrix.Count-1; if MaxY<0 then exit; MaxX:=Length(Matrix[1]); if MaxX<=0 then exit; MaxLen:=Length(WordToFind); if MaxLen<=0 then exit; GetMem(Used,(MaxY+1)*MaxX); FillChar(Used^,(MaxY+1)*MaxX,#0); CurLen:=1; Result:=Test(aPoint,0); FreeMem(Used); end; procedure TForm1.Button7Click(Sender: TObject); const Answer: array[boolean] of string= ("Not found","Found"); var Matrix: TStringList; begin; Matrix:=TStringList.Create; Matrix.Add("тлон"); Matrix.Add("рока"); Matrix.Add("оров"); Matrix.Add("львы"); ShowMessage(Answer[FindWord(Matrix,"корова",Point(3,2-1))]); Matrix.Free; end;

Здесь без рекурсии, явной или скрытой, не обойтись.
Это становится ясно, если взглянуть на мою тестовую матрицу.
Данная задача учебная, поэтому не стал оптимизировать решение по времени выполнения.

← →
michael_b (2002-12-21 19:03) [8]

> Sha © (21.12.02 11:31)
> Мне тоже стало интересно... Вот мое решение:

Код работает на Delphi. Большое спасибо. Сейчас перевожу на TurboPascal...

← →
Fantasist (2002-12-21 21:57) [9]

type TCharMatrix=array [0..N,0..N] of char; TPoint=record x,y:integer; end; function FindWord(var chMatrix:TCharMatrix;Position:TPoint;Word:string):boolean; function GetNextSymbol(x,y:integer;symb:PChar;prev:integer):boolean; begin if symb^=#0 then begin Result:=True; exit; end; Result:=False; if (prev<>1) and (x+1<=N) and (chMatrix[x+1,y]=symb^) then Result:=GetNextSymbol(x+1,y,PChar(Integer(symb)+1),2); if (Result=False) and (prev<>2) and (x-1>=0) and (chMatrix[x-1,y]=symb^) then Result:=GetNextSymbol(x-1,y,PChar(Integer(symb)+1),1); if (Result=False) and (prev<>3) and (y+1<=N) and (chMatrix[x,y+1]=symb^) then Result:=GetNextSymbol(x,y+1,PChar(Integer(symb)+1),4); if (Result=False) and (prev<>4) and (y-1>=0) and (chMatrix[x,y-1]=symb^) then Result:=GetNextSymbol(x,y-1,PChar(Integer(symb)+1),3); end; begin if (Positsion.x in [0..N]) and (Positsion.y in [0..N]) and (chMatrix[Positsion.x,Positsion.y]=Word[1]) then Result:=GetNextSymbol(Positsion.x,Positsion.y,PChar(Integer(Word)+1),0) else Result:=False; end;

← →
Sha (2002-12-22 08:53) [10]

2 Fantasist © (21.12.02 21:57)

Это просто мысль или этот код работает?
Если второе, то нельзя ли показать его полностью?

← →
Sha (2002-12-22 08:58) [11]

С тестовыми данными.

← →
Fantasist (2002-12-24 03:38) [12]

> Это просто мысль или этот код работает?

Это просто мысль. :) Писал не проверяя. Но код работает. :)

> Если второе, то нельзя ли показать его полностью?

А это и есть полностью. :) Ну ладно, только ради вас:

const N=4; type TCharMatrix=array [0..N,0..N] of char; const cMr:TCharMatrix=(("x","o","x","a","x"), ("x","p","e","r","a"), ("d","x","r","x","t"), ("h","x","r","r","o"), ("t","x","r","x","x")); implementation procedure TForm1.Button1Click(Sender: TObject); var Mtr:TCharMatrix; begin Mtr:=cMr; FindWord(Mtr,Point(0,1),"operator"); end;

Функцию FindWord, берем выше, исправляя опечатки в слове Position. Там у меня наверху написанно Positsion.

← →
OlDemon (2002-12-24 06:56) [13]

2 all> IMXO оба представленых варианта страдают одной ошибкой.
Они могут одну букву взять дважды. Насколько я решал (когда то давно) такие задачи там этого делать было нельзя.
2 Fantasist> Лень проверять, но мне кажется твое решение не сработате по карйней мере в таком виде как сейчас. Ты ее с пристрастием тестировал?
Предвидя справедливо возмущенные крики "Сам ничего не сделал а других критикуешь!!" счас сделаю ее сам. :))
2 michael_b> Надо мое решение? IMHO самое правильное и корректное :)))) (шутка)

← →
Fantasist (2002-12-24 08:59) [14]

> IMXO оба представленых варианта страдают одной ошибкой.
> Они могут одну букву взять дважды

Могут. Но это надо было обговорить особо. :)

> Лень проверять, но мне кажется твое решение не сработате
> по карйней мере в таком виде как сейчас. Ты ее с пристрастием
> тестировал?

Сработает. Оно настолько просто, что и сомнений быть не может. :) Нет не тестировал. На кой мне это? Задачка для интереса - я решение придумал, и мне этого достадочно. :)

← →
michael_b (2002-12-24 15:37) [15]

> OlDemon ©

Давай!!!

← →
Sha (2002-12-24 16:13) [16]

2 OlDemon © (24.12.02 06:56)
> IMXO оба представленых варианта страдают одной ошибкой.
> Они могут одну букву взять дважды.

Вообще-то у меня массив Used как раз для того, чтоб не брать дважды. Слон такой маленький :)

← →
Sha (2002-12-24 16:19) [17]

2 Fantasist © (24.12.02 03:38)

Мне было любопытно посмотреть, какие данные используются для тестирования и отладки.

Попробуйте прогнать это с моей матрицей, или с такой:
рок
ква

← →
Fantasist (2002-12-25 03:39) [18]

> Попробуйте прогнать это с моей матрицей, или с такой:
> рок
> ква

Зачем. :) Думаете он найдет тут "корова"? :) Не найдет - у меня специальная переменная введена исключающая взятие той буквы с которой пришли.

← →
Sha (2002-12-25 08:00) [19]

2 Fantasist © (25.12.02 03:39)

> Зачем. :) Думаете он найдет тут "корова"?

Ну, вообще-то, речь идет не только о ней. Здесь есть и другие призраки: окорок, окова.

Согласен, что не найдет. Пока писал письмо, забыл, что у вас проверка имеется на то, откуда пришли, плюс программа работает только для квадратных матриц. Память у меня короткая :)

Но призраки могут быть не только "возвратными", а еще и "циклическими". В своей матрице кроме всего прочего я проверял такой набор призраков: окорок, колокол, канон, канава, колонна. Вот колокол, например, точно будет найден вашей программой.

2 All

Надо заметить, что автор сформулировал не совсем ту задачу, которая стояла перед создателями игры. Мало недопустить самопересечения слов. Надо решить более общую задачу, а именно: указанная игроком позиция может быть позицией ЛЮБОГО символа слова.

← →
OlDemon (2002-12-25 08:14) [20]

2 michael_b> А вот и мой вариант
-----------------------------------
Program ol;
uses crt;
type myarray=array [0..11,0..11] of char;
var a:myarray;
FWord:string;
n,i,j,k,l:integer;

Function FindWord(x,y,z:integer;b:myarray):boolean;
var flag:boolean;
begin
flag:=true;
If b[x,y]=FWord[z] then
begin
If z=Length(Fword) then
flag:=true else
begin
b[x,y]:="*";
flag:=false;
If (b[x-1,y]<>"*") then
flag:=FindWord(x-1,y,z+1,b);
If not(flag)and(b[x+1,y]<>"*") then
flag:=FindWord(x+1,y,z+1,b);
If not(flag)and(b[x,y-1]<>"*") then
flag:=FindWord(x,y-1,z+1,b);
If not(flag)and(b[x,y+1]<>"*") then
flag:=FindWord(x,y+1,z+1,b);
end;
end else Flag:=false;
FindWord:=flag;
end;

function IntToStr(t:integer):string;
var v:string;
begin
str(t,v);
IntToStr:=v;
end;

begin
writeln("Введие размерность матрицы");
readln(n);
for i:=1 to n do
for j:=1 to n do
begin
writeln("Введите "+IntToStr(i)+" элемент "+IntTostr(j)+" строки");
readln(a[i,j]);
end;
For i:=0 to n+1 do
begin
a[0,i]:="*";
a[i,0]:="*";
a[n+1,i]:="*";
a[i,n+1]:="*";
end;
Writeln("Введите начальные координаты");
Readln(k,l);
Writeln("Введите искомое слово");
Readln(FWord);
If FindWord(k,l,1,a) then writeln("Слово может быть составлено")
else Writeln("Слово не может быть составлено");
While not keypressed do;
end.
--------------------------------------------------------------

← →
OlDemon (2002-12-25 08:17) [21]

2 All> единственное что я не сделал это не разобрался с использованием памяти. Т.е. при размере в 100 программа переполняет стек. Но ИМХО Это уже мелочи.

← →
Fantasist (2002-12-25 09:26) [22]

> OlDemon © (25.12.02 08:17)

Правильная идея. :) Фактически то же самое, что у меня, но с пометкой пройденного пути. Однако постоянное копирование матрицы не есть хорошо. Посмотри на мой вариант: рекурсивная функция находиться внутри используемой. Тебе надо сделать точно так же, тогда можно создать глобальную переменную: матрицу той же размерности что и данная, но типа boolean, и пометки делать в ней. Так же отпадет необходимость передавать z=1 каждый раз. И Word, конечно, надо сделать параметром.

← →
OlDemon (2002-12-25 09:52) [23]

2 Fantasist> Да идея одинаковая, т.к. IМХO единственно правильная :))) А для "непередачи" массива нужно просто текущий символ запоминать в переменную и возвражать обратно если Flag в итоге фолз (только что дошло :)) ), иначе все равно надо передавать для отслежывания за"*" полей. И какая разница рекурсивная в используемой или просто рекурсивная?
Вот как надо: Function FindWord(x,y,z:integer):boolean; var flag:boolean; simv:char; begin flag:=true; If b[x,y]=FWord[z] then begin If z=Length(Fword) then flag:=true else begin simv:=a[x,y]; a[x,y]:="*"; flag:=false; If (a[x-1,y]<>"*") then flag:=FindWord(x-1,y,z+1); If not(flag)and(a[x+1,y]<>"*") then flag:=FindWord(x+1,y,z+1); If not(flag)and(a[x,y-1]<>"*") then flag:=FindWord(x,y-1,z+1); If not(flag)and(a[x,y+1]<>"*") then flag:=FindWord(x,y+1,z+1); If not flag then a[x,y]:=simv; end; end else Flag:=false; FindWord:=flag; end;
Ай да Я!! :))))

← →
Sha (2002-12-25 12:32) [24]

Хорошо бы еще решить задачу в общем виде, как в известной игре:
игрок вводит букву "о" в свободную ячейку и говорит (вводит в TEdit), что имел ввиду слово "корова", а программа ему: "есть такое слово".

← →
Fantasist (2002-12-26 00:17) [25]

> И какая разница рекурсивная в используемой или просто рекурсивная?

Разница большая. Мы же стремимся сделать ее наиболее универсальной и удобной в использовании. В данном случае, ты нашел обходное решение, но предположим, что мы воспользуемся первым. То есть примерно так:

type TCharMatrix=array [0..N,0..N] of char; TСheckMatrix=array [0..N,0..N] of boolean; TPoint=record x,y:integer; end; function FindWord(var chMatrix:TCharMatrix;Position:TPoint;Word:string):boolean; var chm:TCheckMatrix; function GetNextSymbol(x,y:integer;symb:PChar;prev:integer):boolean; begin if symb^=#0 then begin Result:=True; exit; end; chm[x,y]:=True; Result:=False; if (chm[x+1,y]=False) and (x+1<=N) and (chMatrix[x+1,y]=symb^) then Result:=GetNextSymbol(x+1,y,PChar(Integer(symb)+1),2); if (Result=False) and (chm[x-1,y]=False) and (x-1>=0) and (chMatrix[x-1,y]=symb^) then Result:=GetNextSymbol(x-1,y,PChar(Integer(symb)+1),1); if (Result=False) and (chm[x,y+1]=False) and (y+1<=N) and (chMatrix[x,y+1]=symb^) then Result:=GetNextSymbol(x,y+1,PChar(Integer(symb)+1),4); if (Result=False) and (chm[x,y-1]=False) and (y-1>=0) and (chMatrix[x,y-1]=symb^) then Result:=GetNextSymbol(x,y-1,PChar(Integer(symb)+1),3); end; begin if (Positsion.x in [0..N]) and (Positsion.y in [0..N]) and (chMatrix[Positsion.x,Positsion.y]=Word[1]) then begin FillChar(chm,sizeof(chm,0); Result:=GetNextSymbol(Positsion.x,Positsion.y,PChar(Integer(Word)+1),0); end else Result:=False; end;

Как видишь, никакого копирования массивов не происходит, и функцией гораздо удобнее пользоваться.

Сложная задача по Pascal Найти похожие ветки