Unit U_Flipit2;
{Copyright  © 2001, 2002, Gary Darby,  www.DelphiForFun.org
 This program may be used or modified for any non-commercial purpose
 so long as this original notice remains in place.
 All other rights are reserved
 }

{
Objective is to turn all tokens with white side
up.  Each click will turn over the clicked token
plus up to 4 adjoining adjoining tokens located
directly above, below, left or right of the
clicked token.
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, StdCtrls, U_Intlist, Spin, ComCtrls;

var boardsize:integer=4;
type
  Tmode=(play,build);
  TBoard=class(TObject)
     constructor create(newsize:integer);
     destructor destroy;  override;
   public
     b:int64; {64 bits representing 64 board positions, bit present = white side}
     size:byte; {# of rows and columns}
     sizemask:int64;
     score:byte;{score of this board}
     path:array of TPoint;  {used to keep track of the moves that got us here}
     procedure init;
     procedure assign(boardin:TBoard);
     function GetTokenColor(col,row:integer):char; {return 'B' or 'W 'for this col & row}
     procedure flipOne (c,r:integer);
     Procedure flipit(col,row:integer);
     {Function SolveIt(var maxdepthtosearch:integer):TBoard;}
     Function SolveIt2(var maxdepthtosearch:integer):TBoard;
  end;

  TForm1 = class(TForm)
    DrawGrid1: TDrawGrid;
    SolveBtn: TButton;
    ListBox1: TListBox;
    NewBoardBtn: TButton;
    ResetBtn: TButton;
    Memo1: TMemo;
    MovesLbl: TLabel;
    StopBtn: TButton;
    ModeBtn: TButton;
    Instruction: TLabel;
    SizeEdit: TSpinEdit;
    Label1: TLabel;
    StatusBar1: TStatusBar;
    New2Btn: TButton;
    NbrMovesEdit: TSpinEdit;
    procedure DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormCreate(Sender: TObject);
    procedure DrawGrid1Click(Sender: TObject);
    procedure SolveBtnClick(Sender: TObject);
    procedure NewBoardBtnClick(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
    procedure StopBtnClick(Sender: TObject);
    procedure ModeBtnClick(Sender: TObject);
    procedure SizeEditChange(Sender: TObject);
    procedure New2BtnClick(Sender: TObject);
  public
    { Public declarations }
    board:TBoard;
    saveboard:TBoard; {save the current board here in case replay is requested}
    Moves:integer;
    MaxDepthToSearch:integer;
    mode:TMode;
    procedure UpdateLabels;
    procedure reset;
    procedure Setplaymode;
  end;

var Form1: TForm1;

implementation
{$R *.DFM}

uses math, combo;

{*********************************************}
{*********** TBoard Methods ******************}
{*********************************************}

constructor TBoard.create(newsize:integer);
{create a board}
begin
  inherited create;
  size:=newsize;
  sizemask:=$4000000000000000 shr (63-size*size);;
  init;
end;

destructor TBoard.destroy;
begin
  setlength(path,0);
  inherited;
end;

{************ Init **********}
procedure TBoard.init;
{Initialize the board}
begin
  b:=$7FFFFFFFFFFFFFFF;
  score:=size*size;
  setlength(path,0)
end;

{***************** Assign ************}
procedure tboard.assign(boardIn:TBoard);
{assign boardin property values to self}
var i:integer;
begin
  size:=boardIn.size;
  b:=boardin.b;
  score:=boardin.score;
  sizemask:=$4000000000000000 shr (63-size*size);;
  setlength(path,length(boardin.path));
  if length(path)>0
  then for i:= 0 to high(boardin.path) do path[i]:=boardin.path[i];
end;

{****************** FlipOne **************}
procedure TBoard.flipOne (c,r:integer);
  {flip one token}
  var
    mask:int64;
    index:integer;
  begin
    index:=c+size*r;
    {shift 1 bit over so that it reflects size of board}
    {mask:=$4000000000000000 shr (63-size*size);  }
    mask:=sizemask shr index; {now shift it over to reflect col and row being flipped}
    b:=b xor mask; {flip it}
    if b and mask>0 then inc(score) else dec(score); {adjust score}
  end;


{************* FlipIt ****************}
Procedure TBoard.flipit(col,row:integer);
{Flip the token at a particular column and row}
{Plus the ones above, below, left and right - if they exist}
begin
    flipone(col,row);
    if col<size-1 then flipone(col+1,row);
    if col>0 then flipone(col-1,row);
    if row<size-1 then flipone(col,row+1);
    if row>0 then flipone(col,row-1);
end;


(*  Original solveit version - too slow over 4X4} 
{****************** SolveIt **************}
Function TBoard.SolveIt(var maxdepthtosearch:integer):TBoard;
{breadth first search for solutions}
var
  boardList:TIntlist; {Integer list eqiuivalent of TStringList}
  i,j,k,next:integer;
  temp,temp2:TBoard;
  depth:integer;
begin
  result:=nil;
  BoardList:=TIntlist.create;
  Boardlist.addobject(b,self);
  if score=size*size then result:=self  {done!}
  else
  begin
    {process each board in the list, adding all legal next moves not yet in  the list}
    next:=0;
    depth:=1;
    while    (next<boardlist.count) and (result=nil)
         and (depth<maxdepthtosearch)  do
    begin
      temp:=TBoard(boardlist.objects[next]);  {get next entry}
      {generate next move boards}
      depth:=length(temp.path)+1;
      with temp do
      for i:=0 to size-1 do
      begin
        for j:=0 to size-1 do
        begin
          temp2:=TBoard.create(size);
          temp2.assign(temp);
          temp2.flipit(i,j); {simulate click on each token}
          k:=boardlist.indexof(temp2.b); {have we been here before?}
          if k<0 then {if not, than add it}
          begin
            boardlist.addobject(temp2.b,temp2);
            setlength(temp2.path, length(temp2.path)+1); {increase the path length}
            temp2.path[high(temp2.path)]:=point(i,j); {and add the move that got us here}
            If temp2.score=size*size then {if they are all white}
            begin
              result:=temp2;  {done!}
              break;
            end;
          end
          else temp2.free;
        end;
        if result<>nil then break;
      end;
      inc(next);
      application.processmessages; {let stop indicator get set if requested}
    end;
  end;
  {free up all unused boards, etc.}
  for i:= boardlist.count-1 downto 1 do
  begin
      if (result=nil) or (boardlist[i]<>result.b)
      then
      begin
        TBoard(boardlist.objects[i]).free;
      end;
      boardlist.delete(i);
  end;
  boardlist.free;
end;
*)


{****************** SolveIt2 **************}
Function TBoard.SolveIt2(var maxdepthtosearch:integer):TBoard;
{try generating all possible solution - since order of moves does not matter }
var
  i,j,k:integer;
  n:int64;
  savescore,r,c:integer;
  solved:boolean;
  count,maxcount:int64;
begin
  n:=b; {get the starting board configuration}
  savescore:=score;
  solved:=false;
  form1.moveslbl.visible:=true;
  for i:= 1 to min(maxdepthtosearch, size*size) do
  begin
    if solved then break;
    combos.setup(i,size*size, combinations);
    maxcount:=combos.getcount;
    count:=0;
    while (combos.getnextcombo) and (not solved) and (maxdepthtosearch>0) do
    begin
      b:=n; {get the starting board configuration}
      score:=savescore;
      inc(count);
      if count mod 1024 =0 then
      begin
        form1.instruction.caption:='Checking '+inttostr(count) +' of '
             +inttostr(maxcount)
             +' games of length '+inttostr(i);
        application.processmessages;
      end;
      for j:=1 to i do {flip the selected bits}
      begin
        r:=(combos.selected[j]-1) div size;
        c:=(combos.selected[j]-1) mod size;
        flipit(c,r);
        if score=size*size then
        begin
          solved:=true;
          {showmessage('solved');}
          setlength(path,j);
          for k:=0 to j-1 do
          with path[k] do
          begin
            y:=(combos.selected[k+1]-1) div size;
            x:=(combos.selected[k+1]-1) mod size;
          end;
          break;
        end;
        if solved then break;
      end;
    end;
  end;
  b:=n;
  score:=savescore;
  if solved then result:=self else result:=nil;
end;




 (*
Function TBoard.SolveIt(var maxdepthtosearch:integer):TBoard;
{depth first search for solutions}
var
  i,j,k,next:integer;
  temp,temp2:TBoard;
  depth:integer;
begin
  result:=nil;
  if score=size*size then result:=self  {done!}
  else
  begin
    temp:=TBoard.create(size);
    temp.assign(self);
    for i:=0 to size-1 do
    begin
      for j:=0 to size-1 do
      begin
        temp.flipit(i,j); {simulate click on each token}
        k:=boardlist.indexof(temp.b); {have we been here before?}
        if k<0 then {if not, than add it}
        begin
          index:=boardlist.addobject(temp.b,temp);
          setlength(temp2.path, length(temp2.path)+1); {increase the path length}
          {temp.path[high(temp.path)]:=point(i,j);} {and add the move that got us here}
          If temp.score=size*size then {if they are all white}
          begin
            result:=temp;  {done!}
            break;
          end;
          end
          else
          begin
            temp.free;
            boardlist.delete(index);
          end;
        end;
        if result<>nil then break;
      end;
      inc(next);
      application.processmessages; {let stop indicator get set if requested}
    end;
  end;
  {free up all unused boards, etc.}
  for i:= boardlist.count-1 downto 1 do
  begin
      if (result=nil) or (boardlist[i]<>result.b)
      then
      begin
        TBoard(boardlist.objects[i]).free;
      end;
      boardlist.delete(i);
  end;
  boardlist.free;
end;

*)

{***************** GetBoardColor *************}
function TBoard.GetTokenColor(col,row:integer):char;
{ Return the value of a board position, B=black, W=white}
var
  index:integer;
  mask:int64;
begin
  Index:=col+size*row;
  mask:=$4000000000000000 shr (index+63-size*size);
  if b and mask>0 then result:='W'
  else result:='B';
end;

{*********************************************}
{************ TForm Methods ******************}
{*********************************************}

{************  DrawGridDrawCell *******************}
procedure TForm1.DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
{Draw a black or white token in this grid position}
begin
   with DrawGrid1.canvas do
   begin
     brush.color:=clgreen;
     fillrect(rect);
     If board.GetTokenColor(acol,arow)='W' then brush.color:=clwhite
     else brush.color:=clblack;
     ellipse(rect);
   end;
end;

{**************** FormCreate ******************}
procedure TForm1.FormCreate(Sender: TObject);
begin
  randomize;
  boardsize:=sizeedit.Value;
  with drawgrid1 do
  begin
    colcount:=boardsize;
    rowcount:=boardsize;
    defaultcolwidth :=width div  colcount -2;
    defaultrowheight:=height div rowcount -2;
  end;
  board:=TBoard.create(boardsize);
  saveboard:=TBoard.create(boardsize);
  board.init;
  newboardbtnclick(sender);
  saveboard.assign(board);
  moves:=0;
  updatelabels;
  stopbtn.bringtofront;  {a big stop button, normally invisible but set to back at
                          design time to ease viewing other components}
  mode:=play;
end;

{************** DrawGridClick ********************}
procedure TForm1.DrawGrid1Click(Sender: TObject);
{User clicked to make a move}
begin

  with drawgrid1 do
  if mode=play then
  begin
    board.flipit(col,row);
    inc(moves);
    updatelabels;
  end
  else
  begin
    board.flipOne(col,row);
    saveboard.flipone(col,row);
  end;
  drawgrid1.invalidate;
end;


{*************** SolvebtnClick ****************}
procedure TForm1.SolveBtnClick(Sender: TObject);
{Auto-solve}
var
  solution:TBoard;
  i:integer;
begin
  moves:=0;
  updatelabels;
  setplaymode;
  listbox1.clear;
  screen.cursor:=crHourGlass;
  stopbtn.visible:=true;
  MaxDepthToSearch:=20;
  application.processmessages;
  solution:=board.SolveIt2(MaxDepthToSearch); {get the solution}
  screen.cursor:=crdefault;
  stopbtn.visible:=false;;
  If solution<>nil then {solution found}
  Begin
    {set up to display solution and animate moves}
    listbox1.items.add('Solved in '+inttostr(length(solution.path))+' moves');
    with solution do
    for i:= 0 to high(path) do
    begin
      listbox1.items.add('Move '+inttostr(i+1)+': (Col:'+inttostr(path[i].x+1)
                          +'  Row:'+inttostr(path[i].y+1)+')');
      board.flipit(path[i].x,path[i].y);
      inc(moves);
      updatelabels;
      drawgrid1.invalidate;
      application.processmessages;
      sleep(500);
    end;
    If solution<>board then solution.free;
  end
  else showmessage('No solution found');
end;



{**************** NewBoardBtnClick ***************}
procedure TForm1.NewBoardBtnClick(Sender: TObject);
var
  i, flips :integer;
begin
  setplaymode;
  with board do
  begin
    init; {clear the board}
    {and make a large random nbr of valid moves - ensures board has a solution}
    flips:=900+random(9);
    for i:= 1 to flips do flipit(random(size),random(size));
  end;
  reset;
  listbox1.clear;
end;

{******************* ResetBtnClick *******************}
procedure TForm1.ResetBtnClick(Sender: TObject);
begin
  setplaymode;
  board.assign(Saveboard);
  reset;
end;

{*********************** StopBtnClick ****************}
procedure TForm1.StopBtnClick(Sender: TObject);
begin
  MaxDepthToSearch:=0;
end;

{****************** ModeBtnClick ****************}
procedure TForm1.ModeBtnClick(Sender: TObject);
begin
  if mode=play then
  begin
    mode:=build;
    instruction.caption:='Click to flip single tokens'
              +#13+'Caution - boards created in this manner may be unsovable!'
              +#13+'Press button again to re-enter play mode';
    Modebtn.caption:='Enter Play mode';
    board.init;    {clear board and saveboard}
    saveboard.init;
    drawgrid1.invalidate;
  end
  else setplaymode;
end;

{********************** UpdateLabels ******************}
procedure TForm1.updatelabels;
begin
  moveslbl.caption:='Moves: '+inttostr(moves);
end;

{**************** Reset *******************}
procedure TForm1.reset;
begin
  moves:=0;
  drawgrid1.invalidate;
  saveboard.assign(board);
  updatelabels;
end;

{****************** SetPlayMode ****************]}
procedure TForm1.Setplaymode;
begin
  mode:=play;
  instruction.caption:='Click token to flip';
  Modebtn.caption:='Enter Build mode';
end;

{***************** SizeEditChnage **********}
procedure TForm1.SizeEditChange(Sender: TObject);
{make a new board size}
begin
  board.free;
  saveboard.free;
  formcreate(sender);
end;
{*************** New2BtnClick **********}
procedure TForm1.New2BtnClick(Sender: TObject);
{Make a new random board that can be solved in he specified number of moves
 (or less)}
var
  i, nbrmoves :integer;
  tries, movesmade, n:integer;
  movefound:boolean;
  movesused:array of boolean;
begin
  setplaymode;
  with board do
  begin
    init; {clear the board}
    nbrmoves:= nbrmovesedit.value;
    movesmade:=0;
    tries:=0;
    setlength(movesused, size*size);
    for i:= 0 to high(movesused) do movesused[i]:=false; {keep track to moved made}
    for i:= 1 to nbrmoves do
    begin
      movefound:=false;
      tries:=0; {we'll try 100 times to find a random move}
      while (tries<100) and (not movefound)do
      begin
        n:=random(size*size);
        if not movesused[n] then
        begin
          movefound:=true;
          movesused[n]:=true;
          flipit(n mod size{column}, n div size{row});
          inc(movesmade);
        end;
        inc(tries);
      end;
    end;
    if movesmade<>nbrmoves
    then
    begin
      showmessage('Only '+inttostr(movesmade)+ ' moves found.');
      nbrmovesedit.value:=movesmade;
    end;
  end;
  reset;
  listbox1.clear;
end;
end.