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.