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.