Unit Computer;
interface
uses
SysUtils, Classes;
procedure SearchPatternsFirst;
{Начало игры}
procedure SearchPatterns;
procedure FindMultiPatterns;
procedure SearchBestWord;
type
TGetListOfWords = class(TThread)
protected
procedure Execute;
override;
procedure GetListOfWords;
public
constructor Create;
end;
implementation
uses _fm_Sugg, _fm_Main, _fm_Word, _fm_DMan;
var
LocPC : integer;
LocPatt : array [1..10] of TPattern;
LocPattFPs : array [0..10] of integer;
{Реальные позиции разных частей сложного шаблона}
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TComputerThread }
constructor TGetListOfWords.Create;
begin
FreeOnTerminate := True;
inherited Create(False);
end;
{ The Execute method is called when the thread starts }
procedure TGetListOfWords.Execute;
begin
fm_Main.Enabled := false;
GetListOfWords;
fm_Main.Enabled := true;
end;
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
procedure FixPatternsCenter;
var
i,l : integer;
Left,Right : integer;
begin
{В центральной (фиксированной) части шаблона заменяем * на _ }
fm_Suggest.lbPatts.Clear;
for i:=1 to PatternsCount do begin
for l:=1 to length(Patterns[i].Pattern) do
if Patterns[i].Pattern[l]<>'*' then
break;
Patterns[i].MaxL := l - 1;
for l:=l to length(Patterns[i].Pattern) do
if Patterns[i].Pattern[l]='*' then
break;
Left := l;
for l:=length(Patterns[i].Pattern) downto 1 do
if Patterns[i].Pattern[l]<>'*' then
break;
Patterns[i].MaxR := length(Patterns[i].Pattern) - l;
for l:=l downto 1 do
if Patterns[i].Pattern[l]='*' then
break;
Right := l;
if Left<=Right then
for l:=Left to Right do
if Patterns[i].Pattern[l]='*' then begin
Delete(Patterns[i].Pattern,l,1);
Insert('_',Patterns[i].Pattern,l);
end;
fm_Suggest.lbPatts.Items.Add(
// inttostr(integer(Patterns[i].DirHor)) + '| ' +
// inttostr(Patterns[i].MaxL) + ';' +
// inttostr(Patterns[i].MaxR) + '; ' +
// inttostr(Patterns[i].FixPos.x) + ';' +
// inttostr(Patterns[i].FixPos.y) + ' ' +
Patterns[i].Pattern
);
end;
end;
{------------------------------------------------------------------------------}
procedure SearchPatternsFirst;
{ Если начало игры }
var
i : integer;
begin
fm_Main.Repaint;
PatternsCount := 0;
{Если есть звездочка, то ???}
for i:=1 to 7 do
if Players[PCurrent].Letters[i]<>'*' then begin
inc(PatternsCount);
Patterns[PatternsCount].FixPos := Point(7,7);
Patterns[PatternsCount].DirHor := true;
Patterns[PatternsCount].Pattern :=
'*******'+Players[PCurrent].Letters[i]+'*******';
fm_Suggest.lbPatts.Items.Add('H: '+'*******'+Players[PCurrent].Letters[i]+
'*******');
end;
end;
{------------------------------------------------------------------------------}
procedure SearchPatterns;
{ Если не начало игры }
var
i,j,k : integer;
FixStart : integer;
patt : shortstring;
Exist : boolean;
begin
fm_Main.Repaint;
PatternsCount := 0;
{Horizontal Check -------------------------------------------------------------}
for j:=0 to MaxWordLength-1 do begin
i := 0;
while i<MaxWordLength-1 do begin
patt := '';
FixStart := -1;
for i:=i to MaxWordLength-1 do begin
if Field[i,j].Letter<>' ' then begin
patt := patt + Field[i,j].Letter;
if FixStart=-1 then
FixStart := i
end
else if SeaCheck(i,j,true) then
patt := patt + '*'
else
break;
end;
{for i}
inc(i);
if patt=AnsiUpperCase(patt) then
patt := '';
{Убираем шаблоны без букв}
if Pos('*',patt)=0 then
patt := '';
{Убираем шаблоны без звездочек}
if (Length(patt)>1) then begin
patt := patt;
Exist := false;
{Проверка на уникальность шаблона}
for k:=1 to PatternsCount do
if Patterns[k].Pattern=patt then begin
Exist := true;
break;
end;
if not Exist then begin
inc(PatternsCount);
Patterns[PatternsCount].FixPos := Point(FixStart,j);
Patterns[PatternsCount].DirHor := true;
Patterns[PatternsCount].Pattern := patt;
end;
end;
end{while}
end;
{for j}
{Vertical Check ---------------------------------------------------------------}
for j:=0 to MaxWordLength-1 do begin
i := 0;
while i<MaxWordLength-1 do begin
patt := '';
FixStart := -1;
for i:=i to MaxWordLength-1 do begin
if Field[j,i].Letter<>' ' then begin
patt := patt + Field[j,i].Letter;
if FixStart=-1 then
FixStart := i
end
else if SeaCheck(j,i,false) then
patt := patt + '*'
else
break;
end;
{for i}
inc(i);
if patt=AnsiUpperCase(patt) then
patt := '';
{Убираем шаблоны без букв}
if Pos('*',patt)=0 then
patt := '';
{Убираем шаблоны без звездочек}
if (Length(patt)>1) then begin
patt := patt;
Exist := false;
{Проверка на уникальность шаблона}
for k:=1 to PatternsCount do
if Patterns[k].Pattern=patt then begin
Exist := true;
break;
end;
if not Exist then begin
inc(PatternsCount);
Patterns[PatternsCount].FixPos := Point(j,FixStart);
Patterns[PatternsCount].DirHor := false;
Patterns[PatternsCount].Pattern := patt;
end;
{for k}
end;
{if}
end{while}
end;
{for j}
end;
{------------------------------------------------------------------------------}
{ Немеренная процедура поиска возможных шаблонов по принципу морского боя }
{ Вложенность подшаблонов составляет }
{------------------------------------------------------------------------------}
procedure NextMultyPattern(PattNo, PattType:integer);
var
i,j,k,l : integer;
Exist : boolean;
begin
k := LocPC - PattType + 1;
{Количество новых шаблонов за этот проход}
for j:=1 to k do begin
LocPatt[j].Pattern := '';
i := LocPattFPs[j] - LocPattFPs[0];
for l:=2 to PattType do begin
{Повторяем количество раз = Типу шаблона}
{>>>>>>>>>>>>>>>>>>>>>>>>>}
while (Patterns[PattNo].Pattern[i]<>'*') and {Пока буковки справа}
(i<=length(Patterns[PattNo].Pattern)) do begin
LocPatt[j].Pattern := LocPatt[j].Pattern + Patterns[PattNo].Pattern[i];
inc(i);
end;
{>>>>>>>>>>>>>>>>>>>>>>>>>}
while (Patterns[PattNo].Pattern[i]='*') and {Пока * справа}
(i<=length(Patterns[PattNo].Pattern)) do begin
LocPatt[j].Pattern := LocPatt[j].Pattern + Patterns[PattNo].Pattern[i];
inc(i);
end;
end;
{>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
while (Patterns[PattNo].Pattern[i]<>'*') and {Пока буковки справа}
(i<=length(Patterns[PattNo].Pattern)) do begin
LocPatt[j].Pattern := LocPatt[j].Pattern + Patterns[PattNo].Pattern[i];
inc(i);
end;
{>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
while (Patterns[PattNo].Pattern[i]='*') and {Пока * справа}
(i<=length(Patterns[PattNo].Pattern)) do begin
LocPatt[j].Pattern := LocPatt[j].Pattern + Patterns[PattNo].Pattern[i];
inc(i);
end;
{Удаляем крайний правый символ}
if (LocPatt[j].Pattern[length(LocPatt[j].Pattern)]='*') and
(i<=length(Patterns[PattNo].Pattern)) then
Delete(LocPatt[j].Pattern,length(LocPatt[j].Pattern),1);
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<}
i := LocPattFPs[j] - LocPattFPs[0] - 1;
while (Patterns[PattNo].Pattern[i]='*') and {Пока * слева}
(i>=0) do begin
LocPatt[j].Pattern := Patterns[PattNo].Pattern[i] + LocPatt[j].Pattern;
dec(i);
end;
if i>0 then
Delete(LocPatt[j].Pattern,1,1);
if Pos('*',LocPatt[j].Pattern)>0 then begin
{если вообще есть звездочки}
{Сохраняем шаблон}
Exist := false;
{Проверка на уникальность шаблона}
for l:=1 to PatternsCount do
if Patterns[l].Pattern=LocPatt[j].Pattern then begin
Exist := true;
break;
end;
if not Exist then begin
inc(PatternsCount);
Patterns[PatternsCount].DirHor := Patterns[PattNo].DirHor;
Patterns[PatternsCount].FixPos := LocPatt[j].FixPos;
if LocPatt[j].DirHor then
Patterns[PatternsCount].FixPos.x := LocPattFPs[j]
else
Patterns[PatternsCount].FixPos.y := LocPattFPs[j];
Patterns[PatternsCount].Pattern := LocPatt[j].Pattern;
end;
end;
{if}
end;
{for j}
end;
{------------------------------------------------------------------------------}
procedure FindMultiPatterns;
var
i,p : integer;
begin
{Устанавливаем количество и характеристики подшаблонов ------------------------}
for p:=1 to PatternsCount do begin
i := 1;
LocPC := 0;
{Local PatternsCount}
while i<=length(Patterns[p].Pattern) do begin
while (Patterns[p].Pattern[i]='*') and {Пока звездочки}
(i<=length(Patterns[p].Pattern)) do
inc(i);
if i>length(Patterns[p].Pattern) then
break;
{Повышаем уровень шаблона}
inc(LocPC);
LocPatt[LocPC].DirHor := Patterns[p].DirHor;
LocPatt[LocPC].FixPos := Patterns[p].FixPos;
if LocPC=1 then
if LocPatt[LocPC].DirHor then
LocPattFPs[0] := Patterns[p].FixPos.x - i
else
LocPattFPs[0] := Patterns[p].FixPos.y - i;
{Разница между реальной и относит позициями для взаимопреобразований}
LocPattFPs[LocPC] := i + LocPattFPs[0];
while (Patterns[p].Pattern[i]<>'*') and {Пока буковки}
(i<=length(Patterns[p].Pattern)) do
inc(i);
end;
{Поиск одинарных, 2х, 3х, 4х... подшаблонов --------------------------------------}
if LocPC>1 then
for i:=1 to LocPC-1 do
NextMultyPattern(p,i);
end;
FixPatternsCenter;
end;
{------------------------------------------------------------------------------}
procedure AddItems(PattNo:integer; Pattern:string; MaxL:byte; Fix:string; MaxR:byte);
var
i,j,f,k : integer;
Letters,Found,Patt : string;
Nested : boolean;
begin
f := 0;
Patt := Fix;
for i:=1 to MaxL do
Patt:='_' + Patt;
for i:=1 to MaxR do
Patt:=Patt + '_';
for k:=0 to fm_DMan.lbActive.Items.Count-1 do
if FindLike(Patt,fm_DMan.lbActive.Items[k]) then begin
Found := fm_DMan.lbActive.Items[k];
Nested := true;
case Difficulty of
0:
if length(Found)>3 then
Nested := false;
1:
if length(Found)>4 then
Nested := false;
2:
if length(Found)>5 then
Nested := false;
end;
{case}
{Поиск позиции фиксированной части шаблона в найденном слове}
if Nested then begin
Nested := false;
for i:=1 to length(Found)-length(Fix)+1 do begin
if (Found[i]=Fix[1]) then begin
Nested := true;
for j:=2 to length(Fix) do
if (Found[i+j-1]<>Fix[j]) and
(Fix[j]<>'_') then
Nested := false;
end;
{if}
if Nested then
break
end;
{for i}
f := i;
if (f-1>MaxL) or (length(Found)-f-length(Fix)+1>MaxR) then
Nested := false;
end;
{Если Nested, то f - позиция фиксированной части шаблона в найденном слове}
if Nested and (length(Found)-length(Fix)<=7) then begin
{Проверка на наличие букв у игрока}
Letters := '';
{строка с буквами игрока}
for i:=1 to 7 do
Letters:=Letters + Players[PCurrent].Letters[i];
{В ситуации первого хода - шаблон добавлять не надо}
if GameState=gsGame then
Letters := Letters + Fix;
{Удаляем '_'}
while Pos('_',Letters)>0 do
Delete(Letters,Pos('_',Letters),1);
{Если такое слово уже поставлено, то его не запоминаем}
Nested := false;
for i:=1 to PlayerMoves do begin
if AnsiLowerCase(Copy(Trim(PlayerMove[i].Word),2,length(Trim(PlayerMove[i].
Word))-2))=Found then begin
Nested := true;
break;
end;
end;
for i:=1 to length(Found) do
if Pos(Found[i],Letters)>0 {Есть такая буква} then
Delete(Letters,Pos(Found[i],Letters),1)
else if Pos('*',Letters)>0 {Нет, но есть звездочка} then
Delete(Letters,Pos('*',Letters),1)
else
break;
{У игрока букв хватает => слово запоминаем}
if (not Nested) and
(length(Found)<i) and
(length(Found)>length(Fix)) and
(FindWordInFounded(Found)<0) then begin
inc(FoundedWords);
Drafts[FoundedWords].Word := Found;
Drafts[FoundedWords].PattNo := PattNo;
if Patterns[PattNo].DirHor then begin
Drafts[FoundedWords].WCol := Patterns[PattNo].FixPos.x - f + 1;
Drafts[FoundedWords].WRow := Patterns[PattNo].FixPos.y;
end
else begin
Drafts[FoundedWords].WCol := Patterns[PattNo].FixPos.x;
Drafts[FoundedWords].WRow := Patterns[PattNo].FixPos.y - f + 1;
end;
end;
end;
{if not Nested}
end;
{if RegExpr}
end;
{------------------------------------------------------------------------------}
procedure TGetListOfWords.GetListOfWords;
var
i,j,k,p : integer;
begin
FoundedWords := 0;
for i:=1 to PatternsCount do begin
{Начинается с фиксированной части}
if (Patterns[i].Pattern[1]<>'*') and (Patterns[i].Pattern[length(Patterns[i].Pattern
)]='*') then begin
Fix := Copy(Patterns[i].Pattern,1,Pos('*',Patterns[i].Pattern)-1);
k := length(Patterns[i].Pattern)-length(Fix);
AddItems(i,Patterns[i].Pattern,0,Fix,k);
end;
{Заканчивается фиксированной частью}
if (Patterns[i].Pattern[1]='*') and (Patterns[i].Pattern[length(Patterns[i].Pattern)
]<>'*') then begin
for j:=length(Patterns[i].Pattern) downto 1 do
if Patterns[i].Pattern[j]='*' then
break;
Fix := Copy(Patterns[i].Pattern,j+1,length(Patterns[i].Pattern)-j);
k := length(Patterns[i].Pattern)-length(Fix);
AddItems(i,Patterns[i].Pattern,k,Fix,0);
end;
{Фиксированная часть в середине}
if (Patterns[i].Pattern[1]='*') and (Patterns[i].Pattern[length(Patterns[i].Pattern)
]='*') then begin
for j:=1 to length(Patterns[i].Pattern) do
if Patterns[i].Pattern[j]<>'*' then
break;
p := j-1;
for k:=j to length(Patterns[i].Pattern) do
if Patterns[i].Pattern[k]='*' then
break;
Fix := Copy(Patterns[i].Pattern,j,k-j);
k := length(Patterns[i].Pattern)-length(Fix)-p;
AddItems(i,Patterns[i].Pattern,p,Fix,k);
end;
end;
{for i}
end;
{------------------------------------------------------------------------------}
procedure SearchBestWord;
var
i,PNo,WNo,WW,GLine : integer;
begin
sWord := '';
WW := 0;
WNo := 1;
GLine := 1;
{Подготавливаем таблицу слов}
fm_Suggest.sgWords.RowCount := 3;
fm_Suggest.sgWords.RowCount := 1024;
for i:=1 to FoundedWords do begin
sWord := Drafts[i].Word;
WordDirHor := Patterns[Drafts[i].PattNo].DirHor;
SCol := Drafts[i].WCol;
SRow := Drafts[i].WRow;
{Проверка на уникальность слова}
CheckForUnique;
{Выбираем из слов самое веское}
if {((WordWeight>WW) or (Suggested)) and} (EMessage='') then begin
// Если поставить в условии "WordWeight>W", то список слов будет разрывным
// и надо решить эту проблему путем вода переменной = позиции вставки
// нового слова
{Записываем слово в список}
PNo := Drafts[i].PattNo;
{!!! Потом убрать}
if Patterns[PNo].DirHor then
fm_Suggest.sgWords.Cells[2,GLine] := '<->'
else
fm_Suggest.sgWords.Cells[2,GLine] := ' |';
fm_Suggest.sgWords.Cells[3,GLine] := inttostr(Drafts[i].WCol);
fm_Suggest.sgWords.Cells[4,GLine] := inttostr(Drafts[i].WRow);
fm_Suggest.sgWords.Cells[0,GLine] := sWord;
fm_Suggest.sgWords.Cells[1,GLine] := IntToStr(WordWeight);
inc(GLine);
if WordWeight>WW then begin
WNo := i;
WW := WordWeight;
end;
end;
end;
{for i}
if WW=0 then
UserSkip := true
else begin
TheBestWordNo := WNo;
sWord := Drafts[WNo].Word;
WordDirHor := Patterns[Drafts[WNo].PattNo].DirHor;
SCol := Drafts[WNo].WCol;
SRow := Drafts[WNo].WRow;
for i:=1 to length(sWord) do
if WordDirHor then
if Field[SCol + i - 1,SRow].Letter=' ' then
WordCross[i] := false
else
WordCross[i] := true
else
if Field[SCol,SRow + i - 1].Letter=' ' then
WordCross[i] := false
else
WordCross[i] := true;
fm_Suggest.sgWords.RowCount := GLine;
fm_Suggest.sgWords.Row := WNo;
fm_Suggest.sgWords.TopRow := fm_Suggest.sgWords.Row;
end;
end;
end.