unit U_PegGame2;
 {Copyright 2001, 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
 }

 {Peg solitaire solver - solves seven common cofigurations of a 33 hole
  7X7 board.  Moves are made by jumping a peg to an empty hole in any
  of the 4 major directions and removing the jumped peg.  The goal
  is to make the last move into the center hole.}

 {This is version 2.0 - allows user play}


interface

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

type
  TMode=(done, solving, replaying);
  TOccupiedType=(Empty,Occupied, NotAvailable);
  PTMove=^TMove;
  TMove=record
     frompoint,topoint:TPoint;
  end;

  TBoard= class(tObject)
    public
     pegcount:integer;{score of this board}
     path:Tlist;  {used to keep track of the moves that got us here}
     totcount:integer;  {total moves tried}
     stop:boolean;  {stop flag}
     Onstatus: procedure of object;
     {b = board array 11X11 array with index levels 0,1,9 and 10 in each direction
     reserved as sentinels to speed search for valid moves}
     b:array[0..10,0..10] of ToccupiedType;
     delayms:integer;
     image:Timage;
     boxw,boxh:integer;
     constructor create;
     destructor destroy; override;
     function moves:boolean;  {recursive search for moves}
     function solved:boolean; {return true if one peg left in center}
     function canmove:boolean;  {return true if there is a move left}
     procedure makemove(p1,p2,p3:TPoint);  {make a move}
     procedure unmakemove(p1,p2,p3:TPoint); {reverse a move}
     procedure draw(imageloc:TImage);
     procedure drawslot(x,y:integer);
     procedure movepeg(frompoint,topoint:TPoint);
     procedure rebuildboard;
  end;

  TForm1 = class(TForm)
    SolveBtn: TButton;
    Boardgrp: TRadioGroup;
    ListBox1: TListBox;
    FreqLabel: TLabel;
    Image1: TImage;
    ReplayPanel: TPanel;
    ReplayBtn: TButton;
    Speedbar: TTrackBar;
    Label1: TLabel;
    ResetBtn: TButton;
    Label2: TLabel;
    procedure SolveBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure ReplayBtnClick(Sender: TObject);
    procedure SpeedbarChange(Sender: TObject);
    procedure BoardgrpClick(Sender: TObject);
    procedure Image1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure Image1StartDrag(Sender: TObject;
      var DragObject: TDragObject);
    procedure Image1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure ResetBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    board:TBoard;
    startcount, freq :int64;
    mode:TMode;
    boxw,boxh:integer;  {Image width and height div 6}
    dragstartx,dragstarty:integer;
    procedure LoadABoard(newboard:boolean);
    procedure status;
  end;


var
  Form1: TForm1;

implementation

{$R *.DFM}

type smallarray= array[2..8,2..8] of byte;
{note - these arrays are stored with row as the high level index
        which makes it easier to see the figure outline in the
        data display, but must be reversed when storing in the board
        array which has column as the high level index}
