unit UBrutForce;
{ ********************************************************************************* }
{ (c) GNU                                                                           }
{ author: Heiko Tietze                                                              }
{ version: 1.0                                                                      }
{ date: 11.12.2004                                                                  }
{ description: ComputeMove() to find words by letters and insert them in the grid   }
{ ********************************************************************************* }

{$I Def.inc}

interface

uses Sysutils, Classes, IniFiles, StrUtils,
     {$IFDEF VCL}
     Windows, Forms,
     {$ELSE}
     QForms,
     {$ENDIF}
     UScrabble, UDictionary;

type TProgress = procedure(Percent:Byte; ID:Byte=0) of Object;
     TBrutForce=class
            private
              FScrabble : TScrabble;
              FProgress:TProgress;
              FCharacters : string;
              function WordsByLetters(Letters:string):string; //returns a comma delimited string of words composed by letters
            published
              constructor Create(Scrabble : TScrabble);
              destructor Destroy; override;
            public
              procedure ComputeMove;
              property OnProgress:TProgress read FProgress write FProgress;
              property Characters:string read FCharacters write FCharacters;
            end;

var BrutForce : TBrutForce;

implementation

constructor TBrutForce.Create(Scrabble:TScrabble);
begin
   inherited Create;
   FCharacters:='ABCDEFGHIJKLMNOPQRSTUVWXYZ';//default
   FScrabble:=Scrabble;
end;

destructor TBrutForce.Destroy;
begin
   inherited;
end;

function TBrutForce.WordsByLetters(Letters: string): string;
var i,j,z,index      : integer;
    AvailableLetters : shortstring;
    s                : string;
begin
   Result:=''; i:=1; s:='';
   AvailableLetters:=Letters;
   if assigned(Dictionary) then with Dictionary do
   repeat
     repeat
       z:=pos(FCharacters[i],AvailableLetters);
       if (z>0) then
       begin
          s:=s+FCharacters[i];
          if Find(s,index) then if Result='' then Result:=s else Result:=Result+','+s;
          if (index<Count) and (copy(Strings[index],1,length(s))=s) then //incomplete or complete word
          begin
             System.Delete(AvailableLetters,z,1); //exclude letter from next search
             i:=1; //start from first letter
             j:=0;
          end else
          begin
             System.Delete(s,length(s),1);//clear the last letter in temp string
             j:=-1;
          end;
       end else j:=-1;
     until j=-1;
     if (i=length(FCharacters)) and (length(s)>0) then //if last letter in the set and something was found
     begin
       i:=pos(s[length(s)],FCharacters)+1; //start next search with then successor in available
       System.Delete(s,length(s),1); //clear the last letter in temp string
       AvailableLetters:=Letters; //reset the available letters and delete found chars
       for j:=1 to length(s) do System.Delete(AvailableLetters,pos(s[j],AvailableLetters),1);
     end else inc(i); //next char in set
   until i>length(FCharacters);
end;

procedure TBrutForce.ComputeMove;

 //collect letters of a row or column into a string; empty field should be filled with spaces
 function Vector(Dim: TDimension; a, b: integer): string;
 var i:integer;
 begin
   Result:='';
   for i:=0 to 14 do
   case dim of
     dx : Result:=Result+FScrabble.Placed[i,a,b].what;
     dy : Result:=Result+FScrabble.Placed[a,i,b].what;
     dz : Result:=Result+FScrabble.Placed[a,b,i].what;
   end;
 end;

 //letters to string
 function AllLetters:string;
 var i:integer;
 begin
    Result:='';
    for i:=0 to FScrabble.LettersCount-1 do
      if FScrabble.Letter[i].State=lsNormal then
         Result:=Result+FScrabble.Letter[i].what else Result:=Result+' '; //sequence must be kept
 end;

var dim       : TDimension;
    i,j,x,y,z : integer;
    tmp,IndexOfRowCol,IndexOfWord,IndexOfLetter : integer;
    MaxValue   : integer;
    BestMove : array of TLetter;
    s        : string;
