unit U_MensaTiles;
{Copyright 2002, Gary Darby, Intellitech Systems Inc., 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
 }

{A Mensa Tiles puzzle program,  User or computer can solve problems.

A set of tiles, each with a 1 to 5 digit number and totalling 25 digits are
provided or input.  Each tile is oriented vertically or horizontally.  The
objective is to arrange the tiles on a 5X5 grid so that the 5 numbers that
appear horizontally in the rows match the 5 numbers read vertically by column.
}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, inifiles, StdCtrls, ComCtrls, ExtCtrls;

type

{A tile class derived from TstringGrid}
TTileObj = class(TStringgrid)
private
constructor create(Aowner:TForm); reintroduce;
public
tilenbr:integer;{for speed - the position of this tile in the TTile array}
moveto:TPoint;  {top/left coordinates of this tile when it is placed
                     on the board}
end;

  TTiles= Array of TTileObj;  {Array of input tiles}

TForm1 = class(TForm)
    PageControl1: TPageControl;
    SetUpSheet: TTabSheet;
    PlaySheet: TTabSheet;
    PlayGrid: TStringGrid;
    HTileGrid: TStringGrid;
    Label1: TLabel;
    Label2: TLabel;
    VTilegrid: TStringGrid;
    SaveBtn: TButton;
    LoadBtn: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Label3: TLabel;
    SolveBtn: TButton;
    ResetBtn: TButton;
    Introsheet: TTabSheet;
    Image1: TImage;
    Panel1: TPanel;
    Memo1: TMemo;
    Label4: TLabel;
    Memo2: TMemo;
    StopBtn: TButton;
    HintBtn: TButton;