const
  pegborder=4;

  crossarray:smallarray=(       (2,2,0,0,0,2,2),
                                (2,2,0,1,0,2,2),
                                (0,0,1,1,1,0,0),
                                (0,0,0,1,0,0,0),
                                (0,0,0,1,0,0,0),
                                (2,2,0,0,0,2,2),
                                (2,2,0,0,0,2,2));

  plusarray:smallarray=(        (2,2,0,0,0,2,2),
                                (2,2,0,1,0,2,2),
                                (0,0,0,1,0,0,0),
                                (0,1,1,1,1,1,0),
                                (0,0,0,1,0,0,0),
                                (2,2,0,1,0,2,2),
                                (2,2,0,0,0,2,2));

  fireplacearray:smallarray=(   (2,2,1,1,1,2,2),
                                (2,2,1,1,1,2,2),
                                (0,0,1,1,1,0,0),
                                (0,0,1,0,1,0,0),
                                (0,0,0,0,0,0,0),
                                (2,2,0,0,0,2,2),
                                (2,2,0,0,0,2,2));

  upArrowArray:smallarray=(     (2,2,0,1,0,2,2),
                                (2,2,1,1,1,2,2),
                                (0,1,1,1,1,1,0),
                                (0,0,0,1,0,0,0),
                                (0,0,0,1,0,0,0),
                                (2,2,1,1,1,2,2),
                                (2,2,1,1,1,2,2));

  pyramidArray:smallarray=(     (2,2,0,0,0,2,2),
                                (2,2,0,1,0,2,2),
                                (0,0,1,1,1,0,0),
                                (0,1,1,1,1,1,0),
                                (1,1,1,1,1,1,1),
                                (2,2,0,0,0,2,2),
                                (2,2,0,0,0,2,2));

  diamondArray:smallarray=(     (2,2,0,1,0,2,2),
                                (2,2,1,1,1,2,2),
                                (0,1,1,1,1,1,0),
                                (1,1,1,0,1,1,1),
                                (0,1,1,1,1,1,0),
                                (2,2,1,1,1,2,2),
                                (2,2,0,1,0,2,2));

  solitairearray:smallarray=(   (2,2,1,1,1,2,2),
                                (2,2,1,1,1,2,2),
                                (1,1,1,1,1,1,1),
                                (1,1,1,0,1,1,1),
                                (1,1,1,1,1,1,1),
                                (2,2,1,1,1,2,2),
                                (2,2,1,1,1,2,2));


{******************* Tform1.LoadABoard **********}

procedure tform1.loadABoard(newboard:boolean);
{copy a set of data defining a figure into the board array}
var
  i,j:integer;

     procedure amove(a:smallarray);  {local data move routine - takes one
                          of the seven board definition arrays as a parameter}
     var  i,j:integer;
     begin
       for i:= 0 to 10 do
       for j:= 0 to 10 do
       with board do
       begin
         if (i>=2) and (i<=8) and (j>=2) and (j<=8)
         then b[j,i]:=TOccupiedtype(a[i,j])
         else b[j,i]:=NotAvailable;
       end;
     end;

begin
  if newboard then
  begin
    if assigned (board) then board.free;
    board:=tboard.create;
    board.onstatus:=status;
    speedbarchange(self);
    listbox1.clear;
    replaypanel.visible:=false;
  end;

  case boardgrp.itemindex of
    0: {cross} amove(crossarray);
    1: {plus}  amove(plusarray);
    2: {fireplace} amove(fireplacearray);
    3: {uparrow} amove(uparrowarray);
    4: {diamond} amove(diamondarray);
    5: {pyramid} amove(pyramidarray);
    6: {solitaire} amove(solitairearray);
  end;
  for i:= 2 to 8 do for j:=2 to 8  do {count pegs}
     if board.b[i,j]=occupied then inc(board.pegcount);
  board.draw(image1);
end;

{************************ TForm1.Status ******************}
procedure TForm1.status;
{output periodic status updates - called as TBoard.OnStatus}
var
  n:int64;
