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.