Const
  {These are the offsets from current locations to all 8 valid knight moves}
  Offsets: array[1..8] of Tpoint= ((x:-2;y:-1),(x:-2;y:+1),(x:-1;y:-2),(x:-1;y:+2),
                                   (x:+1;y:+2),(x:+1;y:-2),(x:+2;y:+1),(x:+2;y:-1)
                                  );
type
  TBoard=class(TStringGrid)
   Private
     b: array of array of integer;
     moves:array of TPoint;  {array of moves made}
     size:integer;  {board size}
     manualplay:boolean; {true=user plays}
     movecount:integer;  {nbr of moves made}
     totmoves:integer;  {total moves tried, counting moves taken back }
     delay:integer; {ms to wait between moves when autosolving}
     closedtour:boolean;
     constructor create(Aowner:TComponent;
                       newsize:integer;
                       newlocrect:Trect );
     procedure DrawAcell(Sender: TObject; ACol, ARow: Integer;
             Rect: TRect; State: TGridDrawState);
     procedure Clicked(Sender:Tobject);
     function  IsValidMove(newcol,newrow:integer):boolean;
     procedure MakeMove(newcol,newrow:integer);
     function  Canundo:boolean;
     procedure UndoMove;
     function  PossibleMoves(newcol,newrow:integer):integer;
     function  SolveFrom(newcol,newrow:integer):boolean;
  end;
 
  TForm1 = class(TForm)
    Memo1: TMemo;
    SolveBtn: TButton;
    PlayBtn: TButton;
    Panel1: TPanel;
    ColEdit: TSpinEdit;
    RowEdit: TSpinEdit;
    Label1: TLabel;
    Label2: TLabel;
    SolvingPanel: TPanel;
    Label4: TLabel;
    Speedbar: TTrackBar;
    StopBtn: TButton;
    StatusBar1: TStatusBar;
    ClosedBox: TCheckBox;
    Moveslbl: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure PlayBtnClick(Sender: TObject);
    procedure SolveBtnClick(Sender: TObject);
    procedure SpeedbarChange(Sender: TObject);
    procedure StopBtnClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure ClosedBoxClick(Sender: TObject);
  public
    { Public declarations }
    board:TBoard;
    Procedure makeboard;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.DFM}
{****************** TBoard Methods ********************}
 
Constructor TBoard.create(Aowner:TComponent;
                       newsize:integer;
                       newlocrect:Trect
                       );
var   i,j:integer;
begin
   inherited create(Aowner);
   if Aowner is TWinControl
   then parent:=TWincontrol(Aowner);
   scrollbars:=ssNone;
   size:=newsize;
   colcount:=size; fixedcols:=0;
   rowcount:=size; fixedrows:=0;
   top:=newlocrect.top;
   left:=newlocrect.left;
   width:=newlocrect.right-left;
   defaultcolwidth:= (width-size) div size-1;
   defaultrowheight:=defaultcolwidth;
   width:=(defaultcolwidth+1)*size+3; {trim width to fit squares}
   height:=width;
   setlength(b,newsize,newsize);
   {initialize board to zeros}
   for i:= 0 to size-1 do for j:= 0 to size-1 do  b[i,j]:=0;
   setlength(moves,size*size+1);
   movecount:=0;
   totmoves:=0;
   OnDrawCell:=DrawACell;
   OnClick:=Clicked;
   canvas.font.size:=12;
   canvas.font.name:='Courier'; {fixed font size}
end;
 
procedure TBoard.DrawACell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
 {OnDrawcell exit}
var
  i,j:integer;
  s:string;
begin
  i:=acol;
  j:=arow;
  with Sender as TBoard do
  begin
    {make chessboard coloring }
    if (i mod 2) = (j mod 2)  {odd row&column or even row&column}
    then Canvas.Brush.Color := clsilver
    else canvas.brush.color:=clblack;
    Canvas.FillRect(Rect);
    if b[i,j]>0
    then
    with canvas do
    begin
      font.size:=12;
      font.style:=[fsbold];
      if (i mod 2) = (j mod 2) then font.color:=clblack
      else font.color:=clwhite;
      s:=format('%2d',[b[i,j]]);
      canvas.textout(rect.left +3 , rect.top+3,s);
    end;
  end;
end;
 
Procedure TBoard.clicked;
{User clicked a cell}
begin
  if not manualplay then exit;
  If isValidmove(col,row) then makemove(col,row)
  else if canundo then undomove
  else beep;