begin
   MaxValue:=0;
   try
     for dim:=low(TDimension) to high(TDimension) do
     begin
       if (dim=dz) and (FScrabble.FieldDimension=D2) then continue;
       for i:=0 to 14 do
        for j:=0 to 14 do
        begin
          if assigned(FProgress) then FProgress(round((((integer(dim)+1)*15*15+i*15+j+1)/(3*15*15))*100),1);
          //first move has to connect the middle field
          if (FScrabble.HistoryCount=0) and ((i<>7) or (j<>7)) then continue;
          //continue if only 2D
          if (FScrabble.FieldDimension=D2) and (j<>7) then continue;
          //collect letters
          s:=AllLetters+AnsiReplaceStr(Vector(dim,i,j),' ','');
          //do only if a connection is possible
          if ((i>0) and (AnsiReplaceStr(Vector(dim,i-1,j),' ','')<>'')) or
             ((i<14) and (AnsiReplaceStr(Vector(dim,i+1,j),' ','')<>'')) or
             ((j>0) and (AnsiReplaceStr(Vector(dim,i,j-1),' ','')<>'')) or
             ((j<14) and (AnsiReplaceStr(Vector(dim,i,j+1),' ','')<>'')) or
             (length(s)>FScrabble.LettersCount) or
             (FScrabble.HistoryCount=0) then
          with TStringList.Create do
          try
            if assigned(FProgress) then FProgress(0,2);
            //find words by letters
            CommaText:=WordsByLetters(s);
            //check each word
            for IndexOfWord:=0 to Count-1 do
            begin
              if assigned(FProgress) then FProgress(round(((IndexOfWord+1)/Count)*100),2);
              //place word at each possible position
              for IndexOfRowCol:=0 to 14-length(Strings[IndexOfWord])+1 do
              begin
                s:=AllLetters;
                try
                  for IndexOfLetter:=1 to length(Strings[IndexOfWord]) do
                  begin
                    case dim of
                     dx : begin x:=IndexOfLetter+IndexOfRowCol-1;y:=i;z:=j;end;
                     dy : begin x:=i;y:=IndexOfLetter+IndexOfRowCol-1;z:=j;end;
                     dz : begin x:=i;y:=j;z:=IndexOfLetter+IndexOfRowCol-1;end;
                    end;
                    //if letter cannot be placed
                    if (FScrabble.Placed[x,y,z].State=psClear) then
                    begin
                      if (pos(Strings[IndexOfWord][IndexOfLetter],s)=0) then abort;
                      //place letter
                      FScrabble.PlaceFromLetter[x,y,z]:=pos(Strings[IndexOfWord][IndexOfLetter],s)-1;
                      s[pos(Strings[IndexOfWord][IndexOfLetter],s)]:=' ';//clear but remeber sequence of letters
                    end;
                  end; //IndexOfLetter
                  //test the move
                  tmp:=FScrabble.CheckMove([cmAskForWords]);
                  //store in case of a good move
                  if (FScrabble.LastError=erNone) then
                  begin
                    if (tmp>MaxValue) then
                    begin
                      setlength(BestMove,0);
                      for IndexOfLetter:=0 to FScrabble.LettersCount-1 do
                       if FScrabble.Letter[IndexOfLetter].State=lsPlaced then
                       begin
                         setlength(BestMove,length(BestMove)+1);
                         BestMove[length(BestMove)-1]:=FScrabble.Letter[IndexOfLetter];
                         BestMove[length(BestMove)-1].what:=chr(IndexOfLetter);
                       end;
                      MaxValue:=tmp;
                      if assigned(FProgress) then FProgress(MaxValue,3);
                    end; //tmp>MaxValue
                  end; //FScrabble.LastError=erNone
                except end; //handling of abort
                //restore gamearray
                FScrabble.ResetLetters;
              end;//IndexOfRowCol
            end;//IndexOfWord
          finally
            Free;
          end; //TStringList.Create
        end; // for i, for j
     end; //for dim
     //change letter if no move was found
     if (MaxValue=0) then
     begin
       tmp:=0;
       //mark multiple letters for change
       for i:=0 to FScrabble.LettersCount-2 do
        for j:=i+1 to FScrabble.LettersCount-1 do
         if (FScrabble.Letter[i].what=FScrabble.Letter[j].what) and (FScrabble.Letter[i].State=lsNormal) then
         begin
           FScrabble.LetterPrepareToChange[i]:=true;
           inc(tmp);
         end;
       //if no multiple letters were found mark the one with the highest value
       if tmp=0 then
       begin
         j:=0;
         for i:=0 to FScrabble.LettersCount-1 do
          if FScrabble.LetterValue[FScrabble.Letter[i].what]>tmp then
          begin
            j:=i;
            tmp:=FScrabble.LetterValue[FScrabble.Letter[i].what];
          end;
         FScrabble.LetterPrepareToChange[j]:=true;
       end;
     end else //place letter if a move was found
     for i:=0 to length(BestMove)-1 do
      with BestMove[i] do
       FScrabble.PlaceFromLetter[where[dx],where[dy],where[dz]]:=ord(BestMove[i].what);
   finally
     setlength(BestMove,0);
     if assigned(FProgress) then FProgress(101,1);
   end;
end;

end.