unit U_8QueensPlus3;


{Version 3
 Generates all solutions for coins in each possible starting
 location.   Adds OnDrawCell graphic display. Adds user play option.
 }

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, Buttons, MPlayer;
const
  maxsolutions=5;
type
  TBoard=array[1..8,1..8] of integer;
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    BitBtn1: TBitBtn;
    Memo1: TMemo;
    Button1: TButton;
    SolutionGroup: TGroupBox;
    SolutionBox: TListBox;
    MediaPlayer1: TMediaPlayer;
    GroupBox1: TGroupBox;
    Label3: TLabel;
    StringGrid1: TStringGrid;
    StringGrid2: TStringGrid;
    Label4: TLabel;
    Label5: TLabel;
    StringGrid3: TStringGrid;
    Label6: TLabel;
    StringGrid4: TStringGrid;
    Label10: TLabel;
    StringGrid8: TStringGrid;
    StringGrid7: TStringGrid;
    Label9: TLabel;
    StringGrid6: TStringGrid;
    Label8: TLabel;
    StringGrid5: TStringGrid;
    Label7: TLabel;
    TestGroup: TGroupBox;
    TestGrid: TStringGrid;
    Label11: TLabel;
    CountLbl: TLabel;
    procedure SolveBtn(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure GridDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormCreate(Sender: TObject);
    procedure SolutionBoxClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure TestGridClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    board:TBoard;
    solutions:array [1..maxsolutions] of tBoard;
    solutioncount:integer;
    counter:integer;
    moves:integer;
    Startcol,StartRow:integer;
    Function PlaceCounter(n:integer):boolean;
    Procedure Initboard;
    Procedure loadsolution(boardin:TBoard);
    Function RowIsClear(x:integer):boolean;
    Function ColIsClear(x:integer):boolean;
    Function DiagsAreClear(x,y:integer):boolean;
    Procedure reward;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}


    {**************** RowIsClear *************}
    Function Tform1.RowIsClear(x:integer):boolean;
    var
      i:integer;
    Begin
      result:=true;
      i:=1;
      While (i<=8) and result do
      Begin
        if (board[i,x]>0) then result:=false
        else inc(i);
      End;
    end;

    {******* ColIsClear *********}
    Function TForm1.ColIsClear(x:integer):boolean;
    var
      i:integer;
    Begin
      result:=true;
      i:=1;
      While (i<=8) and result do
      Begin
        if (board[x,i]>0) then result:=false
        else inc(i);
      End;
    end;

   {******** DiagsAreClear *****}
    Function TForm1.DiagsAreClear(x,y:integer):boolean;
    var
      i,j:integer;
    Begin
      result:=true;
      {go up and left}
      i:=x-1;
      j:=y-1;
      while (i>=1) and (j>=1) and (result)
      do  if board[i,j]>0 then result:=false
      else
      Begin
        dec(i);
        dec(j);
      end;
      {go up and right}
      i:=x+1;
      j:=y-1;
      while (i<=8) and (j>=1) and result
      do  if board[i,j]>0 then result:=false
      else
      Begin
        inc(i);
        dec(j);
      end;

      {go down and left}
      i:=x-1;
      j:=y+1;
      while (result=true) and (i>=1) and (j<=8)
      do  if board[i,j]>0 then result:=false
      else
      Begin
        dec(i);
        inc(j);
      end;

      {go down and right}
      i:=x+1;
      j:=y+1;
      while (result=true) and (i<=8) and (j<=8)
      do  if board[i,j]>0 then result:=false
      else
      Begin
        inc(i);
        inc(j);
      end;
    end;

{************** PlaceCounter *******************}
Function TForm1.PlaceCounter(n:integer):boolean;
var
  i,j:integer;
  placed,r :boolean;
  prevboard:TBoard;