end;
 
Function TBoard.IsValidMove(newcol,newrow:integer):boolean;
 
  {There are 8 possible move positions
   relative to lastmove location. They are
    col   row
    ---   ---
     -2    +1
     -2    -1
     -1    -2
     -1    +2
     +1    +2
     +1    -2
     +2    +1
     +2    -1
   }
   {To be valid, col+newcol and row+newrow must match one of these
    and board must be unoccupied at that loacation}
 
var
  i:integer;
  test:Tpoint;
  OK:boolean;
  pcol,prow:integer;
begin
  If (newcol<0) or (newcol>=size) or (newrow<0) or (newrow>=size)
  then OK:=false
  else
  If movecount=0 then OK:=true {1st move can be anywhere}
  else
  begin   {get previous move}
    test.x:=moves[movecount].x-newcol;
    test.y:=moves[movecount].y-newrow;
    OK:=false;
    for i:=  1 to 8 do  {to be OK, it has to be to valid location}
    if (test.x=offsets[i].x)  and (test.y=offsets[i].y) then
    begin
      OK:=true;
      break;
    end;
    {and location has to be unoccupied}
    If OK and (b[newcol,newrow]<>0) then OK :=false;
 
    {12/20/02 - add code for closed tours - move must not make the starting
     position unreachable unless it is the last move}
    if closedtour and OK  and ((newcol<>0) or (newrow<>0)) and (movecount<size*size-1) then
    begin
      b[newcol,newrow]:=1;
      ok:=false;
      for i:= 1 to 8 do  {count how many next moves exist}
      begin
        pcol:=moves[1].x+offsets[i].x;
        prow:=moves[1].y+offsets[i].y;
        if (pcol>=0) and (pcol<size) and (prow>=0)and(prow<size) and (b[pcol,prow ]=0)
        then
        begin
          Ok:=true;
          break;
        end;
      end;
       b[newcol,newrow]:=0;
    end;
  end;
  result:=OK;
end;
 
Procedure TBoard.makemove(newcol,newrow:integer);
{make a move}
begin
  col:=newcol;
  row:=newrow;
  inc(movecount);   {count the move}
  {add move to moves array}
  with moves[movecount] do
  begin
    x:=col;
    y:=row;
  end;
  {fill in the move number to board and display}
  b[col,row]:=movecount;
  cells[col,row]:=inttostr(movecount);
end;
 
Function TBoard.Canundo:boolean;
begin
  result:=(b[col,row]=movecount); {can only undo last move}
end;
 
Procedure TBoard.UndoMove;
{undo a move}
begin
  If movecount>0 then
  with moves[movecount] do
  begin
    b[x,y]:=0;  {0 the board cell}
    cells[x,y]:=''; {blank the display cell}
    dec(movecount); {decrease the count}
  end;
end;
 
Function TBoard.possiblemoves(newcol,newrow:integer):integer;
{ Return a count of valid moves from this location}
var
  i,count:integer;
begin
  count:=0;
  If isvalidmove(newcol,newrow) then
  begin
    makemove(newcol,newrow);  {make the trial move}
    for i:= 1 to 8 do  {count how many next moves exist}
      if isvalidmove(newcol+offsets[i].x, newrow+offsets[i].y) then inc(count);
    undomove;  {and undo the move}
  end;
  result:=count;
end;
 
 
Function TBoard.solvefrom(newcol,newrow:integer):boolean;
{generate all possible next moves, and count the number of next moves from
     each position.  Pick one with lowest value and move there}
    {If the lowest number of next moves is 0 and that would not be the
    last move then this is a bad path. Need to backtrakc and try another path
    - continue until solved or all paths have been tried}
type
  TMoverec = record
    pcol,prow,nbrmoves:integer;
    distfromstart:single;
  end;
