unit U_Tower3;
{Copyright 2000, 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
 }

 {Towers of Hanoi version 3 - with animated graphics}
interface

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

Const
  maxGraphicDisks=10;
type
  TDisk = class(TShape)  {the disks}
    Private
      nbr:integer;
      pegnbr:integer;
    Public
      Constructor Create(Aowner:TComponent); override;
      Procedure moveto(x,y, moveincr:integer);
  end;

  TTower = class ; {forward declaration so Tpeg.create can reference tower}

  TPeg = class(TObject) {the disks}
    Private
      pegnbr:integer;
      Disk:Array of TDisk;
      NbrDisks:integer;
      l,t,w,h:integer; {dimensions of pegbox}
      PegCenter:integer;
      constructor Create (AOwner:TTower; r:Trect; NewTotDisks:integer;
                          Fillit:boolean; newpegnbr:integer);
    public
      destructor destroy; override;
    end;

  TTower = class (TPanel)
    protected
      procedure paint;  override;

    private
      Peg:array[1..3] of TPeg;
      TotDisks:integer;
      Topmargin,PegHeight,PegWidth, Spacing:integer;
      PixelWidthPerDisk,MaxDiskWidth,DiskHeight:integer;
      dragdisk:TDisk;
      droppeg:integer;
      diskcolor:array of Tcolor;
      movecount:integer;
      MoveCountLbl:TLabel;
      constructor Create(Aowner:TComponent; NewnbrDisks:integer;
                         Imagerect:TRect);  reintroduce;
      procedure reset;
      procedure moveone(FromPeg,ToPeg:integer;moveincr:integer);
      procedure DragOverEvent(Sender, Source: TObject; X, Y: Integer;
                         State: TDragState; var Accept: Boolean);

      procedure DragDropEvent(Sender, Source: TObject; X, Y: Integer);

    public
      destructor destroy;  override;

    end;

  TForm1 = class(TForm)
    Label1: TLabel;
    SolveBtn: TButton;
    Memo1: TMemo;
    StopBtn: TButton;
    Image1: TImage;
    DisksEdt: TIntEdit;
    Panel1: TPanel;
    GraphicsOn: TCheckBox;
    ResetBtn: TButton;
    Memo2: TMemo;
    UpDown2: TUpDown;
    TrackBar1: TTrackBar;
    Label2: TLabel;
    procedure SolveBtnClick(Sender: TObject);
    procedure StopBtnClick(Sender: TObject);
    procedure DisksEdtChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    nbrdisks:Integer;
    movecount:Int64;
    starttime:TDateTime;
    seconds,rate:double;
    tower:TTower;
    Moveincr:integer;
    Procedure MoveOne(A,C:integer);
    Procedure MoveStack(n, A,C,B:integer);
    Procedure MakeLabels(s:string);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
Uses math, Results;

Procedure TForm1.MoveOne(A,C:integer);
{set up animated move of the top disk from peg A to peg C}
{calls tower.moveone procedure}
var
  starttime, endtime:TDateTime;
  targettime:real;
Begin
  inc(movecount);
  If graphicson.checked then
  Begin
    targettime:= 60/(Trackbar1.position*secsperday);
    starttime:=now;
    endtime:=starttime + targettime;
    tower.moveone(a,c,abs(a-c)*moveincr);
    if now-starttime>0
    then moveincr:=max(1, trunc(2*moveincr*(now-starttime)/targettime));
    application.processmessages;
    While now<endtime do application.processmessages;
  end;
End;

