home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Current Shareware 1994 January
/
SHAR194.ISO
/
games
/
thanoi.zip
/
HANOI.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-01-29
|
30KB
|
1,088 lines
{$C-} (* no <ctrl><break> *)
Program TestHanoi(input,output);
const helpsize=9; (* # of lines in const messh1 <help text> *)
Type
DiscNoType = 1..64;
Postnum = 1..3;
charset= set of char;
stsize=string[128];
mc5array=array[1..helpsize] of stsize; (* used for help constant *)
datestr=string[12];
disktype=string[24]; (* used for disk strings *)
ctbl_type=array[0..15] of integer; (* used for color tables *)
var
numberofdisks:DiscNoType;
Sttime,Endtime:datestr;
NMD,Recursecnt,Autospeed:integer; (* NMD = number disks *)
(* recursecnt = # calls to hanoi proc *)
gmode:stsize; (* gmode = game mode *)
disks:array[1..10] of disktype;
drow:array[1..10] of integer; (* row coordinates *)
col:array[1..3] of array [1..10] of integer; (* column coordinates *)
Nch,TC,scrolldone,click:char;
Gamedone,Funckey,Udone,movescroll:boolean;
color_tbl,ctbl_def,cbkg_tbl:ctbl_type; (* color tables *)
(* The help text. *)
const
messh1:MC5aRRay= ('!!! Set Game mode For Play, Automatic or Random demo. ',
'',
' Play - Try to solve game yourself; ',
' Move ALL discs to Tower 3 WITHOUT putting a larger ',
' disc on top of a smaller one. ',
' Use F10 to re-enter a move. Use F3 to set colors. ',
' Use Esc for previous Screen or to Quit. ',
' Automatic - Watch PC play 1 game, You set parameters. ',
' Random demo - Watch PC play continuously. ');
(* procs hv & lv set colors for most of the text messages... *)
(* adjust at runtime via F3. F - 14, B - 1 / F - 7, B - 0 *)
procedure HV;
begin
textcolor(color_tbl[14]);
textbackground(cbkg_tbl[1]);
end;
Procedure LV;
begin
textcolor(color_tbl[7]);
textbackground(cbkg_tbl[0]);
end;
procedure FrameY(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
var
i: Integer;
begin
GotoXY(UpperLeftX, UpperLeftY); Write(chr(220));
for i:=UpperLeftX+1 to LowerRightX-1 do Write(chr(220));
Write(chr(220));
for i:=UpperLeftY+1 to LowerRightY-1 do
begin
GotoXY(UpperLeftX , i); Write(chr(221));
GotoXY(LowerRightX, i); Write(chr(222));
end;
GotoXY(UpperLeftX, LowerRightY);
Write(chr(223));
for i:=UpperLeftX+1 to LowerRightX-1 do Write(chr(223));
Write(chr(223));
end { Frame };
(* return N length string of char C { from turbo manual i think} *)
function ConstStr(C : Char; N : Integer) : Stsize;
var
S : stsize;
begin
if N < 0 then
N := 0;
S[0] := Chr(N);
FillChar(S[1],N,C);
ConstStr := S;
end;
(* checks for keypress, process L & R arrow keys for autospeed adj. *)
(* toggle click (F3) and scroll mode (F4) vars in help display and *)
(* Auto and Random modes. Returns other key stokes in var sch. *)
procedure chspeed(var sch:char);
begin
if keypressed then
begin
read(kbd,sch);
case sch of
#32 : begin
repeat {nothing} until keypressed;
read(kbd,sch);
end;
#27 : begin if keypressed then
begin
read(kbd,sch);
case sch of
#75 : autospeed:=autospeed-25;
#77 : autospeed:=autospeed+25;
#61 : if click='Y' then click:='N'
else click:='Y';
#62 : if movescroll then movescroll:=false
else movescroll:=true;
end;
if autospeed<26 then autospeed:=26;
if autospeed>880 then autospeed:=880;
end;
end;
end;
end;
end;
(* Scrolls a string <type stsize> from right to left. *)
(* Original version scrolled a very large char array thru a *)
(* small window. Modified to scroll in help message and *)
(* slide each line up in window. If len2 = 0 window scrolls up. *)
PROCeDURE SCROLLL(MESSAGE:stsize; WSIZE,ROW,scol,len2:INTEGER);
(* wsize = # columns in window *)
(* row,scol = start coordinates *)
(* len2 = length of MESSAGE *)
VAR
SP,DP,bg,dl,J,cnt:INTEGER;
sch:char;
line:string[80]; (* part of message for each write... *)
label 99;
procedure getline;
var k:integer;
begin
if (j-bg)-1<wsize then
line:=conststr(' ',wsize-(j-bg)-1)
else
line:='';
for k:=bg to j do
if k<=len2 then line:=line+message[k]
else line:=line+' ';
end;
BEGIN
bg:=1; sp:=wsize; cnt:=0; j:=1;
while ((J <= len2+abs(wsize-len2)+1) and (sch<>#27)) DO
BEGIN
gotoxy(scol,row);
getline;
if click='Y' then begin sound(7920-(30*autospeed));delay(3);nosound;end;
delay(3);
chspeed(sch);
write(line);
cnt:=cnt+1;
if ((cnt=wsize) or (len2=0)) then
begin
gotoxy(1,1);
delline;
cnt:=0;
sp:=wsize+1;
bg:=bg+wsize;
if len2=0 then j:=len2+abs(wsize-len2)+1; (* exit if no string *)
end;
j:=j+1;
if sp<>1 then
sp:=sp-1
else
bg:=bg+1;
end;
if sch=#27 then scrolldone:='Y';
tc:=sch;
END;
procedure puttitle;
begin
lv;
gotoxy(5,23);write(conststr(#32,70));
hv;
gotoxy(12,25);
case gmode of
'?' : begin
write(' F1 = Help. F2 = Set Speed. F3 = '+
'Set Colors. Esc = Quit. ');
end;
'P' : begin
write(' F1 = Help. F10 = Re-start current move. Esc = Give up. ');
end;
'A','R' : begin
write(' L/R arrows adjust speed, ESC = To Main Menu after game. ');
gotoxy(15,23); lv;
write(' F3 = Toggle click. F4 = Toggle Scroll Mode. ');
end;
end;
end;
Procedure help; (* the help screen routine *)
var sphold,htinx:integer;
BEGIN
window(1,1,80,25);
textcolor(color_tbl[3]);
textbackground(cbkg_tbl[2]);
gotoxy(5,23);write(conststr(#32,70));
textcolor(color_tbl[15]);
textbackground(cbkg_tbl[5]);
gotoxy(12,25);write(conststr(#32,60));
gotoxy(15,23); hv;
write(' F3 = Toggle click. F4 = Toggle Scroll Mode. ');
lv;
WINDOW(11,18,69,20);clrscr; hv;
gotoxy(1,2);clreol;write(' Use L/R arrows - Scroll speed, Space - pause, ESC - end.');
Window(2,5,79,15); lv; clrscr;
Window(15,5,75,15);
scrolldone:='N'; hv;
sphold:=autospeed;
autospeed:=autospeed*4;
htinx:=1;
while ((htinx<=helpsize) and (scrolldone='N')) do
begin
SCROLLL(messh1[htinx],60,11,1,length(messh1[htinx]));
htinx:=htinx+1;
end;
if tc<>#27 then (* wait unless ESC hit *)
repeat (* nothing *) until keypressed;
lv; clrscr;
window(1,1,80,25);
puttitle;
WINDOW(11,18,69,20);
clrscr;
autospeed:=sphold;
END;
procedure beep;
begin
write(^G);
end;
Procedure Putscrn3; (* draw main screen & boxes... *)
begin
window(1,1,80,25);
lv;
clrscr;
textcolor(color_tbl[12]);
framey(20,1,60,3);
textcolor(color_tbl[13]);
frameY(10,17,70,21);
textcolor(color_tbl[14]);
gotoxy(2,25);write(conststr(#219,78));
textcolor(color_tbl[9]);
frameY(1,4,80,16);
textcolor(color_tbl[7]);
framey(1,22,80,24);
HV; gotoxy(28,2);write('The Towers Of Hanoi !?!?');LV;
gotoxy(19,4);write(' ** Written by Scott Armitage. (c) 1993 ** ');
end;
(* returns system time. Modified from routine whose origins I forgot... *)
function Time: DateStr;
type
regpack = record
ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
end;
var
recpack: regpack; {record for MsDos call}
dx,cx: integer;
hr,min,sec,hsec: string[3];
procedure fixsize;
begin
if length(hr)=1 then hr:='0'+hr;
if length(min)=1 then min:='0'+min;
if length(sec)=1 then sec:='0'+sec;
if length(hsec)=1 then hsec:='0'+hsec;
end;
begin
with recpack do
begin
ax := $2c shl 8;
end;
MsDos(recpack); { call function }
with recpack do
begin
str(cx shr 8,hr); {convert to string}
str(cx mod 256,min); { " }
str(dx shr 8,sec); { " }
str(dx mod 256,hsec);
end;
fixsize;
time:=hr+':'+min+':'+sec+'.'+hsec;
end;
(* nifty consol input routine *)
procedure INKEY(var S : stsize; (* var to be input/edited, may *)
(* contain init value. *)
L,X,Y,ws : Integer; (* L=max length, X,Y=Column,Row *)
(* ws=number of columns in window. *)
Term : CharSet; (* characters that will end input *)
(* may be any key or 2nd function key val *)
AN,CP : char; (* alphanumeric and case switches *)
var TChar : Char);
const
UnderScore = #176;
var
P : Integer;
Ch,Vind : Char;
procedure chAN;
begin
vind:='N';
if UpCase(CH) in['A'..'Z','.','?','!',#44] then
vind:='Y';
IF ch=' ' THEN VIND:='Y';
end;
procedure chnum;
begin
vind:='N';
if ch in['0'..'9','.','$',' ','%',#44] then vind:='Y';
end;
PROCEDURE PUTS;
var workV,Tmpr:integer;
BEGIN
gotoxy(x,y); write(S,CONSTSTR(UNDERSCORE,L-LENGTH(S)));
workV:=0;Tmpr:=0;
if (p+x)>ws then
begin
repeat
begin
workV:=WorkV+(ws); Tmpr:=tmpr+1;
end;
until (workV>=p+x);
workV:=workV+x-1;
gotoxy((p+x+ws-workV),tmpr);
end
else
gotoxy(x+p,y);
{endif};
END;
begin
P :=Length(S);puts;
funckey:=false;tchar:=#255;
repeat
begin
Read(Kbd,Ch);
If ((ch=#27) and keypressed) then
Begin
Read(Kbd,Ch);
Case Ch Of
#71 : Ch:=^A; { Home }
#79 : ch:=^F; { End }
#77 : Ch:=^D; { RightArrow }
#75 : Ch:=^S; { LeftArrow }
#83 : ch:=^G; {PC-DEL}
#30..#68 : begin funckey:=true; end;
else
ch:=#00;
End;
end
else
If ch=#27 then
begin
s:='';p:=0;
end;
{endif};
case ch of
#32..#126 : if ((length(s) < L) and (not funckey)) then
begin
vind:='Y';
if an='A' then chan;
if an='N' then chnum;
if ((vind='Y') and (cp='L')) then ch:=UpCase(ch);
if vind='Y' then
begin
P := P + 1;
Insert(Ch,S,P);
end
else beep;
end
else
if not funckey then
begin
beep; p:=l; s:=copy(s,1,l);
end;
^S : if P > 0 then
P := P - 1
else Beep;
^D : if P < Length(S) then
P := P + 1
else Beep;
^A : if p=0 then beep else P := 0;
^F : if p=length(s) then beep else P:=length(S);
^G : if P < Length(S) then
Delete(S,P + 1,1)
else beep;
^H,#127 : if P > 0 then
begin
delete(S,P,1);p:=p-1;
end
else Beep;
^Y,^X : if length(s)=0 then
beep
else
begin
S:=''; P:=0;
end;
^T : if p < length(s) then
begin
delete(s,p+1,(length(s)-p));
p:=length(s);
end else beep;
else
if (not (Ch in Term) and (not funckey)) then Beep;
end; {of case}
PUTS;
end;
until ((Ch in Term) or (funckey) OR (P=L));
P := Length(S);
puts;
TChar := Ch;
end;
procedure ssetspeed; (* routine to adjust global autospeed variable *)
(* probably unneccesary due to speed adj in chspeed proc *)
var ch:char;
begin
textcolor(color_tbl[9]);
textbackground(cbkg_tbl[4]);
clrscr;
hv;
gotoxy(5,1);write('Use L, R arrow keys');
gotoxy(5,2);write(' to set AutoSpeed,');
Gotoxy(5,3);write('Enter for Selection.');
textcolor(color_tbl[11]);
textbackground(cbkg_tbl[2]);
framey(40,1,50,3);
hv;
if tc<>#27 then
repeat
Begin
gotoxy(43,2);write(' ');
gotoxy(44,2);write(Autospeed);
read(kbd,ch);
if ((ch=#27) and (keypressed)) then
begin
read(kbd,ch);
case ch of
#75:Autospeed:=autospeed-5;
#77:autospeed:=autospeed+5;
else beep;
end;
end;
if autospeed<0 then autospeed:=500
else
if autospeed>880 then autospeed:=0;
end;
until ((ch=#13) or (ch=#27));
clrscr;
end;
procedure ctbl_init; (* set inital vals for default color table... *)
var x:integer;
begin
for x:=0 to 15 do
ctbl_def[x]:=x;
for x:=0 to 15 do
color_tbl[x]:=x;
for x:=0 to 15 do
cbkg_tbl[x]:=x;
end;
procedure setcttl; (* draw prompts for set colors proc *)
begin
textcolor(color_tbl[13]);
textbackground(cbkg_tbl[4]);
gotoxy(5,23);write(conststr(#32,70));
gotoxy(15,23);hv; write(' Return or Esc to exit. Space = Re-Draw screen. ');
textcolor(color_tbl[1]);
textbackground(cbkg_tbl[7]);
gotoxy(12,25);write(conststr(#32,60));
window(11,18,69,20);
textcolor(color_tbl[10]);
textbackground(cbkg_tbl[5]);
clrscr;
hv;
gotoxy(3,1);write('Use L, R, U & D arrow keys to set ');
gotoxy(3,2);write('& select colors, F2=Toggle blink,');
Gotoxy(3,3);write('F3=Default vals, F4=Toggle table.');
textcolor(color_tbl[3]);
textbackground(cbkg_tbl[5]);
framey(44,1,57,3);
end;
(* procedure to adjust values in color tables. *)
(* the values and 'XX' will be displayed useing the current *)
(* value being adjusted and the last Foreground/Background *)
(* value that was selected. F4 toggles between the 2. *)
(* the index of the last Foreground/Background selected will *)
(* be displayed to the right of the 'XX'. No check are made *)
(* to prevent F & B from being set to the same value. *)
(* if you do this your text will vanish for that combo *)
(* on MDA and other monochrome monitors I tested, the *)
(* background value has no effect. *)
procedure ssetcolors;
var ch,cflag:char; (* ch = input char, cflag = switch for F or B *)
cinx,ciny,cval:integer; (* cval = value in table. cinx = current index *)
(* ciny = previous table index *)
begin
window(1,1,80,25);
setcttl;
cinx:=0; ciny:=7; cflag:='F';
repeat
Begin
case cflag of
'F' : begin
cval:=color_tbl[cinx];
textbackground(cbkg_tbl[ciny]);
textcolor(color_tbl[cinx]);
end;
'B' : begin
cval:=cbkg_tbl[cinx];
textbackground(cbkg_tbl[cinx]);
textcolor(color_tbl[ciny]);
end;
end;
gotoxy(45,2);write(cflag);
write(cinx:2,' -',cval:3,' XX ');
gotoxy(58,2);write(ciny:2);
read(kbd,ch);
if ((ch=#27) and (keypressed)) then
begin
read(kbd,ch);
case ch of
(* f2 = blink = on/off *)
#60:if cval<16 then cval:=cval+16
else cval:=cval-16;
#61:ctbl_init; (* f3 = restore defaults *)
#62:begin (* f4 = toggle current table *)
if cflag='F' then
begin
cflag:='B';
cval:=cinx;
cinx:=ciny;
ciny:=cval;
cval:=cbkg_tbl[cinx];
end
else
begin
cflag:='F';
cval:=cinx;
cinx:=ciny;
ciny:=cval;
cval:=color_tbl[cinx];
end;
end;
#72:cinx:=cinx-1; (* arrow keys, adj val or index *)
#75:cval:=cval-1;
#77:cval:=cval+1;
#80:cinx:=cinx+1;
else beep;
end;
end
else
if ch=#32 then (* space bar, re-draw screen *)
begin putscrn3; setcttl; end;
if ((ch=#72) or (ch=#80)) then (* check index range valid *)
case cflag of
'F': begin
if cinx<0 then cinx:=15
else if cinx>15 then cinx:=0;
end;
'B': begin
if cinx<0 then cinx:=7
else if cinx>7 then cinx:=0;
end;
end
else
(* check color value valid *)
if ((ch=#60) or (ch=#75) or (ch=#77)) then
begin
if cval<0 then cval:=31
else if cval>31 then
cval:=0;
if cflag='F' then
color_tbl[cinx]:=cval
else
cbkg_tbl[cinx]:=cval;
end;
end;
until ((ch=#13) or (ch=#27) or (ch=#61)); (* exit on return, Esc or F3 *)
clrscr;
end;
procedure getnumdiscs; (* get number of disks for play and automatic modes *)
var flag,tmp:integer;
ch:char;
ust1:stsize;
begin
ust1:='';numberofdisks:=0;tmp:=0;
window(11,18,69,20); hv; clrscr;
repeat
begin
LV;
gotoxy(5,2);write(' Enter Number of Disc`s - '); HV;
inkey(ust1,1,35,2,60,[#13,#27],'N','x',TC);
val(ust1,tmp,flag);ust1:='';
if ((funckey) and (tc=#60)) then begin ssetspeed; end;
if ((funckey) and (tc=#59)) then begin help end;
if ((funckey) and (tc=#61)) then
begin ssetcolors; putscrn3; puttitle; window(11,18,69,20); end;
if funckey then tc:=#255;
end;
until ((TC=#27) or (tmp<=9) and (tmp<>0));
clrscr;
NumberofDisks:=tmp;
NMD:=tmp;
window(1,1,80,25);
LV;
end;
procedure puttt; (* draw all towers and disks on post 1 *)
var i:integer;
begin
window(2,5,79,15);
clrscr;
gotoxy(2,2); lv;
write('Disk#');
gotoxy(8,1);
write('Post#');
for i:=2 to 11 do
begin
textcolor(color_tbl[i]);
textbackground(cbkg_tbl[i div 2]);
gotoxy(18,i);write(#222,#221);
gotoxy(40,i);write(#222,#221);
gotoxy(62,i);write(#222,#221);
end;
hv;
gotoxy(18,1); write('1');
gotoxy(40,1); write('2');
gotoxy(62,1); write('3');
for i:=1 to nmd do
begin
textcolor(color_tbl[drow[i]+4]);
textbackground(cbkg_tbl[i+1 div 2]);
gotoxy(col[1,i],drow[i]);write(disks[i]);
hv; gotoxy(3,drow[i]); write(i:2);
end;
window(1,1,80,25);
end;
(* move a disk in play mode *)
Procedure showdisksP(N:discnotype; S,G:postnum);
var x:integer;
begin
window(2,5,79,15);hv;
gotoxy(col[g,n],drow[N]);
textcolor(color_tbl[drow[n]+1]);
textbackground(cbkg_tbl[((drow[n]+1) div 2)]);
write(disks[N]);
lv;
gotoxy(col[s,n],drow[N]);
write(conststr(#32,length(disks[n])));
case s of
1:gotoxy(18,drow[N]);
2:gotoxy(40,drow[N]);
3:gotoxy(62,drow[N]);
end;
textcolor(color_tbl[drow[n]]);
textbackground(cbkg_tbl[((drow[n]) div 2)]);
write(#222,#221);
end;
(* move a disk in automatic and random modes *)
Procedure showdisksA(N:discnotype; S,G:postnum);
var x:integer;
h_str:stsize;
nc,sc,gc,schar:char;
procedure int2char(var cc:char; num:integer);
begin
case num of
1:cc:='1';
2:cc:='2';
3:cc:='3';
4:cc:='4';
5:cc:='5';
6:cc:='6';
7:cc:='7';
8:cc:='8';
9:cc:='9';
0:cc:='0'
end;
end;
begin
window(11,18,69,20);
int2char(nc,n);
int2char(sc,s);
int2char(gc,g);
h_str:='Move disk - '+nc+' from post '+sc+' to post '+gc;
if movescroll then
SCROLLL(h_str,58,3,1,length(h_str))
else
begin
gotoxy(1,1); delline;
gotoxy(1,3);
write(h_str);
if click='Y' then begin sound(7920-(30*autospeed));delay(3);nosound;end;
chspeed(tc);
end;
window(2,5,79,15);
gotoxy(col[g,n],drow[N]);
textcolor(color_tbl[drow[n]]);
textbackground(cbkg_tbl[((drow[n]) div 2)]);
write(disks[N]);
gotoxy(col[s,n],drow[N]);
lv;
write(conststr(#32,length(disks[n])));
case s of
1:gotoxy(18,drow[N]);
2:gotoxy(40,drow[N]);
3:gotoxy(62,drow[N]);
end;
textcolor(color_tbl[drow[n]]);
textbackground(cbkg_tbl[((drow[n]) div 2)]);
write(#222,#221);
delay(Autospeed);
window(11,18,69,20);
end;
(* the recursive hanoi routine. used for automatic and random modes *)
(* nd = # of disks, on 1st call start = 1 and goal = 3 *)
Procedure Hanoi(nd:discnotype; start,Goal:postnum);
const allpost=6; (* sum of post vals/indexes 1, 2 & 3 *)
var freepost:postnum;
begin
recursecnt:=recursecnt+1; (* count recursive calls {moves} made. *)
Freepost:=allpost-start-goal; (* calc free post *)
if nd>1 then (* recursive case 1. move top nd-1 discs to free *)
Hanoi(nd-1,start,freepost);
showdisksA(nd,start,Goal); (* base case move bottom disc to goal *)
if nd>1 then (* recursive case 2. move top nd-1 discs to goal *)
Hanoi(nd-1,freepost,goal);
end;
procedure puttowers; (* calculate coordinates and initialize disk vars *)
var i,c,x,j:integer;
TmpCol:real;
begin
x:=0; tmpcol:=nmd;
col[1,nmd]:=16-round(tmpcol/2);
col[2,nmd]:=38-round(tmpcol/2);
col[3,nmd]:=60-round(tmpcol/2);
for i:=1 to 3 do
begin
case nmd of
1 :col[i,nmd]:=col[i,nmd]+2;
2,3: col[i,nmd]:=col[i,nmd]+1;
6,7: col[i,nmd]:=col[i,nmd]-1;
8,9: col[i,nmd]:=col[i,nmd]-2;
end;
end;
j:=nmd;
for i:=1 to nmd do
begin
if x=0 then
begin
disks[i]:=(conststr(#178,(2*(nmd-j+2)))); x:=1
end
else
begin
disks[i]:=(conststr(#176,(2*(nmd-j+2)))); x:=0;
end;
drow[j]:=(13-i-1);
col[1,j-1]:=col[1,j]+1;col[2,j-1]:=col[2,j]+1;col[3,j-1]:=col[3,j]+1;
j:=j-1;
end;
puttt;
end;
Procedure DoAuto; (* automatic mode until Esc. {and current puzzle done} *)
begin
getnumdiscs;
if tc<>#27 then
begin
repeat
begin
puttitle;
recursecnt:=0;
puttowers;
HV; gotoxy(63,3);write(conststr(#32,12));
gotoxy(3,1);write(' Start time ');gotoxy(3,3);write(time);
window(2,5,79,15);
Hanoi(numberofdisks,1,3);
window(1,1,80,25);
gotoxy(64,1);HV;
write(' End time ');gotoxy(63,3);write(time);
lv;
gotoxy(5,23);write(conststr(#32,70));
gotoxy(15,23);write(' PC can do it in only - ');
HV;write(recursecnt);LV;write(' Moves.');
getnumdiscs;
end;
until ((tc=#27));
end;
tc:=#255;
end;
procedure getrdd; (* get random values for random mode *)
var tmp:integer;
begin
tmp:=random(8)+1;
NumberofDisks:=tmp;
NMD:=tmp;
autospeed:=random(200)+5;
for tmp:=0 to 15 do
begin
color_tbl[tmp]:=random(16);
cbkg_tbl[tmp]:=random(16);
end;
end;
Procedure DoAutor; (* do random mode until Esc {and current puzzle done} *)
var nk:char;
begin
getrdd;
repeat
begin
recursecnt:=0;
puttowers;
puttitle;
gotoxy(3,1);write(' Start time ');gotoxy(3,3);write(time);
window(2,5,79,15);
Hanoi(numberofdisks,1,3);
window(1,1,80,25);
gotoxy(64,1);HV;
write(' End time ');gotoxy(63,3);write(time);
lv;
gotoxy(5,23);write(conststr(#32,70));
gotoxy(15,23);write(' PC can do it in only - ');
HV;write(recursecnt);LV;write(' Moves.');
getrdd;
delay(autospeed*10);
end;
until (tc=#27);
tc:=#255;
end;
procedure domodeP; (* play the game. manual mode *)
Label QQ; (* lable for GOTO's !! {bad,bad,bad} *)
var n,s,G,Flag,h:integer;
ld,dn:array[1..3] of integer;
ppos:array[1..9] of integer;
vind:char;
ust1:stsize;
begin
window(11,18,69,20);dn[1]:=nmd;dn[2]:=0;dn[3]:=0;
ld[1]:=1;ld[2]:=nmd;ld[3]:=nmd;fillchar(ppos,sizeof(ppos),0);
for h:=1 to nmd do ppos[h]:=1;
repeat
begin
gotoxy(1,1);delline; vind:='Y';
gotoxy(1,3);write('Move disk - ');
repeat
begin
N:=0;ust1:='';
inkey(ust1,1,13,3,60,[#13,#27],'N','x',TC);
val(UST1,n,flag);
end;
until ((n>0) and (n<=nmd) or (tc=#27) or (tc=#68));
If ((tc=#27) or (tc=#68)) then goto QQ;
gotoxy(15,3);write(' from post ');
repeat
begin
ust1:='';s:=0;
inkey(ust1,1,28,3,60,[#13,#27],'N','x',TC);
val(ust1,s,flag);
end;
until ((s>0) and (s<=3) or (tc=#27) or (tc=#68));
if ((tc=#27) or (tc=#68)) then goto QQ;
gotoxy(30,3);write(' to post ');
repeat
begin
ust1:='';g:=0;
inkey(ust1,1,41,3,60,[#13,#27],'N','x',TC);
val(ust1,g,flag);
end;
until ((g>0) and (g<=3) or (tc=#27) or (tc=#68));
if ((tc=#27) or (tc=#68)) then goto QQ;
if s=g then vind:='N';
if ((n>ld[g]) or (n>ld[s])) then vind:='N';
if ppos[n]<>s then vind:='N';
if dn[s]=0 then vind:='N';
if vind='Y' then
begin
showdisksP(n,s,g);
dn[g]:=dn[g]+1;
ld[g]:=n;ppos[n]:=g;
dn[s]:=dn[S]-1;
ld[s]:=0;
repeat
ld[s]:=ld[s]+1;
until ((ppos[ld[s]]=s) or (ld[s]>=nmd));
{eeendee}
end
else
begin beep;delay(25);Beep; gotoxy(45,3);write('ERROR'); delay(250);end;
{endif};
window(11,18,69,20);
recursecnt:=recursecnt+1;
QQ: If ((dn[3]=nmd) or (tc=#27)) then gamedone:=True;
if ((dn[3]=nmd)) then Udone:=True;
if ((funckey) and (tc=#59)) then begin help end;
end;
Until Gamedone;
end;
Procedure Playit; (* get # of disks and play until Esc *)
begin
getnumdiscs;
if tc<>#27 then
begin
repeat
begin
puttitle;
recursecnt:=0;
puttowers; gamedone:=false; Udone:=false;
HV; gotoxy(63,3);write(conststr(#32,12));
gotoxy(3,1);write(' Start time ');gotoxy(3,3);write(time);
doModeP;
window(1,1,80,25);
gotoxy(64,1);HV;
write(' End time ');gotoxy(63,3);write(time);LV;
gotoxy(15,23);write(' You ');hv;
if Udone=true then write(' did it ') else write (' FAILED ');
lv;write(' in ');hv;
write(recursecnt);LV;write(' Moves.');recursecnt:=0;delay(2500);
HV;write(' PC ');lv;write('can do it in - ');hv;puttt;
Hanoi(numberofdisks,1,3);
window(1,1,80,25);
hv;
gotoxy(62,23);write(recursecnt);lv;write(' Moves.');
delay(2500);
getnumdiscs;
end;
until ((tc=#27));
end;
Tc:=#255;
end;
procedure getgamemode; (* select game mode Play, Auto or Random *)
var ust1:stsize;
begin
window(11,18,69,20);clrscr;
repeat
begin
lv;
gotoxy(15,1);Write('Enter a ');HV;write('P');LV;write(' to Play the Game.');
gotoxy(3,3);Write('Enter an ');HV;write('A');LV;write(' to See PC do it.');
Write(' Enter an ');HV;write('R');LV;write(' for Random demo.');
HV;
gotoxy(17,2);write(' Enter Game Mode - ');
ust1:='';
inkey(ust1,1,36,2,60,[#13,#27],'A','L',TC);
if not funckey then gmode:=ust1;
if ((funckey) and (tc=#59)) then begin help end;
if ((funckey) and (tc=#60)) then begin ssetspeed; end;
if ((funckey) and (tc=#61)) then
begin ssetcolors; putscrn3; puttitle; window(11,18,69,20); end;
if funckey then tc:=#255;
end;
until ((TC=#27) or (gmode='A') or (gmode='P') or (gmode='R'));
clrscr;
end;
BEGIN (* main program *)
ctbl_init; (* initalize color tables and other global vars *)
movescroll:=false;
click:='Y';
autospeed:=50;
putscrn3; (* draw the screen *)
repeat
begin
Gmode:='?';
puttitle;
GetGameMode; (* get the game mode and do it until Esc *)
if Gmode='A' then
Doauto
else
if gMode='P' then
Playit
else
if gMode='R' then
doautor;
{endif};
end;
until TC=#27;
ctbl_init; (* restore default colors and exit *)
lv;
window(1,1,80,25);
clrscr;
gotoxy(1,24);
end.