var
  possibles:array [1..8] of TMoveRec;
  i:integer;
 
  function dist(col,row:integer):single;
  begin
    result:=sqr(moves[1].x-col)+sqr(moves[1].y-row);
  end;
 
 
  Procedure sortmoves;
  {sort the possible moves by increasing next move count
   then by distance from staring position}
  var
    i,j:integer;
 
    procedure swap(i,j:integer);
      var Hrec:TMoverec;
      begin
        Hrec:=possibles[i];
        possibles[i]:=possibles[j];
        possibles[j]:=hrec;
      end;
 
  begin
    begin
      for i:= 1 to size-1 do
      for j:= i+1 to size do
      If possibles[i].nbrmoves>possibles[j].nbrmoves
      then swap(i,j)
      else if (possibles[i].nbrmoves=possibles[j].nbrmoves) and
               (possibles[i].distfromstart<possibles[j].distfromstart)
      then swap(i,j);
    end;
  end; {Sortmoves}
 
  begin  {Solvefrom}
  {Update display and wait awhile}
  application.processmessages;
  sleep(delay);
  {Done?}
 
  If movecount=size*size then result:=true
  else
  {If not, then generate next moves for all possible moves from here}
  begin
    result:=false;
    If manualplay then exit;
    for i:= 1 to size do
    with possibles[i] do
    begin
      pcol:=newcol+offsets[i].x;
      prow:=newrow+offsets[i].y;
      nbrmoves:=PossibleMoves(pcol,prow);
      distfromstart:=dist(pcol,prow);
      {if no moves possible from this location,
       then make sure it sorts to end of array.
       Not really necessary, just saves the time of
       checking and rejecting those cases
      }
      if nbrmoves=0 then nbrmoves:=size+1;
    end;
    {Sort them by increasing possible moves - Warnsdorff heuristic}
    sortmoves;
    {Now, run through all the possibilities
       - making recursive call for valid ones}
    {backtrack by calling undomove for paths that don't work}
    i:=1;
    while (i<=size) and (tag=0) do
    with possibles[i] do
    begin
      If isvalidmove(pcol,prow) then
      begin
        makemove(pcol,prow);
        inc(totmoves);
        form1.moveslbl.caption:='Total moves tried: '+inttostr(totmoves);
        if solvefrom(pcol,prow) then
        begin
          result:=true;
          break;
        end
        else if not manualplay then begin undomove; {beep;} end;
      end;
      inc(i);
    end;
  end;
end;
 
{******************** Form Methods *******************}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  randomize;
  makeboard;
  solvingpanel.bringtofront;
end;
 
Procedure TForm1.makeboard;
begin
  with Panel1 do {dummygrid is a stringgrid just to supply the size}
  board:=TBoard.create(self,8,rect(left,top,left+width,top+height));
  board.delay:=speedbar.max-speedbar.position;
  closedboxclick(self);
end;
 
procedure TForm1.PlayBtnClick(Sender: TObject);
begin
  if board.manualplay then
  begin
    if assigned(board) then board.free;
    Makeboard;
  end;
  board.manualplay:=true;
end;
 
 
procedure TForm1.SolveBtnClick(Sender: TObject);
{Compute solution -
 Start at a random location and try all paths - backtrack on those
 that don't work - until solution is found.
 
 Uses Warnsdorf heuristic - when a choice of moves is available,
  choose the one that has the fewest next moves
 }
begin
 
  makeboard;
  board.manualplay:=false;
  with board do
  begin
    with speedbar do position:=(max+min) div 2;
    solvingpanel.visible:=true;
    totmoves:=0;
    moveslbl.caption:='Total moves tried: 0';
    {makemove(random(size),random(size));}
    makemove(Coledit.value-1, Rowedit.value-1);
    If solvefrom(col,row) then showmessage('Solved!')
    else if not manualplay then showmessage('No solution found');
    solvingpanel.visible:=false;
  end;
  board.manualplay:=true;
end;
 
procedure TForm1.SpeedbarChange(Sender: TObject);
{set new ms delay between moves}
begin
  with speedbar do board.delay:=max-position;
end;
 
procedure TForm1.StopBtnClick(Sender: TObject);
begin
  board.tag:=1;
end;
 
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
   board.tag:=1; {in case we're solving}
   canclose:=true;
end;
 
procedure TForm1.ClosedBoxClick(Sender: TObject);
begin
   board.closedtour:=closedbox.checked;
end;
 
(*
procedure TForm1.Button1Click(Sender: TObject);
{temp to save a copy of the board for website}
var
  b:TBitmap;
  w,h:integer;
begin
  b:=tBitmap.create;
  h:=board.Height;
  w:=board.Width;
  b.height:=h;
  b.width:=w;
  b.canvas.copyrect(rect(0,0,w,h),board.canvas,rect(0,0,w,h));
  b.savetofile('kn.BMP');
  b.free;
end;
*)
 
end.