Procedure TForm1.MoveStack(n, A,C,B:integer);
{Use recursive calls to move n pegs from Peg A to Peg C with Peg B as a spare}
  Begin
    if tag=1 then exit; {User signaled to stop}
    If (nbrdisks>MaxGraphicDisks) and (movecount mod 1000 =0)
    then application.processmessages; {Every 100 moves, give Windows a chance}
    If n=1 then
    Begin
       MoveOne(A,C); {If there's only one to move, move it}
    end
    else
    Begin
      MoveStack(n-1, A,B,C);  {Move n-1 pegs to peg B}
      MoveStack(1,A,C,B);     {Then move bottom peg to Peg C}
      MoveStack(n-1,B,C,A);   {Then move n-1 pegs from B back to Peg C}
    end;
  end;

procedure TForm1.SolveBtnClick(Sender: TObject);
{show computer solution }
begin
  tag:=0; {Quit flag - set by stop button}
  If not graphicson.checked then screen.cursor:=crHourGlass;
  SolveBtn.enabled:=false;
  ResetBtn.enabled:=false;
  StopBtn.enabled:=true;
  movecount:=0;
  starttime:=time;
  If nbrdisks<=MaxGraphicDisks then Tower.reset;
  ResultsDlg.MovesLbl.Caption:='Number of moves:' ;
  ResultsDlg.timelbl.caption:='Number of Seconds: ';
  ResultsDlg.ratelbl.caption:='Moves per second: ';

  MoveStack(nbrdisks,1,3,2); {move nbrdisks from peg 1 to peg 3 using peg2 as the spare}
  If tag=0 then makelabels('Complete');
  SolveBtn.enabled:=true;
  ResetBtn.enabled:=true;
  StopBtn.enabled:=false;
  Screen.cursor:=CrArrow;
  ResultsDlg.showmodal;
end;

Procedure TForm1.MakeLabels(S:String);
{setup results display}
Begin
  ResultsDlg.MovesLbl.Caption:='Number of moves: '+floattostrf(movecount,ffnumber,9,0);
  seconds:=(time-starttime)*SecsPerDay;
  ResultsDlg.timelbl.caption:='Number of Seconds: '+floattostrf(seconds,ffnumber,6,1);
  If seconds>=0.5 then
  Begin
     rate:=movecount / seconds;
     ResultsDlg.ratelbl.caption:='Moves per second: '+floattostrf(rate,ffnumber,9,0);
  end
  else
   ResultsDlg.ratelbl.caption:='Moves per second: Need runtime of at least'
                   +#13+' 1/2 second to calculate rate';
End;

procedure TForm1.StopBtnClick(Sender: TObject);
{interrupt computer solution}
var
  years:single;
  s:string;
begin
  makelabels('Not Complete');
  Screen.cursor:=crArrow;
  ResultsDlg.EstSecsLbl1.visible:=true;
  ResultsDlg.EstsecsLbl2.visible:=true;
  ResultsDlg.EstSecsLbl1.caption:= 'Estimated time to complete: '
   + floattostrf((power(2,nbrdisks)-1)/Rate,ffnumber,8,1)+' seconds';
  years:=power(2,nbrdisks)/(365*24*3600);
  If years<=1 then s:=' year)' else s:=' years!)';
  ResultsDlg.EstSecsLbl2.caption:=
   'Est. time at 1 move per second: '
   +#13
   +floattostrf(Power(2,nbrdisks),ffnumber,20,0)
   +' seconds '+#13+'(That''s '
   +floattostrf(years,ffnumber,15,0)+s;
  SolveBtn.enabled:=true;
  StopBtn.enabled:=false;
  tag:=1; {Set quit flag}
end;


procedure TForm1.DisksEdtChange(Sender: TObject);
{set up a new number of disks }
begin
  nbrdisks:=disksedt.value;
  If nbrdisks>MaxGraphicDisks then
  Begin
    freeandnil(tower);
    graphicson.checked:=false;
  end
  else
  Begin
    if assigned(tower) then tower.free;
    tower:=TTower.create(self,nbrdisks,image1.boundsrect);
    graphicson.checked:=true;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  disksedtchange(sender);
  moveincr:=1;
end;

{************************************************************}
{*********** Here begins all the graphics stuff *************}
{************************************************************}

{************************************************************************}
{************************** TTower methods ******************************}
{************************************************************************}

{***************************** TTower.create ****************************}
Constructor TTower.create(AOwner:TComponent; NewnbrDisks:integer; Imagerect:TRect);
Begin
  inherited Create(AOwner);
  Parent:=TWincontrol(Aowner);
  OnDragOver:=DragOverEvent;
  OnDragDrop:=DragDropEvent;
  doublebuffered:=true;
  TotDisks:=NewNbrDisks;
  Left:=Imagerect.left;
  Top:=ImageRect.top;
  Width:=Imagerect.right-imagerect.left;
  Height:=ImageRect.Bottom-Imagerect.top;

  Pegwidth:=width div 4;
  Spacing:=width*6 div 100;
  Pegheight:= height*9 div 10;
  TopMargin:= Height div 10;
  MaxDiskWidth:=Pegwidth-4;

  MoveCountLbl:=Tlabel.create(self);
  with MoveCountLbl do
  Begin
    parent:=self;
    top:= 0;
    canvas.font.size:=24;
    font.size:=24;
    left:=self.width-canvas.textwidth('0000');
    caption:='';
  end;
  reset; {create (or free and recreate) all pegs & disks}
  sendtoback; {put board behind disk images}
end;

{***************************** TTower.MoveOne *********************}
Procedure TTower.moveone(FromPeg,ToPeg:integer;moveincr:integer);
{animate move of top disk from frompeg to topeg}
var
  tempdisk:TDisk;
  i:integer;
Begin
  with peg[frompeg] do
  Begin
    tempdisk:=disk[nbrdisks];
    dec(nbrdisks);
  end;

  {disable all dragging during the move}
  for i:= 1 to 3 do
  with peg[i] do
  if nbrdisks>0 then disk[nbrdisks].dragmode:=dmmanual;

  with peg[topeg] do
  Begin
    inc(nbrdisks);
    disk[nbrdisks]:=tempdisk;
    with disk[nbrdisks] do
    Begin
      moveto(pegcenter-width div 2, t+h-6 -nbrdisks*height, moveincr);
      pegnbr:=topeg;
    end;
  end;
  inc(Movecount);
  MovecountLbl.caption:=inttostr(movecount);
  invalidate;
  {enable all top disk dragging after the move}
  for i:= 1 to 3 do
  with peg[i] do
  if nbrdisks>0 then disk[nbrdisks].dragmode:=dmautomatic;
end;

{*************************** TTower.reset ************************}
Procedure ttower.reset;
{start over}
const
  maxcolors=12;
  colors:array[0..maxcolors-1] of TColor =
            (clred,clblue,clgreen,clyellow,
             clteal,clAqua,clLime, clNavy,
             clPurple,clMaroon,clOlive,clFuchsia);
var
  i,j,t,b,l,r:integer;
  usedcolors:array of boolean;
Begin
  {Set a random set of colors for disks - without duplicates}
  setlength(usedcolors, maxcolors);
  setlength(diskcolor, totdisks);
  for i:= 0 to maxcolors-1 do usedcolors[i]:=false;
  randomize;
  if totdisks<=maxcolors then {normal case}
  Begin
    for i:=0 to totdisks-1 do
    Begin
      j:=random(maxcolors);
      if usedcolors[j] then {find the next unused color}
      while usedcolors[j] do j:= (j+1) mod maxcolors;
      diskcolor[i]:=colors[j];
      usedcolors[j]:=true;
    end;
  end
  else for i:= 0 to totdisks-1 do diskcolor[i]:= colors[random(maxcolors)];

  {Set up peg box dimensions & create pegs}
  T:=TopMargin;
  B:=T+Pegheight;
  PixelWidthPerDisk:=Pegwidth div totdisks;
  DiskHeight:=Pegheight div (TotDisks+1);
  For i:= 1 to 3 do
  Begin
    L:=spacing + (i-1)*(Pegwidth+spacing);
    R:=L+Pegwidth;
    if assigned(Peg[i]) then peg[i].free;
    If i=1 then peg[1]:=TPeg.create(self, Rect(l,t,r,b),Totdisks,True,i)
    else peg[i]:=TPeg.create(self, Rect(l,t,r,b),Totdisks,False,i);
  end;
  movecount:=0;
  MoveCountLbl.caption:='';
  invalidate;
end;

procedure TTower.DragOverEvent(Sender, Source: TObject; X, Y: Integer;
                                       State: TDragState; var Accept: Boolean);
{called when a disk is dragged over a tower}
var
  cx,cy,i:integer;
Begin
  accept:=false;
  droppeg:=0;
  If (source is Tdisk) then
  with source as TDisk do
  Begin
    {key from the center of the disk to determine which peg it may be on}
    cx:=x+width div 2;
    cy:=y+ height div 2;
    for i:= 1 to 3 do
    with peg[i] do
    Begin
      {must be in the peg box}
      If (l<cx) and (l+w>cx) and (t<cy) and (t+h>cy)
         and (TDisk(source).pegnbr<>i)
       then
      {and disk number must be smaller than the top disk
       on the potential drop peg}
      if (nbrdisks=0) or (nbr< disk[nbrdisks].nbr) then
      Begin
        accept:=true;
        droppeg:=i;
        break;
      end;
    end;
  end;
end;

procedure TTower.DragDropEvent(Sender, Source: TObject; X, Y: Integer);
{called when disk is dropped}
Begin
 if (source is tDisk) and (droppeg>0)
 then moveone(TDisk(Source).pegnbr,droppeg,2);
 droppeg:=0;
 freeandnil(dragdisk);
end;


{************************** TTower.Boardpaint *********************}
Procedure TTower.paint;
{This routine repaints the pegs, disks are owned by the tower and will be
 redrawn automatically}
var
  i:integer;
Begin
  For i:=1 to 3 do
  with canvas, peg[i] do
  Begin
    {horizontal peg line}
    pen.width:=8;
    moveto(pegcenter-maxdiskwidth div 2 - 4,height-4);
    lineto(pegcenter+maxdiskwidth div 2+ 4,height-4);

    {vertical peg line}
    moveto(pegcenter,height-4);
    lineto(pegcenter,4);
  end;
End;


{************************ TTower.free **********************}
destructor TTower.destroy;
var
  i:integer;
Begin
  for i:= 1 to 3 do peg[i].free;
  inherited ;
end;

{************************************************************}
{******************** TPeg methods **************************}
{************************************************************}

{******************* TPeg.create ****************************}
Constructor TPeg.Create(Aowner:TTower; r:Trect; NewTotDisks:integer;
                        fillIt:boolean; newpegnbr:integer);
var
  i:integer;
Begin
  inherited create;
  L:=R.left; W:=R.Right-R.Left; T:=R.Top; H:=R.Bottom-R.top;
  pegnbr:=newpegnbr;
  Setlength(disk,Newtotdisks+1);
  PegCenter:=L+ w div 2;
  If fillit then
  Begin
    NbrDisks:=NewTotDisks;
    For i:=1 to Nbrdisks do
    Begin
      disk[i]:=TDisk.create(Aowner);
      with disk[i] do
      Begin
        parent:=Aowner;
        nbr:=Nbrdisks+1-i;
        width:=nbr*aowner.pixelWidthPerDisk;
        height:=aowner.Diskheight;
        left:=pegcenter-width div 2;
        top:=t+H-6 -(i*aowner.diskheight);
        brush.color:=Aowner.diskcolor[i-1];
        pegnbr:=self.pegnbr;
      end;
    end;
    disk[nbrdisks].dragmode:=dmAutomatic; {make top disk draggable}

  end
  else nbrdisks:=0;
end;


{************************* Tpeg.free *********************}
destructor TPeg.destroy;
var
  i:integer;
Begin
  for i:=1 to nbrdisks do if assigned(disk[i]) then disk[i].free;
  inherited destroy;
end;

{************************************************************}
{******************** TDisk methods *************************}
{************************************************************}

Constructor TDisk.create(aowner:TComponent);
Begin
  inherited ;
  shape:= stRoundRect;
end;

Procedure TDisk.moveto(x,y:integer; moveIncr:integer);
{move a disk from current loaction to x,y}
  var
    dy:real;
    dx:integer;
    startx,starty:integer;
    newx,newy:integer;
    stopx:integer;
  begin
    stopx:=x;
    startx:=left;
    starty:=top;
    If stopx>startx then dx:=moveincr else dx:=-moveincr;
    dy:=(starty-y)/(startx-x);
    newx:=startx;
    while newx<>stopx do
    Begin
      newx:=newx+dx;
      If ((dx<0) and (newx<stopx)) or ((dx>0) and (newx>stopx))
      then newx:=stopx;
      newy:=starty - trunc((startx-newx)*dy);
      If newx=stopx then newy:=y;
      left:=newx;
      top:=newy;
      invalidate;
      application.processmessages;
    end;
  end;



procedure TForm1.ResetBtnClick(Sender: TObject);
{reset the tower}
begin
  tower.reset;
end;

end.