begin
   queryperformancecounter(n);
   freqlabel.caption:=(format('%9.0n moves per second, %9.0n moves tried '{, %6.0n'},
       [board.totcount*freq/(n-startcount), 0.0+board.totcount {, allocmemsize+0.0}]));
end;

{******************** TForm1.SolveBtnLCick **************}
procedure TForm1.SolveBtnClick(Sender: TObject);
{Compute a solution}
var
  i:integer;
  r:boolean;
begin
  if (mode = solving) or (mode=replaying)  then
  begin
    board.stop:=true;
    application.processmessages;
    if mode=replaying then board.rebuildboard{loadaboard(false)};
    exit;
  end;
  if board.pegcount<=1 then   LoadABoard(true) {make a new board}
  else {resetboardcounts}
  begin
   {listbox1.clear;}
    replaypanel.visible:=false;
    board.stop:=false;
  end;
  queryperformancefrequency(freq);
  queryperformancecounter(startcount);
  mode:=solving;
  solvebtn.caption:='Stop';
  screen.cursor:=crHourglass;
  r:=board.moves;   {solve it!}
  screen.cursor:=crdefault;

  if r and (not board.stop) then
  with board do
  begin
    listbox1.clear;
    for i:=0 to path.count-1 do
    with pTmove(path[i])^ do
    begin    {adjust "move" data to 1-7 range}
      listbox1.items.add('From ('+inttostr(frompoint.x-1)+','+inttostr(frompoint.y-1)
                + ') to ('+ inttostr(topoint.x-1)+','+inttostr(topoint.y-1)+')');
    end;
    replaypanel.visible:=true;
    replaybtnclick(sender);
  end
  else listbox1.items.add('No solution found');
  mode:=done;
  solvebtn.caption:='Solve it';
end;

{***************** FormCreate ****************}
procedure TForm1.FormCreate(Sender: TObject);
begin
  doublebuffered:=true; {prevent flicker}
  loadaboard(true);  {make a new board}
  boxw:=image1.width div 7;
  boxh:=image1.height div 7;
  {load drag cursors}
  screen.cursors[crDrag]:=LoadCursor(HInstance, pchar('PEGDROP'));
  screen.cursors[crNoDrop]:=LoadCursor(HInstance, 'PEGNODROP');
  mode:=done;
end;

{******************** FormCloseQuery *****************}
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
{set flag to let solving stop if user clicks close}
begin
  if assigned(board) then board.stop:=true;
end;

{*************** ReplayBtnCick ***************}
procedure TForm1.ReplayBtnClick(Sender: TObject);
var
  i:integer;
begin
  if mode=replaying then  exit;
  if board.path.count>0 then
  with board do
  begin
    mode:=replaying;
    rebuildboard;
    board.stop:=false;
    solvebtn.caption:='Stop';
    mode:=replaying;
    application.processmessages;
    i:=0;
    if path.count-1>0 then
    repeat
      with pTmove(path[i])^ do movepeg(point(frompoint.x-1,frompoint.y-1),
                                       point(topoint.x-1,topoint.y-1));
      if board.stop then break;
      inc(i);
    until i>path.count-1;
    mode:=done;;
    solvebtn.caption:='Solve it';
    if board.stop then loadaboard(false);
  end;
end;

{******************** Speedbarchange ***************}
procedure TForm1.SpeedbarChange(Sender: TObject);
{Controls speed of animations}
begin
  with Speedbar do  board.delayms:=max-position;
end;

{******************** Boardgroupclick *************}
procedure TForm1.BoardgrpClick(Sender: TObject);
{Can't the the user replay after he's selected a different board}
begin
  if  mode<>done then
  begin
    board.stop:=true;
    application.processmessages;
  end;
  replaypanel.visible:=false;
  loadaboard(true);  {make a new board}
end;

{****************************************************}
{******************** TBoard methods ****************}
{****************************************************}

{****************** Create ****************}
constructor TBoard.create;
begin
  inherited;
  pegcount:=0;
  totcount:=0;
  path:=tlist.create;
  stop:=false;
end;

{******************* Destroy ****************}
destructor TBoard.destroy;
var
  i:integer;
begin
  for i:=0 to path.count-1 do dispose(PTMove(path[i]));
  path.free;
  inherited;
end;

{********************* MakeMove ****************}
procedure TBoard.makemove(p1,p2,p3:TPoint);
{make a move}
var
  pmove:PTMove;
begin
  b[p1.x,p1.y]:=empty;
  b[p2.x,p2.y]:=empty;
  b[p3.x,p3.y]:=occupied;
  dec(pegcount);
  new(PMove);
  path.add(pmove);
  pmove^.frompoint:=p1;
  pmove^.topoint:=p3;
  inc(totcount);
  if totcount mod (128*1024) =0 then
  begin
    if assigned(Onstatus) then onstatus;
    application.processmessages;
  end;
end;

{********************** UnMakeMove *************}
procedure TBoard.UnMakemove(p1,p2,p3:TPoint);
{retract a  move}
begin
  b[p1.x,p1.y]:=occupied;
  b[p2.x,p2.y]:=occupied;
  b[p3.x,p3.y]:=empty;
  inc(pegcount);
  dispose(PTMove(path[path.count-1]));
  path.delete(path.count-1);
end;

{******************* Solved ***********}
function Tboard.solved:boolean;
{Solved test}
begin {Solution = one peg left in the center}
  result:=(pegcount=1) and (b[5,5]=occupied);
end;

{****************** Moves ***************}
function TBoard.moves:boolean;
{Main solution search method}
{Check moves depth first - recursive function}
{Optimized for speed}
var
  i,j:integer;
begin
  result:=true;
  if stop then exit;
  if solved then
  begin
    if assigned(onstatus) then onstatus;
    exit;
  end
  else
  begin

    for i:= 2 to 8  do  {check all peg locations  - 0,1,9,and 10 are "sentinal"
                       index slots to avoid range testing of each i,j, value}
    for j:= 8 downto 2 do

    begin
      if b[i,j]=occupied then  {check all 4 directions}
      begin
        {1. North}
        if  (b[i,j-1]=occupied) and (b[i,j-2]=empty)
        then
        begin
          makemove(point(i,j), point(i,j-1), point(i,j-2));
          if not moves then unmakemove(point(i,j), point(i,j-1), point(i,j-2))
          else  exit;
        end;
        {2. East}
        if  (b[i+1,j]=occupied) and  (b[i+2,j]=empty)
        then
        begin
          makemove(point(i,j), point(i+1,j),point(i+2,j));
          if not moves then unmakemove(point(i,j), point(i+1,j),point(i+2,j))
          else  exit;
        end;
         {3. South}
        if    (b[i,j+1]=occupied) and (b[i,j+2]=empty)
        then
        begin
          makemove(point(i,j), point(i,j+1),point(i,j+2));
          if not moves then unmakemove(point(i,j), point(i,j+1),point(i,j+2))
          else  exit;
        end;
        {4. West}
        if   (b[i-1,j]=occupied) and (b[i-2,j]=empty)
        then
        begin
          makemove(point(i,j), point(i-1,j),point(i-2,j));
          if not moves then unmakemove(point(i,j), point(i-1,j),point(i-2,j))
          else exit;
        end;
      end;
    end;
    result:=false;
  end;
end;

function TBoard.canmove:boolean;
{return true if at least one move left}
var
  i,j:integer;
begin
  result:=false;
  for i:= 2 to 8  do
  begin
    for j:= 8 downto 2 do
    begin
      if b[i,j]=occupied then  {check all 4 directions}
      begin
        if    (b[i,j-1]=occupied) and (b[i,j-2]=empty)
          or  (b[i+1,j]=occupied) and  (b[i+2,j]=empty)
          or  (b[i,j+1]=occupied) and (b[i,j+2]=empty)
          or   (b[i-1,j]=occupied) and (b[i-2,j]=empty)
        then
        begin
          result:=true;
          break;
        end;
      end;
    end;
    if result then break;
  end;
end;

{********************** Draw ***************}
procedure TBoard.draw(imageloc:Timage);
{Draw the current board }
var
  {boxw,boxh:integer; }
  i,j:integer;
begin
  image:=imageloc;
  boxw:=image.width div 7;
  boxH:=image.height div 7;
  image.width:=boxw*7;
  image.height:=boxH*7;
  with image, canvas do
  for i:=2 to 8 do
  for j:=2 to 8 do
  begin
    brush.color:=clyellow;
    rectangle((i-2)*boxw,(j-2)*boxh,(i-1)*boxw,(j-1)*boxh);
    case b[i,j] of
      empty:
        begin
          brush.color:=clblack;
          ellipse((i-2)*boxw+8,(j-2)*boxh+8,(i-1)*boxw-8,(j-1)*boxh-8);
        end;
      occupied:
        begin
          brush.color:=clred;
          ellipse((i-2)*boxw+4,(j-2)*boxh+4,(i-1)*boxw-4,(j-1)*boxh-4);
        end;
    end;
  end;
  application.processmessages;
end;


procedure TBoard.drawslot(x,y:integer);
{draw image of slot contonts, x & y zero based}
begin

  case b[x+2,y+2] of
    occupied:
      with image, canvas do
      begin
        brush.color:=clred;
        ellipse((x)*boxw+4,(y)*boxh+4,(x+1)*boxw-4,(y+1)*boxh-4);
      end;
    empty:
      with image, canvas do
      begin
        brush.color:=clyellow;
        rectangle((x)*boxw,(y)*boxh,(x+1)*boxw,(y+1)*boxh);
        brush.color:=clblack;
        ellipse((x)*boxw+8,(y)*boxh+8,(x+1)*boxw-8,(y+1)*boxh-8);
      end;
  end;
  application.processmessages;
end;


{************************* MovePeg **********************}
procedure TBoard.movepeg(frompoint,topoint:TPoint);
{animate a peg move}
var
  boxw,boxh,delta:integer;
  i:integer;
  peg:Tshape;
  fromx,fromy,tox,toy:integer;

  procedure drawempty(i,j:integer);
  begin
    with image, canvas do
   begin
     brush.color:=clyellow;
     rectangle((i)*boxw,(j)*boxh,(i+1)*boxw,(j+1)*boxh);
     brush.color:=clblack;
     ellipse((i)*boxw+8,(j)*boxh+8,(i+1)*boxw-8,(j+1)*boxh-8);
   end;
 end;

  procedure drawpeg(i,j:integer);
  begin
    with image, canvas do
    begin
      brush.color:=clred;
      ellipse((i)*boxw+pegborder,(j)*boxh+pegborder,(i+1)*boxw-pegborder,(j+1)*boxh-pegborder);
    end;
  end;

begin
  boxw:=image.width div 7;
  boxH:=image.height div 7;
  {make points 0 based}
  fromx:=frompoint.x-1;
  fromy:=frompoint.y-1;
  tox:=topoint.x-1;
  toy:=topoint.y-1;
  peg:=tshape.create(image.owner);
  with peg do
  begin
    width:=boxw-2*pegborder;
    height:=boxh-2*pegborder;
    parent:=image.parent;
    shape:=stcircle;
    brush.color:=clred;
    left:=image.left+pegborder;
    top:=image.top+pegborder;
  end;
  with image, canvas do
  begin
     if  fromy=toy then
     begin   {horizontal - move up, over, and down}
       drawempty(fromx, fromy);
       delta:=(tox-fromx)*boxw;
       peg.left:=image.left+4+boxw*fromx;
       peg.top:=image.top+4+boxh*fromy;
       for i:= 1 to 12 do
       begin
         If i<=4 then
         begin
           peg.left:=peg.left+delta div 12;
           peg.top:=peg.top-boxw div 8;
         end
         else if i<=8 then  peg.left:=peg.left+delta div 12
         else
         begin
           peg.left:=peg.left+delta div 12;
           peg.top:=peg.top+boxw div 8;
         end;
         update;
         if stop then break;
         sleep(delayms);
       end;
       if not stop then
       begin
         drawempty(fromx+delta div (2*boxw),fromy);
         drawpeg(tox,toy);
       end;
     end
     else
     begin  {vertical move - right, up/down, left}
       drawempty(fromx, fromy);
       delta:=(toy-fromy)*boxh;
       peg.left:=image.left+4+boxw*fromx;
       peg.top:=image.top+4+boxh*fromy;
       for i:= 1 to 12 do
       begin
         if i<=4 then
         begin
           peg.left:=peg.left+boxw div 8;  {angle over half a peg}
           peg.top:=peg.top+delta div 12;
         end
         else if i<=8 then  peg.top:=peg.top+delta div 12
         else
         begin
           peg.left:=peg.left-boxw div 8;
           peg.top:=peg.top+delta div 12 ;
         end;
         update;
         if stop then break;
         sleep(delayms);
       end;
       if not stop then
       begin
         drawempty(fromx,fromy+delta div (2*boxH));
         drawpeg(tox,toy);
       end;
     end;
  end;
  peg.free;
  application.processmessages;
  sleep(4*delayms);
end;


procedure TForm1.Image1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
var
  nx,ny:integer;
begin
   nx:=x div boxw;
   ny:=y div boxh;
   if (board.b[nx+2,ny+2]=empty)
   and (
        ( (nx=dragstartx)
           and (abs(ny-dragstarty)=2)
           and (board.b[nx+2,(dragstarty+ny) div 2+2]= occupied)
         )
    or  ( (ny=dragstarty)
           and (abs(nx-dragstartx)=2)
           and (board.b[(dragstartx+nx) div 2 +2, ny+2]= occupied)
         )
       )
   then accept:=true
   else  accept:=false;
end;

procedure TBoard.rebuildboard;
{reconstruct the board from the path by applying moves in reverse order from
 end of list}
var
  i,j:integer;
begin
  for i:= 2 to 8 do
  for j:= 2 to 8 do
  begin
    drawslot(i-2,j-2);
    application.processmessages;
  end;
  for i:= path.count-1 downto 0 do
  with pTmove(path[i])^ do
  begin    {adjust "move" data to 1-7 range}
    b[frompoint.x{+1},frompoint.y{+1}]:=occupied;
    b[topoint.x{+1},topoint.y{+1}]:=empty;
    b[(frompoint.x+topoint.x) div 2{+1}, (frompoint.y+topoint.y) div 2{+1}]:=occupied;
    drawslot(frompoint.x-2,frompoint.y-2);
    drawslot(topoint.x-2,topoint.y-2);
    drawslot((frompoint.x+topoint.x) div 2-2, (frompoint.y+topoint.y) div 2-2);
     application.processmessages;
  end;

  sleep(1000);
end;


procedure TForm1.Image1StartDrag(Sender: TObject;
  var DragObject: TDragObject);
var
  p:TPoint;
begin
  p:=image1.screentoclient(mouse.cursorpos);
  dragstartx:=p.x div boxw;
  dragstarty:=p.y div boxh;
  dragobject:=nil;
end;


procedure TForm1.ResetBtnClick(Sender: TObject);
begin
  board.stop:=true;
  application.processmessages;
   mode:=done;
  solvebtn.caption:='Solve it';
  loadaboard(true);
end;


procedure TForm1.Image1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
  nx,ny:integer;
  midx,midy:integer;
  msg:string;
begin
  with board do
  begin
    nx:=x div boxw;
    ny:=y div boxh;
    midx:=(nx+dragstartx) div 2;
    midy:=(ny+dragstarty) div 2;
    board.makemove(point(dragstartx+2,dragstarty+2),
                   point(midx+2,midy+2),
                   point(nx+2,ny+2));
    drawslot(nx,ny);
    drawslot(dragstartx, dragstarty);
    drawslot(midx,midy);
    with pTmove(path[path.count-1])^ do
    begin
      {adjust "move" data from 2-8 range back to to 1-7 range}
      listbox1.items.add('From ('+inttostr(frompoint.x-1)+','+inttostr(frompoint.y-1)
                + ') to ('+ inttostr(topoint.x-1)+','+inttostr(topoint.y-1)+')');
    end;
    if not canmove then
    begin
      if pegcount>3 then msg:='That''s pitiful!'
      else if pegcount>1 then msg:='Not bad'
      else if not solved then msg:='Almost made it!'
      else msg:='Congratulations!';
     showmessage('No moves remaining - you have ' +inttostr(pegcount) +' pegs left'
              +#13+msg);
    end;
  end;
end;


end.