procedure FormActivate(Sender: TObject);
procedure DragOverProc(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
procedure DragDropProc(Sender, Source: TObject; X, Y: Integer);
procedure LoadBtnClick(Sender: TObject);
procedure SaveBtnClick(Sender: TObject);
procedure PageControl1Change(Sender: TObject);
procedure DrawCellProc(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
procedure SolveBtnClick(Sender: TObject);
procedure ResetBtnClick(Sender: TObject);
procedure PlaySheetDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
procedure PlaySheetDragDrop(Sender, Source: TObject; X, Y: Integer);
procedure TileMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
procedure GridKeyPress(Sender: TObject; var Key: Char);
procedure PageControl1Changing(Sender: TObject;
var AllowChange: Boolean);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure StopBtnClick(Sender: TObject);
procedure HintBtnClick(Sender: TObject);
public
{Public declarations }
dragging:boolean;
    offsetx, offsety:integer;
    savecolor:TColor;
    filename:string;
    board:array of array of char;
    tiles:TTiles;
    modified:boolean;
    tilesOK:boolean; {tiles are 1-5 chars long and 25 characters in total}
Solutionfound:boolean;
procedure tryfits(N:integer);  {recursive tile search procedure}
function  tilefits(i,j,n:integer):boolean;
procedure addtile(i,j,n:integer);
procedure removetile({i,j,}n:integer);
procedure solved;
procedure loadfile(fname:string);
procedure savefile(fname:string);
procedure inittile(dir:char;t:TTileobj; newleft, newtop:integer; s:string);
procedure movetile(i:integer);
end;

var   Form1: TForm1;

const boardsize=5;

implementation

{$R *.DFM}

{******************* TTileObj.Create ************}
constructor ttileObj.create(Aowner:TForm);
{Create a tile}
begin
inherited create(Aowner);
  visible:=false;
  parent:=TForm(Aowner);
  defaultcolwidth:=24;
  defaultrowheight:=24;
  dragmode:=dmmanual;
  defaultdrawing:=false;
  scrollbars:=ssNone;
  moveto.x:=-1; moveto.y:=-1; {target location when solved}
tilenbr:=-1;
end;

{****************** FormActivate ***************}
procedure TForm1.FormActivate(Sender: TObject);
{Initialization stuff}
begin
doublebuffered:=true;
  setlength(board, boardsize,boardsize);
  pagecontrol1.activepage:=Introsheet;
  modified:=false;
  opendialog1.initialdir:=extractfilepath(application.exename);
  savedialog1.initialdir:=opendialog1.initialdir;
{Move the Stop button in behind the Solve button so it will be
   hidden until we brig it back on top (while searching for a solution)}
{This could be done at design time, except it is then hard for the programmer
   to detect that it exists at all!}
stopbtn.top:=solvebtn.top;
  stopbtn.left:=solvebtn.left;
  stopbtn.sendtoback;
end;

{****************** TryFits **************}
procedure TForm1.tryfits(N:integer);
{Recursive search for solution path }
var i,j:integer;
begin
if tag<>0 then exit;
with tiles[N] do
begin
i:=0;
    j:=0;
while (i<=boardsize-colcount) and (j<=boardsize-rowcount) do
begin
if tilefits(i,j,N)   then
begin
addtile(i,j,N);
if N<high(tiles) then
begin
tryfits(N+1);
{remove the tile to continue search unless it's solved!}
if not solutionfound then removetile(N);
end
else
begin
{solved;}
solutionfound:=true;
          break;
end;
end;
      inc(j);
if j>boardsize-rowcount then
begin
j:=0;
        inc(i);
end;
end;
end;
end;

{***************** Tilefits ****************}
function TForm1.tilefits(i,j,n:integer):boolean;
{Test if tile N will fit on the board with topleft corner at [i,j]}
{'Fit' means spaces are not occupied and the diagonal slots are
 empty or match the values on this tile}
var   c,r:integer;
begin
result:=true;
if (i>=0) and (j>=0) and (n>=0) then
with tiles[n] do
begin
for c:= 0 to colcount-1 do
begin
for r:=0 to rowcount-1 do
if (i+c < boardsize) and (j+r<boardsize) then
begin
if (board[i+c,j+r]=' ') and
((board[j+r,i+c]=' ') or (board[j+r,i+c]=cells[c,r][1]{tile[c,r]}))
then
else
begin
result:=false;
          break;
end;
end
else result:=false;
if result=false then break;
end;
end;
end;

{******************* Addtile ***********}
procedure TForm1.addtile(i,j,n:integer);
{Add tile N to the board at [i,j] }
var   c,r:integer;
begin
with tiles[n] do
begin
for c:= 0 to colcount-1 do for r:=0 to rowcount-1
do board[i+c,j+r]:=cells[c,r][1];
    moveto.x:=i;
    moveto.y:=j;
end;
end;

{*************** RemoveTile ***************}
procedure TForm1.removetile({i,j,}n:integer);
{remove a previously added tile , used when backtracking}
var   c,r:integer;
      i,j:integer;
begin
if n>=0 then
with  tiles[n] do
if (moveto.x>=0) and (moveto.y>=0) then
begin
i:=moveto.x; j:=moveto.y;
for c:= 0 to colcount-1 do for r:=0 to rowcount-1 do  board[i+c,j+r]:=' ';
    moveto.x:=-1;
    moveto.y:=-1;
end;
end;

procedure TForm1.Movetile(i:integer);
{animated tile move for tile i}
var
incr:integer;
  r:Trect;
  p:tpoint;
begin
with tiles[i] do
begin
r:=playgrid.cellrect(moveto.x, moveto.y); {get pixel coordinates from
                                               target column and row}
{cellrect coordinates are relative to playgrid, so need to adjust them to
     page coordinates}
p.x:=playgrid.left+r.left;
    p.y:=playgrid.top+r.top;
{Move horizontally a couple of pixels at a time}
incr:=2;  if left>p.x then incr:=-incr;
if application.mainform.tag=0 then  {tag>0 ==> user wants to stop, so skip animation}
while abs(left-p.x)>abs(incr) do
begin
left:=left+incr;
      sleep(5); {wait 5 milliseconds}
update;   {show the move}
end;
    left:=p.x; {position exactly}
application.processmessages;
{Now move vertically}
incr:=2; if top > p.y then incr:=-incr;
if application.mainform.tag=0 then  {tag>0 ==> user wants to stop, so skip animation}
while abs(top-p.y)>abs(incr) do
begin
top:=top+incr;
      sleep(5);
      update; {Show the move}
end;
    top:=p.y;
    application.processmessages;
end;
end;


{************** Solved *********}
Procedure TForm1.solved;
{called when the solution is found - animate moving the tiles
 onto the board}
var

i:integer;

begin
for i := 0 to high(tiles) do {move tiles to final resting place}
with tiles[i] do movetile(i);
end;


{**************** DragOverProc ******************}
procedure TForm1.DragOverProc(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
{if the mouse is positioned over the playgrid, then we want to accept
 only if the tile will fit at its current location without overlappeing
 other tiles already placed (except that it can overlap itself).
 Other wise allow dropping}
var
g, g2:TGridCoord;
begin
accept:=false;
if (source is ttileobj) and ((sender=playgrid) or (sender=source))
then
begin
{is cursor over playgrid}
if sender=playgrid then
begin
g:=playgrid.mousecoord (x,y);
end
else
with sender as ttileobj do
begin
g:=mousecoord(x,y);
      g2:=playgrid.mousecoord(left-playgrid.left,top-playgrid.top);
      g.x:=g.x+g2.x;
      g.y:=g.y+g2.y;
end;
if (g.x<0) or (g.y<0)  {we're not over the playgrid}
then accept:=true
else  {we are over playgrid - make sure that entire tile wil fit}
with source as ttileobj do
if (g.x+ colcount<= playgrid.ColCount) and (g.y+rowcount<=playgrid.rowcount)
then accept:=true;
end;
end;

{******************** DragDropProc ****************}
procedure TForm1.DragDropProc(Sender, Source: TObject; X,
  Y: Integer);
{Called when a tile is dropped on the playgrid}
var
xx,yy:integer;
  rr:TRect;
  g,g2:TGridCoord;
  AllOn, issolved:boolean;
  i,j:integer;
begin
if (source is tTileObj) and (Sender is TStringgrid)
then with source as tTileObj do
begin
if sender=playgrid then   g:=playgrid.mousecoord (x,y)
else
with sender as ttileobj do
begin
g:=mousecoord(x,y);
      g2:=playgrid.mousecoord(left-playgrid.left,top-playgrid.top);
      g.x:=g.x+g2.x;
      g.y:=g.y+g2.y;
end;
with playgrid do  rr:=cellrect(g.x,g.y);
    xx:=playgrid.left;
    yy:=playgrid.top;
    left:=rr.left+xx;
    top:=rr.top+yy;
    moveto.x:=g.x;
    moveto.y:=g.y;
{check to see if all tiles are on the playgrid and if so,
     if the puzzle is solved}
for i:=0 to boardsize-1 do for j:=0 to boardsize-1 do board[i,j]:=' ';
    i:=0; allOn:=true; issolved:=true;

while (i<high(tiles)) and (allon) do
with tiles[i] do
begin
if (left<playgrid.left) or (top<playgrid.top)
or (left>playgrid.left+playgrid.width)
or (top>playgrid.top+playgrid.height)
then allon:=false
else
begin
if tilefits(moveto.x,moveto.y,i) then addtile(moveto.x,moveto.y,i)
else issolved:=false;
        inc(i);
end;
end;
if allon then
begin
if issolved then showmessage('Congratulations!  You are ready for Mensa!')
else Showmessage('Not yet, don''t give up though');
end;
end;
end;


{***************** LoadBtnCLick ***********}
procedure TForm1.LoadBtnClick(Sender: TObject);
{Call loadfile when clicked}
var
r:integer;
begin
r:=mryes;
if modified then
begin
r:=messagedlg('Save current set of tiles first?',mtconfirmation,
                            [mbYes,MbNo, mbcancel],0);
if r=mrYes then  savebtnclick(sender);
end;
if (r<>mrcancel) and opendialog1.execute then loadfile(opendialog1.filename);
end;

{*************** SaveBtnClick **************}
procedure TForm1.SaveBtnClick(Sender: TObject);
{Call savefiel when clicked }
begin
if savedialog1.execute then savefile(savedialog1.filename);
end;

{**************** Savefile ************}
procedure TForm1.savefile(fname:string);
{Save the current set of tiles }
var
ini:TInifile;
  i:integer;
begin
filename:=fname;  {save filename}
ini:=TInifile.create(fname);
with ini do
begin
with HTilegrid do
begin
writeinteger('Horizontals','Count',rowcount);
for i:=0 to rowcount-1 do
writestring('Horizontals','Nbr'+inttostr(i),cells[0,i]);
end;
with VTilegrid do
begin
writeinteger('Verticals','Count',rowcount);
for i:=0 to rowcount-1 do
writestring('Verticals','Nbr'+inttostr(i),cells[0,i]);
end;
end;
  ini.free;
  modified:=false;
end;

{************* Loadfile *************}
procedure TForm1.loadfile(fname:string);
{Load a set of tiles }
var
ini:TInifile;
  i,count:integer;

begin
filename:=fname;
  ini:=TInifile.create(fname);
with ini do
begin
with hTileGrid do
begin
count:=readinteger('Horizontals','Count',0);
for i:=0 to count-1 do
cells[0,i]:=readstring('Horizontals','Nbr'+inttostr(i),'');
end;

with vTileGrid do
begin
count:=readinteger('Verticals','Count',0);
for i:=0 to count-1 do
cells[0,i]:=readstring('Verticals','Nbr'+inttostr(i),'');
end;
end;
  ini.free;
  modified:=false;
end;

{*************** InitTile *****************}
procedure TForm1.inittile(dir:char;t:TTileobj; newleft, newtop:integer;s:string);
{fill in event exits, values, and location information for a tile}
var
j:integer;
begin
with t do
begin
ondragdrop:=DragdropProc;
     ondragover:=DragoverProc;
     ondrawcell:=DrawCellProc;
     onmousedown:=TileMouseDown;
     parent:=playsheet;
if dir='H' then
begin
colcount:=length(s);
       rowcount:=1;
for j:=1 to length(s) do cells[j-1,0]:=s[j];
end
else
begin
rowcount:=length(s);
       colcount:=1;
for j:=1 to length(s) do cells[0,j-1]:=s[j];
end;
     left:=newleft;
     top:= newtop;
     width:=(defaultcolwidth+1)*colcount;
     height:=(defaultrowheight+1)*rowcount;
end
end;

{*************** PageControl1Changing ************}
procedure TForm1.PageControl1Changing(Sender: TObject;
var AllowChange: Boolean);
var
i:integer;
    s:string;
    sum:integer;
    r:integer;
begin
{Leaving a tabsheet, if it's SetupSheet then make sure tiles are valid.}
If pagecontrol1.activepage=setupsheet then
begin
tilesOK:=true;
    sum:=0;
for i:=0 to htilegrid.rowcount-1 do
with htilegrid do
begin
s:=trim(cells[0,i]);
if length(s)>5 then
begin
showmessage('Horizontal tile '+ cells[0,i] + 'exceeds 5 characters');
        TilesOK:=false;
end;
      sum:=sum+length(s);
end;
for i:=0 to vtilegrid.rowcount-1 do
with vtilegrid do
begin
s:=trim(cells[0,i]);
if length(s)>5 then
begin
showmessage('Vertical tile '+ cells[0,i] + 'exceeds 5 characters');
        TilesOK:=false;
end;
      sum:=sum+length(s);
end;
if sum <> 25 then
begin
showmessage('Total number of digits on all tiles must be 25, found '+inttostr(sum));
      tilesOK:=false;
end
else
if modified then
begin
r:=messagedlg('Save current set of tiles first?',mtconfirmation,
                            [mbYes,MbNo, mbcancel],0);
if r=mrYes then  savebtnclick(sender);
end;
end;
end;

{******************* PageControlChange **************}
procedure TForm1.PageControl1Change(Sender: TObject);
{When entering the playsheet, build a new set of tiles based on
 SetupSheet tile definitions}
var
i,j:integer;
  s:string;
  lasttop:integer; {top of lowest horizontal tile}
nbrtiles:integer;
begin
if Pagecontrol1.activepage=Playsheet then
if tilesOK then
begin
{drawtiles for dragging}
if length(tiles)>0  {free old tiles}
then for i:=0 to high(tiles) do  with tiles[i] do free;
     setlength(tiles,htilegrid.rowcount+vtilegrid.rowcount); {maxsize}
nbrtiles:=0;
     lasttop:=0;{used as top point for vertical tiles, move down as
                 horizontal tiles are added}
with htilegrid do
for i:= 0 to rowcount-1 do
if trim(cells[0,i])<>'' then
begin
s:=trim(cells[0,i]);
       tiles[nbrtiles]:=TTileObj.create(self);
       tiles[nbrtiles].visible:=false;
       inc(nbrtiles);
with tiles[nbrtiles-1] do
begin
inittile('H',tiles[nbrtiles-1],pagecontrol1.left+20,pagecontrol1.top+30*(i+1),s);
         tilenbr:=nbrtiles-1;
         lasttop:=top;
end;
end;
with vtilegrid do
for i:= 0 to rowcount-1 do
if trim(cells[0,i])<>'' then
begin
s:=trim(cells[0,i]);
if s<>'' then
begin
tiles[nbrtiles]:=TTileObj.create(self);
         tiles[nbrtiles].visible:=false;
         inc(nbrtiles);
with tiles[nbrtiles-1] do
begin
tilenbr:=nbrtiles-1;
           inittile('V',tiles[nbrtiles-1],pagecontrol1.left+30*(i+1),lasttop+50,s);
end;
end;
end;
     setlength(tiles,nbrtiles);
for i:= 0 to nbrtiles-1 do tiles[i].visible:=true;
for i:=0 to boardsize-1 do for j:=0 to boardsize-1 do board[i,j]:=' ';
     tag:=0;
     solutionfound:=false;
end
else showmessage('Tile set is invalid - return to Setup page and make corrections');
   application.processmessages;
end;

{************ DrawCellProc ***************}
procedure TForm1.DrawCellProc(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
{Draw cells ourselves to get rid of selected cell coloring}
begin
with sender as TStringgrid do
canvas.textout(rect.left+4,rect.top+4,cells[acol,arow]);
end;

{******************* SolveBtnClick ***********}
procedure TForm1.SolveBtnClick(Sender: TObject);
{Solve button on playsheet was clicked }
begin
pagecontrol1change(sender); {reset the page}
screen.cursor:=crhourglass;
  tag:=0;  {Stop flag, stop solving if >0}
stopbtn.bringtofront;
  resetbtn.enabled:=false;
  setupsheet.enabled:=false;
  introsheet.enabled:=false;
  tryfits(0);  {Start recursive solution search}
screen.cursor:=crdefault;
if (tag=0) and solutionfound then solved
else showmessage('No solution found for this set of tiles');
  stopbtn.sendtoback;
  resetbtn.enabled:=true;
  setupsheet.enabled:=true;
  introsheet.enabled:=true;
end;

{******************** HintBtnClick ***********}
procedure TForm1.HintBtnClick(Sender: TObject);
{Move a random tile into its proper place}
begin
pagecontrol1change(sender); {reset the page}
screen.cursor:=crhourglass;
  tryfits(0);  {Start recursive solution search}
if not solutionfound then showmessage('No solution possible for this set of tiles')
else
begin
solutionfound:=false;
    movetile(random(length(tiles)));
end;
  screen.cursor:=crdefault;
end;

{************* ResetBtnClick ************}
procedure TForm1.ResetBtnClick(Sender: TObject);
{Rebuil;d tile display, just as we did when playsheet was opened}
begin   pagecontrol1change(sender); end;

{******************* PlaySheetDragOver ******************}
procedure TForm1.PlaySheetDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
{allow a tile to be dropped back on the sheet, outside of the playgrid}
begin   accept:=true; end;

{************ PlaySheetDragDrop ************}
procedure TForm1.PlaySheetDragDrop(Sender, Source: TObject; X, Y: Integer);
{Drop a tile back on the Playsheet page}
begin
if source is ttileobj then
with source as ttileobj
do
begin
left:=x;
    top:=y;
    moveto.x:=-1;
    moveto.y:=-1;
end;
end;

{************ TileMouseDown *****************}
procedure TForm1.TileMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
{Used to start dragging when the mouse moves on the tile with a button down}
begin
if sender is ttileobj then TTileobj(sender).begindrag(false);
end;

{********************* GridKeyPress ****************}
procedure TForm1.GridKeyPress(Sender: TObject; var Key: Char);
{set modified flag to warn user to save before leaving}
begin  modified:=true  end;

{********************** FormCloseQuery *************}
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
{set flag to stop any solving process and allow close}
begin
tag:=1;
  canclose:=true;
end;

procedure TForm1.StopBtnClick(Sender: TObject);
{set flag to stop solving or showing animation}
begin   tag:=1; end;


end.