Begin
  inc(counter);
  prevboard:=board;
  placed:=false;
  if n>1 then
  Begin
    i:=2;
    j:=1;
  end
  else
  Begin
    i:=startcol;
    j:=startrow;
  End;
  while (i<=8) and (j<=8) and not placed do
  Begin
    r:=RowIsClear(j);
    if (board[i,j]=0)
       and r
       and ColIsClear(i)
       and DiagsAreClear(i,j)
    then
    Begin
      board[i,j]:=n;
      placed:=true;
    end
    else
    Begin
      if not r then i:=9 else inc(i);
      if i>8 then
      Begin
        i:=1;
        inc(j);
      end;
    end;
    if placed
       then
       {Make recursive call to place next counter}
       if (n<8) then placed:=placeCounter(n+1)
       else
    else board:=prevboard; {erase that move and continue search}
  end;
  result:=placed;
end;

{********** InitBoard **************}
Procedure TForm1.InitBoard;
var
  i,j:integer;

Begin
  for i:=1 to 8 do
  for j:= 1 to 8 do
    board[i,j]:=0;

  for i:=1 to 8 do
  Begin
    board[i,i]:=-1;
    board[i,9-i]:=-1;
  end;
End;

 Procedure LoadgridFromBoard(BoardIn:TBoard; var Grid:TStringGrid);
    var
      i,j:integer;
    {Load up the display grid values - on drawcell will handle graphics}
    Begin
      for i:= 1 to 8 do
      for j:= 1 to 8 do
      with grid do
      if boardIn[i,j]>0 then cells[i-1,j-1]:='1'
      else if boardin[i,j]=-1 then cells[i-1,j-1]:='X'
      else cells[i-1,j-1]:='';
    end;


 Function GridsEqual(grid1,grid2:TStringgrid):Boolean;
 var
   i,j:integer;
 Begin
   result:=true;
   If (grid1.rowcount=grid2.rowcount) and (grid1.colcount=grid2.colcount) then
   Begin
     for i:= 0 to grid1.colcount-1 do
     begin
       for j:=0 to grid2.rowcount-1 do
       if grid1.cells[i,j]<>grid2.cells[i,j] then
       begin
         result:=false;
         break;
       end;
       if result=false then break;
     end;  
   end
   else result:=false;
 End;

Procedure rotateboard(GridIn:TstringGrid; var GridOut:TStringgrid);
{rotate board clockwise by 90 degrees}
var i,j:integer;
Begin
    for i:=0 to 7 do
    for j:=0 to 7 do
    GridOut.Cells[7-j,i]:=GridIn.Cells[i,j];
End;

Procedure invertboard(GridIn:TstringGrid; var GridOut:TStringgrid);
{reverse columns - we couuld also revese rows, but not both}
var j:integer;
Begin
    for j:=0 to 7 do
    GridOut.cols[7-j]:=GridIn.cols[j];
End;

Procedure Tform1.loadsolution(boardin:TBoard);
    Begin
      LoadGridFromBoard(Boardin,StringGrid1);
      rotateboard(stringgrid1,stringgrid2);
      rotateboard(stringgrid2,stringgrid3);
      rotateboard(stringgrid3,stringgrid4);

      invertboard(stringgrid1,stringgrid5);
      rotateboard(stringgrid5,stringgrid6);
      rotateboard(stringgrid6,stringgrid7);
      rotateboard(stringgrid7,stringgrid8);
    End;

{******************* SolveBtn **********************}
procedure TForm1.SolveBtn(Sender: TObject);
var
  i,j:integer;
  equal, done:boolean;
