home *** CD-ROM | disk | FTP | other *** search
/ Current Shareware 1994 January / SHAR194.ISO / games / thanoi.zip / HANOI.PAS < prev   
Pascal/Delphi Source File  |  1993-01-29  |  30KB  |  1,088 lines
  1. {$C-}              (* no <ctrl><break> *)
  2.  
  3. Program TestHanoi(input,output);
  4.  
  5. const helpsize=9;  (* # of lines in const messh1 <help text> *)
  6.  
  7.  
  8. Type
  9.    DiscNoType = 1..64;
  10.    Postnum = 1..3;
  11.    charset= set of char;
  12.    stsize=string[128];
  13.    mc5array=array[1..helpsize] of stsize;  (* used for help constant *)
  14.    datestr=string[12];
  15.    disktype=string[24];                    (* used for disk strings *)
  16.    ctbl_type=array[0..15] of integer;      (* used for color tables *)
  17.  
  18. var
  19.   numberofdisks:DiscNoType;
  20.   Sttime,Endtime:datestr;
  21.   NMD,Recursecnt,Autospeed:integer;        (* NMD = number disks *)
  22.                                     (* recursecnt = # calls to hanoi proc *)
  23.   gmode:stsize;                            (* gmode = game mode *)
  24.   disks:array[1..10] of disktype;
  25.   drow:array[1..10] of integer;                 (* row coordinates *)
  26.   col:array[1..3] of array [1..10] of integer;  (* column coordinates *)
  27.   Nch,TC,scrolldone,click:char;
  28.   Gamedone,Funckey,Udone,movescroll:boolean;
  29.   color_tbl,ctbl_def,cbkg_tbl:ctbl_type;        (* color tables *)
  30.  
  31.      (* The help text.  *)
  32.  
  33. const
  34.   messh1:MC5aRRay=   ('!!! Set Game mode For Play, Automatic or Random demo. ',
  35.       '',
  36.       ' Play - Try to solve game yourself; ',
  37.       ' Move ALL discs to Tower 3 WITHOUT putting a larger ',
  38.       '   disc on top of a smaller one. ',
  39.       ' Use F10 to re-enter a move.  Use F3 to set colors. ',
  40.       ' Use Esc for previous Screen or to Quit.  ',
  41.       ' Automatic - Watch PC play 1 game, You set parameters. ',
  42.       ' Random demo - Watch PC play continuously. ');
  43.  
  44. (*  procs hv & lv set colors for most of the text messages... *)
  45. (*  adjust at runtime via F3.  F - 14, B - 1 /  F - 7, B - 0  *)
  46.  
  47. procedure HV;
  48. begin
  49.   textcolor(color_tbl[14]);
  50.   textbackground(cbkg_tbl[1]);
  51. end;
  52.  
  53. Procedure LV;
  54. begin
  55.   textcolor(color_tbl[7]);
  56.   textbackground(cbkg_tbl[0]);
  57. end;
  58.  
  59.    procedure FrameY(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
  60.    var
  61.       i: Integer;
  62.    begin
  63.  
  64.       GotoXY(UpperLeftX, UpperLeftY);  Write(chr(220));
  65.       for i:=UpperLeftX+1 to LowerRightX-1 do Write(chr(220));
  66.       Write(chr(220));
  67.       for i:=UpperLeftY+1 to LowerRightY-1 do
  68.       begin
  69.          GotoXY(UpperLeftX , i);  Write(chr(221));
  70.          GotoXY(LowerRightX, i);  Write(chr(222));
  71.       end;
  72.       GotoXY(UpperLeftX, LowerRightY);
  73.       Write(chr(223));
  74.       for i:=UpperLeftX+1 to LowerRightX-1 do Write(chr(223));
  75.       Write(chr(223));
  76.    end  { Frame };
  77.  
  78.  
  79.   (* return N length string of char C { from turbo manual i think} *)
  80.  
  81. function ConstStr(C : Char; N : Integer) : Stsize;
  82. var
  83.   S : stsize;
  84. begin
  85.   if N < 0 then
  86.     N := 0;
  87.   S[0] := Chr(N);
  88.   FillChar(S[1],N,C);
  89.   ConstStr := S;
  90. end;
  91.  
  92. (* checks for keypress, process L & R arrow keys for autospeed adj. *)
  93. (* toggle click (F3) and scroll mode (F4) vars in help display and  *)
  94. (* Auto and Random modes.   Returns other key stokes in var sch.    *)
  95.  
  96. procedure chspeed(var sch:char);
  97. begin
  98.      if keypressed then
  99.         begin
  100.           read(kbd,sch);
  101.           case sch of
  102.             #32 : begin
  103.                     repeat {nothing} until keypressed;
  104.                     read(kbd,sch);
  105.                   end;
  106.             #27 : begin if keypressed then
  107.                             begin
  108.                               read(kbd,sch);
  109.                               case sch of
  110.                                 #75 : autospeed:=autospeed-25;
  111.                                 #77 : autospeed:=autospeed+25;
  112.                                 #61 : if click='Y' then click:='N'
  113.                                       else click:='Y';
  114.                                 #62 : if movescroll then movescroll:=false
  115.                                      else movescroll:=true;
  116.                               end;
  117.                               if autospeed<26 then autospeed:=26;
  118.                               if autospeed>880 then autospeed:=880;
  119.                             end;
  120.                   end;
  121.           end;
  122.         end;
  123. end;
  124.  
  125.  
  126. (* Scrolls a string <type stsize> from right to left.  *)
  127. (* Original version scrolled a very large char array thru a *)
  128. (* small window.  Modified to scroll in help message and *)
  129. (* slide each line up in window.  If len2 = 0 window scrolls up. *)
  130.  
  131.  
  132. PROCeDURE SCROLLL(MESSAGE:stsize; WSIZE,ROW,scol,len2:INTEGER);
  133.                                   (* wsize = # columns in window *)
  134.                                   (* row,scol = start coordinates *)
  135.                                   (* len2 = length of MESSAGE *)
  136. VAR
  137.   SP,DP,bg,dl,J,cnt:INTEGER;
  138.   sch:char;
  139.   line:string[80];                (* part of message for each write... *)
  140. label 99;
  141.  
  142. procedure getline;
  143. var k:integer;
  144.  
  145. begin
  146.    if (j-bg)-1<wsize then
  147.      line:=conststr(' ',wsize-(j-bg)-1)
  148.    else
  149.      line:='';
  150.   for k:=bg to j do
  151.     if k<=len2 then line:=line+message[k]
  152.      else line:=line+' ';
  153. end;
  154.  
  155.  
  156. BEGIN
  157.   bg:=1; sp:=wsize; cnt:=0; j:=1;
  158.  
  159.   while ((J <= len2+abs(wsize-len2)+1) and (sch<>#27)) DO
  160.     BEGIN
  161.       gotoxy(scol,row);
  162.       getline;
  163.       if click='Y' then begin sound(7920-(30*autospeed));delay(3);nosound;end;
  164.       delay(3);
  165.       chspeed(sch);
  166.  
  167.       write(line);
  168.       cnt:=cnt+1;
  169.       if ((cnt=wsize) or (len2=0)) then
  170.        begin
  171.          gotoxy(1,1);
  172.          delline;
  173.          cnt:=0;
  174.          sp:=wsize+1;
  175.          bg:=bg+wsize;
  176.          if len2=0 then j:=len2+abs(wsize-len2)+1;  (* exit if no string *)
  177.        end;
  178.       j:=j+1;
  179.       if sp<>1 then
  180.          sp:=sp-1
  181.       else
  182.          bg:=bg+1;
  183.  
  184.     end;
  185.  
  186.     if sch=#27 then scrolldone:='Y';
  187.     tc:=sch;
  188. END;
  189.  
  190.  
  191. procedure puttitle;
  192. begin
  193.   lv;
  194.   gotoxy(5,23);write(conststr(#32,70));
  195.   hv;
  196.   gotoxy(12,25);
  197.   case gmode of
  198.     '?'     : begin
  199.                write(' F1 = Help.  F2 = Set Speed.  F3 = '+
  200.                                     'Set Colors.  Esc = Quit. ');
  201.               end;
  202.     'P'     : begin
  203.                write(' F1 = Help.  F10 = Re-start current move.  Esc = Give up.   ');
  204.               end;
  205.     'A','R' : begin
  206.                write(' L/R arrows adjust speed,  ESC = To Main Menu after game.   ');
  207.                gotoxy(15,23); lv;
  208.                write('  F3 = Toggle click.  F4 = Toggle Scroll Mode.  ');
  209.  
  210.               end;
  211.   end;
  212.  
  213. end;
  214.  
  215.  
  216.  
  217. Procedure help;     (* the help screen routine *)
  218.   var sphold,htinx:integer;
  219. BEGIN
  220.    window(1,1,80,25);
  221.    textcolor(color_tbl[3]);
  222.    textbackground(cbkg_tbl[2]);
  223.    gotoxy(5,23);write(conststr(#32,70));
  224.    textcolor(color_tbl[15]);
  225.    textbackground(cbkg_tbl[5]);
  226.    gotoxy(12,25);write(conststr(#32,60));
  227.    gotoxy(15,23); hv;
  228.    write('  F3 = Toggle click.  F4 = Toggle Scroll Mode.  ');
  229.    lv;
  230.    WINDOW(11,18,69,20);clrscr; hv;
  231.    gotoxy(1,2);clreol;write('  Use L/R arrows - Scroll speed, Space - pause, ESC - end.');
  232.    Window(2,5,79,15); lv; clrscr;
  233.    Window(15,5,75,15);
  234.    scrolldone:='N'; hv;
  235.    sphold:=autospeed;
  236.    autospeed:=autospeed*4;
  237.    htinx:=1;
  238.  
  239.      while ((htinx<=helpsize) and (scrolldone='N')) do
  240.       begin
  241.         SCROLLL(messh1[htinx],60,11,1,length(messh1[htinx]));
  242.         htinx:=htinx+1;
  243.       end;
  244.  
  245.    if tc<>#27 then                         (* wait unless ESC hit *)
  246.      repeat (* nothing *) until keypressed;
  247.  
  248.    lv; clrscr;
  249.    window(1,1,80,25);
  250.    puttitle;
  251.    WINDOW(11,18,69,20);
  252.    clrscr;
  253.    autospeed:=sphold;
  254. END;
  255.  
  256.  
  257. procedure beep;
  258. begin
  259.    write(^G);
  260. end;
  261.  
  262.  
  263. Procedure Putscrn3;    (* draw main screen & boxes... *)
  264. begin
  265.    window(1,1,80,25);
  266.    lv;
  267.    clrscr;
  268.    textcolor(color_tbl[12]);
  269.    framey(20,1,60,3);
  270.    textcolor(color_tbl[13]);
  271.    frameY(10,17,70,21);
  272.    textcolor(color_tbl[14]);
  273.    gotoxy(2,25);write(conststr(#219,78));
  274.    textcolor(color_tbl[9]);
  275.    frameY(1,4,80,16);
  276.    textcolor(color_tbl[7]);
  277.    framey(1,22,80,24);
  278.    HV; gotoxy(28,2);write('The Towers Of Hanoi !?!?');LV;
  279.    gotoxy(19,4);write(' ** Written by Scott Armitage. (c) 1993 ** ');
  280.  
  281. end;
  282.  
  283.  
  284.   (* returns system time.  Modified from routine whose origins I forgot... *)
  285.  
  286. function Time: DateStr;
  287. type
  288.   regpack = record
  289.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  290.             end;
  291.  
  292. var
  293.   recpack:       regpack;                {record for MsDos call}
  294.   dx,cx:         integer;
  295.   hr,min,sec,hsec: string[3];
  296.  
  297. procedure fixsize;
  298. begin
  299.   if length(hr)=1 then hr:='0'+hr;
  300.   if length(min)=1 then min:='0'+min;
  301.   if length(sec)=1 then sec:='0'+sec;
  302.   if length(hsec)=1 then hsec:='0'+hsec;
  303. end;
  304.  
  305. begin
  306.   with recpack do
  307.   begin
  308.     ax := $2c shl 8;
  309.   end;
  310.   MsDos(recpack);                        { call function }
  311.   with recpack do
  312.   begin
  313.     str(cx shr 8,hr);                       {convert to string}
  314.     str(cx mod 256,min);                     { " }
  315.     str(dx shr 8,sec);                     { " }
  316.     str(dx mod 256,hsec);
  317.   end;
  318.   fixsize;
  319.   time:=hr+':'+min+':'+sec+'.'+hsec;
  320. end;
  321.  
  322.  
  323. (* nifty consol input routine *)
  324.  
  325. procedure INKEY(var S        : stsize;     (* var to be input/edited, may  *)
  326.                                            (* contain init value.          *)
  327.                        L,X,Y,ws : Integer; (* L=max length, X,Y=Column,Row *)
  328.                                         (* ws=number of columns in window. *)
  329.                        Term     : CharSet; (* characters that will end input *)
  330.                                    (* may be any key or 2nd function key val *)
  331.  
  332.                        AN,CP    : char;  (* alphanumeric and case switches *)
  333.                    var TChar     : Char);
  334.  
  335. const
  336.   UnderScore  = #176;
  337. var
  338.   P : Integer;
  339.   Ch,Vind : Char;
  340.  
  341. procedure chAN;
  342. begin
  343.    vind:='N';
  344.    if UpCase(CH) in['A'..'Z','.','?','!',#44] then
  345.        vind:='Y';
  346.    IF ch=' ' THEN VIND:='Y';
  347. end;
  348.  
  349. procedure chnum;
  350. begin
  351.    vind:='N';
  352.    if ch in['0'..'9','.','$',' ','%',#44] then vind:='Y';
  353. end;
  354.  
  355. PROCEDURE PUTS;
  356. var workV,Tmpr:integer;
  357. BEGIN
  358.    gotoxy(x,y); write(S,CONSTSTR(UNDERSCORE,L-LENGTH(S)));
  359.    workV:=0;Tmpr:=0;
  360.    if (p+x)>ws then
  361.        begin
  362.          repeat
  363.            begin
  364.               workV:=WorkV+(ws); Tmpr:=tmpr+1;
  365.            end;
  366.          until (workV>=p+x);
  367.          workV:=workV+x-1;
  368.          gotoxy((p+x+ws-workV),tmpr);
  369.        end
  370.    else
  371.       gotoxy(x+p,y);
  372. {endif};
  373. END;
  374.  
  375. begin
  376.   P :=Length(S);puts;
  377.      funckey:=false;tchar:=#255;
  378.   repeat
  379.    begin
  380.  
  381.     Read(Kbd,Ch);
  382.     If ((ch=#27) and keypressed) then
  383.                   Begin
  384.                      Read(Kbd,Ch);
  385.                      Case Ch Of
  386.                              #71 : Ch:=^A;     {  Home }
  387.                              #79 : ch:=^F;     {  End }
  388.                              #77 : Ch:=^D;     { RightArrow }
  389.                              #75 : Ch:=^S;     { LeftArrow }
  390.                              #83 : ch:=^G;     {PC-DEL}
  391.                              #30..#68 : begin funckey:=true; end;
  392.                            else
  393.                               ch:=#00;
  394.                       End;
  395.                    end
  396.    else
  397.      If ch=#27 then
  398.             begin
  399.                s:='';p:=0;
  400.             end;
  401.    {endif};
  402.    case ch of
  403.       #32..#126 : if ((length(s) < L) and (not funckey)) then
  404.                   begin
  405.                     vind:='Y';
  406.                     if an='A' then chan;
  407.                     if an='N' then chnum;
  408.                     if ((vind='Y') and (cp='L')) then ch:=UpCase(ch);
  409.                     if vind='Y' then
  410.                        begin
  411.                          P := P + 1;
  412.                          Insert(Ch,S,P);
  413.                        end
  414.                      else beep;
  415.                   end
  416.                   else
  417.                      if not funckey then
  418.                         begin
  419.                           beep; p:=l; s:=copy(s,1,l);
  420.                         end;
  421.       ^S        : if P > 0 then
  422.                     P := P - 1
  423.                   else Beep;
  424.       ^D        : if P < Length(S) then
  425.                      P := P + 1
  426.                   else Beep;
  427.       ^A        : if p=0 then beep else P := 0;
  428.       ^F        : if p=length(s) then beep else P:=length(S);
  429.       ^G        : if P < Length(S) then
  430.                     Delete(S,P + 1,1)
  431.                   else beep;
  432.       ^H,#127   : if P > 0 then
  433.                   begin
  434.                      delete(S,P,1);p:=p-1;
  435.                   end
  436.                   else Beep;
  437.       ^Y,^X    : if length(s)=0 then
  438.                     beep
  439.                  else
  440.                  begin
  441.                     S:=''; P:=0;
  442.                   end;
  443.       ^T       : if p < length(s) then
  444.                     begin
  445.                        delete(s,p+1,(length(s)-p));
  446.                        p:=length(s);
  447.                     end else beep;
  448.     else
  449.       if (not (Ch in Term) and (not funckey)) then Beep;
  450.     end;  {of case}
  451.     PUTS;
  452.    end;
  453.   until ((Ch in Term) or (funckey) OR (P=L));
  454.   P := Length(S);
  455.   puts;
  456.   TChar := Ch;
  457. end;
  458.  
  459.  
  460. procedure ssetspeed;  (* routine to adjust global autospeed variable *)
  461.                (* probably unneccesary due to speed adj in chspeed proc *)
  462. var ch:char;
  463. begin
  464.    textcolor(color_tbl[9]);
  465.    textbackground(cbkg_tbl[4]);
  466.    clrscr;
  467.    hv;
  468.    gotoxy(5,1);write('Use L, R arrow keys');
  469.    gotoxy(5,2);write(' to set AutoSpeed,');
  470.    Gotoxy(5,3);write('Enter for Selection.');
  471.    textcolor(color_tbl[11]);
  472.    textbackground(cbkg_tbl[2]);
  473.    framey(40,1,50,3);
  474.    hv;
  475. if tc<>#27 then
  476.    repeat
  477.       Begin
  478.          gotoxy(43,2);write('     ');
  479.          gotoxy(44,2);write(Autospeed);
  480.          read(kbd,ch);
  481.          if ((ch=#27) and (keypressed)) then
  482.            begin
  483.               read(kbd,ch);
  484.               case ch of
  485.                 #75:Autospeed:=autospeed-5;
  486.                 #77:autospeed:=autospeed+5;
  487.                else beep;
  488.               end;
  489.            end;
  490.          if autospeed<0 then autospeed:=500
  491.            else
  492.              if autospeed>880 then autospeed:=0;
  493.  
  494.        end;
  495.    until ((ch=#13) or (ch=#27));
  496.    clrscr;
  497. end;
  498.  
  499.  
  500. procedure ctbl_init;  (* set inital vals for default color table... *)
  501.   var x:integer;
  502. begin
  503.   for x:=0 to 15 do
  504.       ctbl_def[x]:=x;
  505.   for x:=0 to 15 do
  506.       color_tbl[x]:=x;
  507.  
  508.   for x:=0 to 15 do
  509.       cbkg_tbl[x]:=x;
  510.  
  511. end;
  512.  
  513. procedure setcttl;   (* draw prompts for set colors proc *)
  514. begin
  515.   textcolor(color_tbl[13]);
  516.   textbackground(cbkg_tbl[4]);
  517.   gotoxy(5,23);write(conststr(#32,70));
  518.   gotoxy(15,23);hv; write(' Return or Esc to exit.  Space = Re-Draw screen. ');
  519.   textcolor(color_tbl[1]);
  520.   textbackground(cbkg_tbl[7]);
  521.   gotoxy(12,25);write(conststr(#32,60));
  522.  
  523.   window(11,18,69,20);
  524.   textcolor(color_tbl[10]);
  525.   textbackground(cbkg_tbl[5]);
  526.    clrscr;
  527.    hv;
  528.    gotoxy(3,1);write('Use L, R, U & D arrow keys to set ');
  529.    gotoxy(3,2);write('& select colors,  F2=Toggle blink,');
  530.    Gotoxy(3,3);write('F3=Default vals,  F4=Toggle table.');
  531.    textcolor(color_tbl[3]);
  532.    textbackground(cbkg_tbl[5]);
  533.    framey(44,1,57,3);
  534. end;
  535.  
  536.  
  537.  
  538. (* procedure to adjust values in color tables. *)
  539. (* the values and 'XX' will be displayed useing the current *)
  540. (* value being adjusted and the last Foreground/Background *)
  541. (* value that was selected.  F4 toggles between the 2. *)
  542. (* the index of the last Foreground/Background selected will *)
  543. (* be displayed to the right of the 'XX'.  No check are made *)
  544. (* to prevent F & B from being set to the same value. *)
  545. (* if you do this your text will vanish for that combo *)
  546. (* on MDA and other monochrome monitors I tested, the *)
  547. (* background value has no effect. *)
  548.  
  549.  
  550. procedure ssetcolors;
  551. var ch,cflag:char;          (* ch = input char, cflag = switch for F or B *)
  552.     cinx,ciny,cval:integer; (* cval = value in table. cinx = current index *)
  553.                             (* ciny = previous table index *)
  554.  
  555. begin
  556.   window(1,1,80,25);
  557.    setcttl;
  558.    cinx:=0; ciny:=7; cflag:='F';
  559.  
  560.    repeat
  561.       Begin
  562.          case cflag of
  563.            'F' : begin
  564.                   cval:=color_tbl[cinx];
  565.                   textbackground(cbkg_tbl[ciny]);
  566.                   textcolor(color_tbl[cinx]);
  567.                 end;
  568.            'B' : begin
  569.                   cval:=cbkg_tbl[cinx];
  570.                   textbackground(cbkg_tbl[cinx]);
  571.                   textcolor(color_tbl[ciny]);
  572.                  end;
  573.          end;
  574.  
  575.          gotoxy(45,2);write(cflag);
  576.          write(cinx:2,' -',cval:3,' XX ');
  577.          gotoxy(58,2);write(ciny:2);
  578.  
  579.          read(kbd,ch);
  580.          if ((ch=#27) and (keypressed)) then
  581.            begin
  582.               read(kbd,ch);
  583.               case ch of
  584.                      (* f2 = blink = on/off *)
  585.                 #60:if cval<16 then cval:=cval+16
  586.                     else cval:=cval-16;
  587.                 #61:ctbl_init;   (* f3 = restore defaults *)
  588.                 #62:begin        (* f4 = toggle current table *)
  589.                      if cflag='F' then
  590.                        begin
  591.                          cflag:='B';
  592.                          cval:=cinx;
  593.                          cinx:=ciny;
  594.                          ciny:=cval;
  595.                          cval:=cbkg_tbl[cinx];
  596.                        end
  597.                      else
  598.                        begin
  599.                          cflag:='F';
  600.                          cval:=cinx;
  601.                          cinx:=ciny;
  602.                          ciny:=cval;
  603.                          cval:=color_tbl[cinx];
  604.                        end;
  605.                     end;
  606.                 #72:cinx:=cinx-1;   (* arrow keys, adj val or index *)
  607.                 #75:cval:=cval-1;
  608.                 #77:cval:=cval+1;
  609.                 #80:cinx:=cinx+1;
  610.                else beep;
  611.               end;
  612.            end
  613.           else
  614.           if ch=#32 then         (* space bar, re-draw screen *)
  615.             begin putscrn3; setcttl; end;
  616.  
  617.  
  618.  
  619.         if ((ch=#72) or (ch=#80)) then  (* check index range valid *)
  620.             case cflag of
  621.              'F': begin
  622.                    if cinx<0 then cinx:=15
  623.                     else if cinx>15 then cinx:=0;
  624.                   end;
  625.              'B': begin
  626.                    if cinx<0 then cinx:=7
  627.                     else if cinx>7 then cinx:=0;
  628.                   end;
  629.             end
  630.          else
  631.                    (* check color value valid *)
  632.        if ((ch=#60) or (ch=#75) or (ch=#77)) then
  633.           begin
  634.             if cval<0 then cval:=31
  635.              else if cval>31 then
  636.                cval:=0;
  637.             if cflag='F' then
  638.               color_tbl[cinx]:=cval
  639.             else
  640.               cbkg_tbl[cinx]:=cval;
  641.            end;
  642.  
  643.  
  644.        end;
  645.    until ((ch=#13) or (ch=#27) or (ch=#61));  (* exit on return, Esc or F3 *)
  646.    clrscr;
  647. end;
  648.  
  649.  
  650.  
  651.  
  652.  
  653. procedure getnumdiscs;  (* get number of disks for play and automatic modes *)
  654. var flag,tmp:integer;
  655.    ch:char;
  656.    ust1:stsize;
  657. begin
  658.    ust1:='';numberofdisks:=0;tmp:=0;
  659.    window(11,18,69,20); hv; clrscr;
  660.    repeat
  661.      begin
  662.         LV;
  663.         gotoxy(5,2);write(' Enter Number of Disc`s - '); HV;
  664.         inkey(ust1,1,35,2,60,[#13,#27],'N','x',TC);
  665.         val(ust1,tmp,flag);ust1:='';
  666.         if ((funckey) and (tc=#60)) then begin ssetspeed; end;
  667.         if ((funckey) and (tc=#59)) then begin  help end;
  668.         if ((funckey) and (tc=#61)) then
  669.           begin ssetcolors; putscrn3; puttitle;  window(11,18,69,20); end;
  670.         if funckey then tc:=#255;
  671.      end;
  672.    until ((TC=#27) or (tmp<=9) and (tmp<>0));
  673.    clrscr;
  674.    NumberofDisks:=tmp;
  675.    NMD:=tmp;
  676.  
  677.    window(1,1,80,25);
  678.    LV;
  679. end;
  680.  
  681. procedure puttt;   (* draw all towers and disks on post 1 *)
  682. var i:integer;
  683. begin
  684.    window(2,5,79,15);
  685.    clrscr;
  686.    gotoxy(2,2); lv;
  687.    write('Disk#');
  688.    gotoxy(8,1);
  689.    write('Post#');
  690.    for i:=2 to 11 do
  691.      begin
  692.        textcolor(color_tbl[i]);
  693.        textbackground(cbkg_tbl[i div 2]);
  694.        gotoxy(18,i);write(#222,#221);
  695.        gotoxy(40,i);write(#222,#221);
  696.        gotoxy(62,i);write(#222,#221);
  697.      end;
  698.    hv;
  699.    gotoxy(18,1); write('1');
  700.    gotoxy(40,1); write('2');
  701.    gotoxy(62,1); write('3');
  702.    for i:=1 to nmd do
  703.     begin
  704.       textcolor(color_tbl[drow[i]+4]);
  705.       textbackground(cbkg_tbl[i+1 div 2]);
  706.       gotoxy(col[1,i],drow[i]);write(disks[i]);
  707.       hv; gotoxy(3,drow[i]); write(i:2);
  708.     end;
  709.    window(1,1,80,25);
  710. end;
  711.  
  712.     (* move a disk in play mode *)
  713. Procedure showdisksP(N:discnotype; S,G:postnum);
  714. var x:integer;
  715. begin
  716.    window(2,5,79,15);hv;
  717.    gotoxy(col[g,n],drow[N]);
  718.    textcolor(color_tbl[drow[n]+1]);
  719.    textbackground(cbkg_tbl[((drow[n]+1) div 2)]);
  720.    write(disks[N]);
  721.    lv;
  722.    gotoxy(col[s,n],drow[N]);
  723.    write(conststr(#32,length(disks[n])));
  724.    case s of
  725.        1:gotoxy(18,drow[N]);
  726.        2:gotoxy(40,drow[N]);
  727.        3:gotoxy(62,drow[N]);
  728.     end;
  729.    textcolor(color_tbl[drow[n]]);
  730.    textbackground(cbkg_tbl[((drow[n]) div 2)]);
  731.    write(#222,#221);
  732. end;
  733.  
  734.  
  735.  (* move a disk in automatic and random modes *)
  736. Procedure showdisksA(N:discnotype; S,G:postnum);
  737. var x:integer;
  738.     h_str:stsize;
  739.     nc,sc,gc,schar:char;
  740.  
  741.     procedure int2char(var cc:char; num:integer);
  742.      begin
  743.       case num of
  744.         1:cc:='1';
  745.         2:cc:='2';
  746.         3:cc:='3';
  747.         4:cc:='4';
  748.         5:cc:='5';
  749.         6:cc:='6';
  750.         7:cc:='7';
  751.         8:cc:='8';
  752.         9:cc:='9';
  753.         0:cc:='0'
  754.       end;
  755.      end;
  756.  
  757. begin
  758.    window(11,18,69,20);
  759.    int2char(nc,n);
  760.    int2char(sc,s);
  761.    int2char(gc,g);
  762.    h_str:='Move disk - '+nc+'  from post  '+sc+'  to post  '+gc;
  763.    if movescroll then
  764.      SCROLLL(h_str,58,3,1,length(h_str))
  765.    else
  766.      begin
  767.        gotoxy(1,1); delline;
  768.        gotoxy(1,3);
  769.        write(h_str);
  770.        if click='Y' then begin sound(7920-(30*autospeed));delay(3);nosound;end;
  771.        chspeed(tc);
  772.      end;
  773.  
  774.    window(2,5,79,15);
  775.    gotoxy(col[g,n],drow[N]);
  776.    textcolor(color_tbl[drow[n]]);
  777.    textbackground(cbkg_tbl[((drow[n]) div 2)]);
  778.    write(disks[N]);
  779.    gotoxy(col[s,n],drow[N]);
  780.    lv;
  781.    write(conststr(#32,length(disks[n])));
  782.    case s of
  783.        1:gotoxy(18,drow[N]);
  784.        2:gotoxy(40,drow[N]);
  785.        3:gotoxy(62,drow[N]);
  786.     end;
  787.    textcolor(color_tbl[drow[n]]);
  788.    textbackground(cbkg_tbl[((drow[n]) div 2)]);
  789.    write(#222,#221);
  790.    delay(Autospeed);
  791.    window(11,18,69,20);
  792. end;
  793.  
  794. (* the recursive hanoi routine. used for automatic and random modes *)
  795.  
  796. (* nd = # of disks, on 1st call start = 1 and goal = 3 *)
  797.  
  798. Procedure Hanoi(nd:discnotype; start,Goal:postnum);
  799.  
  800. const allpost=6;               (* sum of post vals/indexes 1, 2 & 3 *)
  801. var freepost:postnum;
  802. begin
  803.    recursecnt:=recursecnt+1;      (* count recursive calls {moves} made. *)
  804.    Freepost:=allpost-start-goal;  (* calc free post *)
  805.  
  806.    if nd>1 then       (* recursive case 1.  move top nd-1 discs to free *)
  807.       Hanoi(nd-1,start,freepost);
  808.  
  809.    showdisksA(nd,start,Goal);  (* base case move bottom disc to goal *)
  810.  
  811.    if nd>1 then       (* recursive case 2.  move top nd-1 discs to goal *)
  812.       Hanoi(nd-1,freepost,goal);
  813. end;
  814.  
  815.  
  816. procedure puttowers;  (* calculate coordinates and initialize disk vars *)
  817. var i,c,x,j:integer;
  818.     TmpCol:real;
  819. begin
  820.  
  821.    x:=0; tmpcol:=nmd;
  822.    col[1,nmd]:=16-round(tmpcol/2);
  823.    col[2,nmd]:=38-round(tmpcol/2);
  824.    col[3,nmd]:=60-round(tmpcol/2);
  825.    for i:=1 to 3 do
  826.      begin
  827.        case nmd of
  828.           1  :col[i,nmd]:=col[i,nmd]+2;
  829.           2,3: col[i,nmd]:=col[i,nmd]+1;
  830.           6,7: col[i,nmd]:=col[i,nmd]-1;
  831.           8,9: col[i,nmd]:=col[i,nmd]-2;
  832.         end;
  833.      end;
  834.    j:=nmd;
  835.    for i:=1 to nmd do
  836.     begin
  837.       if x=0 then
  838.         begin
  839.           disks[i]:=(conststr(#178,(2*(nmd-j+2)))); x:=1
  840.         end
  841.       else
  842.         begin
  843.           disks[i]:=(conststr(#176,(2*(nmd-j+2)))); x:=0;
  844.         end;
  845.       drow[j]:=(13-i-1);
  846.       col[1,j-1]:=col[1,j]+1;col[2,j-1]:=col[2,j]+1;col[3,j-1]:=col[3,j]+1;
  847.       j:=j-1;
  848.     end;
  849.    puttt;
  850.  
  851. end;
  852.  
  853. Procedure DoAuto;  (* automatic mode until Esc. {and current puzzle done} *)
  854. begin
  855.    getnumdiscs;
  856.    if tc<>#27 then
  857. begin
  858.  repeat
  859.   begin
  860.    puttitle;
  861.    recursecnt:=0;
  862.    puttowers;
  863.    HV; gotoxy(63,3);write(conststr(#32,12));
  864.    gotoxy(3,1);write(' Start time  ');gotoxy(3,3);write(time);
  865.    window(2,5,79,15);
  866.    Hanoi(numberofdisks,1,3);
  867.    window(1,1,80,25);
  868.    gotoxy(64,1);HV;
  869.    write(' End time  ');gotoxy(63,3);write(time);
  870.    lv;
  871.    gotoxy(5,23);write(conststr(#32,70));
  872.    gotoxy(15,23);write(' PC can do it in only - ');
  873.    HV;write(recursecnt);LV;write('  Moves.');
  874.    getnumdiscs;
  875.   end;
  876. until ((tc=#27));
  877. end;
  878.   tc:=#255;
  879. end;
  880.  
  881. procedure getrdd;   (* get random values for random mode *)
  882.  var tmp:integer;
  883.  begin
  884.    tmp:=random(8)+1;
  885.    NumberofDisks:=tmp;
  886.    NMD:=tmp;
  887.    autospeed:=random(200)+5;
  888.    for tmp:=0 to 15 do
  889.     begin
  890.      color_tbl[tmp]:=random(16);
  891.      cbkg_tbl[tmp]:=random(16);
  892.     end;
  893.  end;
  894.  
  895.  
  896. Procedure DoAutor;  (* do random mode until Esc {and current puzzle done} *)
  897.   var nk:char;
  898. begin
  899.    getrdd;
  900.  
  901.  repeat
  902.   begin
  903.    recursecnt:=0;
  904.    puttowers;
  905.    puttitle;
  906.  
  907.    gotoxy(3,1);write(' Start time  ');gotoxy(3,3);write(time);
  908.    window(2,5,79,15);
  909.    Hanoi(numberofdisks,1,3);
  910.    window(1,1,80,25);
  911.    gotoxy(64,1);HV;
  912.    write(' End time  ');gotoxy(63,3);write(time);
  913.    lv;
  914.    gotoxy(5,23);write(conststr(#32,70));
  915.    gotoxy(15,23);write(' PC can do it in only - ');
  916.    HV;write(recursecnt);LV;write('  Moves.');
  917.    getrdd;
  918.    delay(autospeed*10);
  919.   end;
  920. until (tc=#27);
  921.  
  922. tc:=#255;
  923. end;
  924.  
  925. procedure domodeP;     (* play the game.  manual mode *)
  926. Label QQ;              (* lable for GOTO's !! {bad,bad,bad} *)
  927.  
  928. var n,s,G,Flag,h:integer;
  929.     ld,dn:array[1..3] of integer;
  930.     ppos:array[1..9] of integer;
  931.     vind:char;
  932.     ust1:stsize;
  933.  
  934.  
  935. begin
  936.    window(11,18,69,20);dn[1]:=nmd;dn[2]:=0;dn[3]:=0;
  937.    ld[1]:=1;ld[2]:=nmd;ld[3]:=nmd;fillchar(ppos,sizeof(ppos),0);
  938.    for h:=1 to nmd do ppos[h]:=1;
  939. repeat
  940.  begin
  941.    gotoxy(1,1);delline;  vind:='Y';
  942.    gotoxy(1,3);write('Move disk - ');
  943.    repeat
  944.      begin
  945.        N:=0;ust1:='';
  946.        inkey(ust1,1,13,3,60,[#13,#27],'N','x',TC);
  947.        val(UST1,n,flag);
  948.      end;
  949.    until ((n>0) and (n<=nmd) or (tc=#27) or (tc=#68));
  950.   If ((tc=#27) or (tc=#68)) then goto QQ;
  951.    gotoxy(15,3);write('  from post  ');
  952.    repeat
  953.      begin
  954.        ust1:='';s:=0;
  955.        inkey(ust1,1,28,3,60,[#13,#27],'N','x',TC);
  956.        val(ust1,s,flag);
  957.      end;
  958.    until ((s>0) and (s<=3) or (tc=#27) or (tc=#68));
  959.    if ((tc=#27) or (tc=#68)) then goto QQ;
  960.    gotoxy(30,3);write('  to post  ');
  961.    repeat
  962.      begin
  963.        ust1:='';g:=0;
  964.        inkey(ust1,1,41,3,60,[#13,#27],'N','x',TC);
  965.        val(ust1,g,flag);
  966.      end;
  967.    until ((g>0) and (g<=3) or (tc=#27) or (tc=#68));
  968.    if ((tc=#27) or (tc=#68)) then goto QQ;
  969.    if s=g then vind:='N';
  970.    if ((n>ld[g]) or (n>ld[s]))  then vind:='N';
  971.    if ppos[n]<>s then vind:='N';
  972.    if dn[s]=0 then vind:='N';
  973.    if vind='Y' then
  974.       begin
  975.          showdisksP(n,s,g);
  976.          dn[g]:=dn[g]+1;
  977.          ld[g]:=n;ppos[n]:=g;
  978.          dn[s]:=dn[S]-1;
  979.          ld[s]:=0;
  980.          repeat
  981.            ld[s]:=ld[s]+1;
  982.          until ((ppos[ld[s]]=s) or (ld[s]>=nmd));
  983.          {eeendee}
  984.       end
  985.    else
  986.       begin beep;delay(25);Beep; gotoxy(45,3);write('ERROR'); delay(250);end;
  987.    {endif};
  988.    window(11,18,69,20);
  989.    recursecnt:=recursecnt+1;
  990.  
  991. QQ:   If ((dn[3]=nmd) or (tc=#27)) then gamedone:=True;
  992.       if ((dn[3]=nmd)) then Udone:=True;
  993.       if ((funckey) and (tc=#59)) then begin  help end;
  994.   end;
  995.  Until Gamedone;
  996. end;
  997.  
  998. Procedure Playit;  (* get # of disks and play until Esc *)
  999. begin
  1000.    getnumdiscs;
  1001.    if tc<>#27 then
  1002. begin
  1003.  repeat
  1004.   begin
  1005.    puttitle;
  1006.    recursecnt:=0;
  1007.    puttowers; gamedone:=false; Udone:=false;
  1008.    HV; gotoxy(63,3);write(conststr(#32,12));
  1009.    gotoxy(3,1);write(' Start time  ');gotoxy(3,3);write(time);
  1010.    doModeP;
  1011.    window(1,1,80,25);
  1012.    gotoxy(64,1);HV;
  1013.    write(' End time  ');gotoxy(63,3);write(time);LV;
  1014.    gotoxy(15,23);write(' You ');hv;
  1015.    if Udone=true then write(' did it ') else write (' FAILED ');
  1016.    lv;write(' in ');hv;
  1017.    write(recursecnt);LV;write('  Moves.');recursecnt:=0;delay(2500);
  1018.    HV;write(' PC ');lv;write('can do it in - ');hv;puttt;
  1019.    Hanoi(numberofdisks,1,3);
  1020.    window(1,1,80,25);
  1021.    hv;
  1022.    gotoxy(62,23);write(recursecnt);lv;write('  Moves.');
  1023.    delay(2500);
  1024.    getnumdiscs;
  1025.   end;
  1026. until ((tc=#27));
  1027. end;
  1028. Tc:=#255;
  1029. end;
  1030.  
  1031. procedure getgamemode;   (* select game mode Play, Auto or Random *)
  1032.   var ust1:stsize;
  1033. begin
  1034.    window(11,18,69,20);clrscr;
  1035.    repeat
  1036.      begin
  1037.         lv;
  1038.         gotoxy(15,1);Write('Enter a ');HV;write('P');LV;write(' to Play the Game.');
  1039.         gotoxy(3,3);Write('Enter an ');HV;write('A');LV;write(' to See PC do it.');
  1040.         Write('  Enter an ');HV;write('R');LV;write(' for Random demo.');
  1041.         HV;
  1042.         gotoxy(17,2);write(' Enter Game Mode - ');
  1043.         ust1:='';
  1044.         inkey(ust1,1,36,2,60,[#13,#27],'A','L',TC);
  1045.         if not funckey then gmode:=ust1;
  1046.         if ((funckey) and (tc=#59)) then begin  help end;
  1047.         if ((funckey) and (tc=#60)) then begin ssetspeed; end;
  1048.         if ((funckey) and (tc=#61)) then
  1049.           begin ssetcolors; putscrn3; puttitle;  window(11,18,69,20); end;
  1050.         if funckey then tc:=#255;
  1051.      end;
  1052.    until ((TC=#27) or (gmode='A') or (gmode='P') or (gmode='R'));
  1053.    clrscr;
  1054. end;
  1055.  
  1056.  
  1057. BEGIN                 (* main program *)
  1058.  
  1059.    ctbl_init;         (* initalize color tables and other global vars *)
  1060.    movescroll:=false;
  1061.    click:='Y';
  1062.    autospeed:=50;
  1063.    putscrn3;          (* draw the screen *)
  1064.  
  1065. repeat
  1066.   begin
  1067.    Gmode:='?';
  1068.    puttitle;
  1069.    GetGameMode;       (* get the game mode and do it until Esc *)
  1070.    if Gmode='A' then
  1071.       Doauto
  1072.    else
  1073.       if gMode='P' then
  1074.          Playit
  1075.       else
  1076.         if gMode='R' then
  1077.            doautor;
  1078.    {endif};
  1079.  end;
  1080. until TC=#27;
  1081.  
  1082.    ctbl_init;         (* restore default colors and exit *)
  1083.    lv;
  1084.    window(1,1,80,25);
  1085.    clrscr;
  1086.    gotoxy(1,24);
  1087. end.
  1088.