begin
  GroupBox1.visible:=true;
  testgroup.visible:=false;
  SolutionGroup.visible:=false;
  solutioncount:=0;
  counter:=0;
  done:=false;
  screen.cursor:=crHourGlass;
  repeat;
    initboard;
    {if solved}
    if placecounter(1) then
    Begin
      {possible solution - may be repeat of one already found}
      loadsolution(Board);


      {Now check for previous equal solution}
      i:=1;
      equal:=false;
      {Load up current solutions and compare to new solution permutations}
      while not(equal) and (i<=solutioncount) do
      Begin
        loadgridfromBoard(solutions[i],testgrid);
        if GridsEqual(testgrid,stringgrid1)
        or GridsEqual(testgrid,stringgrid2)
        or GridsEqual(testgrid,stringgrid3)
        or GridsEqual(testgrid,stringgrid4)
        or GridsEqual(testgrid,stringgrid5)
        or GridsEqual(testgrid,stringgrid6)
        or GridsEqual(testgrid,stringgrid7)
        or GridsEqual(testgrid,stringgrid8)
        then equal:=true
        else inc(i);
      end;
      if not equal then
      Begin
        inc(solutioncount);
        solutions[solutioncount]:=board;
        Label3.caption:='Solution # '+inttostr(solutioncount);
        screen.cursor:=crDefault;
        If messagedlgpos('Solution found!',mtinformation,[mbOK,mbcancel],0, 352,72)
          =mrcancel then done:=true;
        screen.cursor:=crHourGlass;
      end;

      {Find first marked block}
      i:=1;
      j:=1;
      while (i<=8) and (board[i,j]<>1) do
      Begin
        inc(j);
        If j>8 then
        Begin
          inc(i);
          j:=1;
        End;
      End;
      {If found set next starting point}
      if (i<=8) and (board[i,j]=1) then
      Begin
        startcol:=i+1;
        startrow:=j;
        If startcol>8 then
        Begin
          inc(startrow);
          startcol:=1;
        End;
      end
      else  {shouldn't get here}
      Begin
        startcol:=2;
        startrow:=1;
      End;
    End
    else
    Begin
      {label2.caption:='Sorry - no more, starting over';}
      startcol:=2;
      Startrow:=1;
      done:=true;
    End;
    {label1.caption:='Postions tried='+inttostr(counter);}
  until done;
  screen.cursor:=crdefault;
  messagedlgpos('No more solutions',mtinformation,[mbOK],0, 352,72);
  SolutionGroup.visible:=true;
  With SolutionBox.items do
  Begin
    clear;
    for i:=1 to solutioncount do add('Solution # '+inttostr(i));
  end;
end;

{**************** FormActivate **************}
procedure TForm1.FormActivate(Sender: TObject);
begin
  Initboard;
  LoadGridFromBoard(board,Stringgrid1);
  Startcol:=2;
  StartRow:=1;
end;

{****************** GridDrawCell ****************}
procedure TForm1.GridDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
  var
    i,j:integer;
begin
   i:=acol;
   j:=arow;
   with Sender as Tstringgrid do
  begin
    if cells[i,j]='X' then
    Canvas.Brush.Color := clblack
    else canvas.brush.color:=clgreen;
    Canvas.FillRect(Rect);
    if Cells[i,j] ='1' then
    Begin
      Canvas.Brush.color:=clred;
      with rect do
      canvas.Ellipse(left+2,top+2,right-2,bottom-2);
    End;
  end;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  windowstate:=wsMaximized;
  solutioncount:=0;
end;

procedure TForm1.SolutionBoxClick(Sender: TObject);
begin
  with solutionbox do
  Begin
    loadsolution(Solutions[itemindex+1]);
    Label3.caption:='Solution # '+inttostr(itemindex+1);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  solutiongroup.visible:=false;
  groupbox1.visible:=false;
  initboard;
  LoadGridFromBoard(board,testgrid);
  testgroup.visible:=true;
  {intedit1.value:=0;}
  moves:=0;

end;

Procedure TForm1.reward ;
Begin
  showmessage('Give a nice reward here');
end;

procedure TForm1.TestGridClick(Sender: TObject);
  var
    arow,acol:integer;
begin
  with testgrid do
  Begin
    acol:=col; arow:=row;
    if cells[acol,arow]='' then
    Begin
      If colIsClear(acol+1)
        and rowIsClear(arow+1)
        and diagsAreClear(acol+1,arow+1)
      then
      Begin
        board[acol+1,arow+1]:=1;
        cells[acol,arow]:='1';
        inc(moves);
        countlbl.caption:=inttostr(moves);
        If moves=8 then reward;
        {
        intedit1.value:=intedit1.value+1;
        if intedit1.value=8 then Reward;
        }
      end
      else mediaplayer1.play;
    end
    else if cells[acol,arow]='1' then
    Begin
      board[acol+1,arow+1]:=0;
      cells[acol,arow]:='';
      moves:=moves-1;
      countlbl.caption:=inttostr(moves)
      {intedit1.value:=intedit1.value-1;}
    end
    else mediaplayer1.play;
  end;
end;


end.