PROGRAM HANOI; Uses Crt; CONST Disks = 9; TimeFactor = 5000; WaitTime = 100; FirstLine = 1; ShiftLine = 5; BaseLine = 17; ErrorLine = 20; MessageLine = 21; PromptLine = 22; LastLine = 22; LeftMargin = 2; MessageColumn = 33; RightMargin = 77; distance = 25; TYPE TLine = FirstLine..LastLine; TColumn = LeftMargin..RightMargin; TDiskNumber = 1..Disks; TDiskCount = 0..Disks; TTowerNumber = 1..3; TDiskPtr = ^TDisk; TTowerPtr = ^TTower; TDisk = record nbr : TDiskNumber; nxt : TDiskPtr; Line : TLine end; TTower = record nbr : TTowerNumber; top : TDiskPtr end; VAR t1,t2,t3 : TTowerPtr; x : TDiskPtr; Number,StepNbr,z : integer; Help, Automatic : boolean; Bell : char; WhiteChar : char; GrayChar : char; procedure InitGlobals; begin Bell := chr( 7); GrayChar := chr(177); WhiteChar := chr(219); end; procedure Position (Line: TLine; Column: TColumn); {Line 0 = upper screen border, Column 0 = left screen border } begin GotoXY (Column+1,Line+1); end; procedure HelpText; const margin = ' '; begin Position (ShiftLine,LeftMargin); writeln; writeln (margin,'Move all disks from tower 1 to tower 3'); writeln; writeln; writeln (margin,'These are the rules of the game :'); writeln; writeln (margin,'Only 1 disk may be moved at a time.'); writeln (margin,'Never place a larger disk on top of a smaller one.') end; procedure ClearHelpText; const LineCount = 8; var r : TLine; begin for r := ShiftLine to ShiftLine+LineCount do begin Position (r,LeftMargin); ClrEol; end; end; function UpperCase(c:char):char; begin if c in ['a'..'z'] then UpperCase := chr(ord(c)+ord('A')-ord('a')) else UpperCase := c end; function GetKey: char; var c : char; begin c:= ReadKey; if c in [' '..'~'] then write (c); GetKey := UpperCase (c) end; function GetStepCount (n: TDiskNumber): integer; begin if n=1 then GetStepCount := 1 else GetStepCount := 2*GetStepCount(n-1) + 1 end; procedure Wait (t: integer); var i,j : integer; begin for i:= 1 to t do for j:= 1 to TimeFactor do {nothing} end; function DiskColumn (t: TTowerNumber; b: integer): TColumn; {start Column for disk with width b on top op of or over tower t} begin DiskColumn := LeftMargin + (t-1)*distance + ((distance-b) div 2) end; function CharacterValue (c: char): integer; {value of character c or -1 if c is not a digit} begin if c in ['0'..'9'] then CharacterValue := ord(c)-ord('0') else CharacterValue := -1 end; function Again : boolean; var c : char; begin repeat Position (PromptLine,MessageColumn); write ('again? (Y/N) : '); ClrEol; c := GetKey until (c in ['Y','N']); Again := c ='Y' end; procedure MoveHorizontal (StartColumn,EndColumn: TColumn; Width: integer); var col: TColumn; begin col := StartColumn; while col<>EndColumn do begin if colStartLine then v:= 1 else v:= -1; r := StartLine; while r <> EndLine do begin Position (r,Column); for c:= 1 to Width do write (' '); Position (r+v,Column); for c:= 1 to Width do write (WhiteChar); r := r+v; Wait (2*z) end end; {MoveVertical} procedure LiftUp (twr: TTowerNumber; dsk: TDiskNumber; Line: TLine); var Width,StartCol,EndCol : integer; begin Width := 2*dsk+1; StartCol := DiskColumn (twr,Width); EndCol := DiskColumn (2,Width); MoveVertical (StartCol,Line,ShiftLine,Width); MoveHorizontal (StartCol,EndCol,Width) end; {LiftUp} procedure PutDown (twr: TTowerNumber; dsk: TDiskNumber; Line: TLine); var Width,StartCol,EndCol : integer; begin Width := 2*dsk+1; StartCol := DiskColumn (2,Width); EndCol := DiskColumn (twr,Width); MoveHorizontal (StartCol,EndCol,Width); MoveVertical (EndCol,ShiftLine,Line,Width) end; {PutDown} procedure MoveDisk (src,dst: TTowerPtr); var x,y : TDiskPtr; begin Wait (z*WaitTime); x := src^.top; y := x^.nxt; src^.top := y; LiftUp (src^.nbr,x^.nbr,x^.Line); x^.nxt := dst^.top; dst^.top := x; if x^.nxt<>nil then x^.Line := x^.nxt^.Line-1 else x^.Line := BaseLine-1; PutDown (dst^.nbr,x^.nbr,x^.Line); Wait (z*WaitTime); end; procedure Interactive (from, temp, dest: TTowerPtr); var k,a : integer; src,dst : TTowerNumber; towers : array[TTowerNumber] of TTowerPtr; ok : boolean; function KeyOK (t:integer): boolean; begin KeyOK := t in [1,2,3] end; function TowerOK (top: TDiskPtr): boolean; begin if top=nil then TowerOK := true else if top^.nxt=nil then TowerOK := true else TowerOK := top^.nbr < top^.nxt^.nbr end; begin {proc Interactive} towers[1] := from; towers[2] := temp; towers[3] := dest; k := 0; repeat k := k+1; Position (MessageLine,MessageColumn); write ('step : ',k); Position (PromptLine,MessageColumn); write ('from '); repeat Position (PromptLine,MessageColumn+5); ClrEol; a := CharacterValue (GetKey); if not KeyOK (a) then begin ok := false; Position (ErrorLine,MessageColumn); write (Bell); ClrEol; end else begin ok := towers[a]^.top<>nil; if not ok then begin Position (ErrorLine,MessageColumn); write (Bell,'There is no disk at <',a:1,'> !'); ClrEol; end end until ok; Position (ErrorLine,MessageColumn); ClrEol; Position (PromptLine,MessageColumn+5); write (a:1,' to '); src := a; repeat Position (PromptLine,MessageColumn+10); ClrEol; a := CharacterValue (GetKey); if not KeyOK (a) then write (Bell); until KeyOK (a); Position (PromptLine,MessageColumn+10); write (a:1); ClrEol; dst := a; if src=dst then begin Position (ErrorLine,MessageColumn); write (Bell,'It''s there already!'); ClrEol; k:= k-1 end else begin MoveDisk (towers[src],towers[dst]); if not TowerOK(towers[dst]^.top) then begin Position (ErrorLine,MessageColumn); write (Bell,'Not allowed'); Wait (5*WaitTime); MoveDisk (towers[dst],towers[src]); Position (ErrorLine,MessageColumn); ClrEol; end end until (from^.top=nil) and (temp^.top=nil); Position (ErrorLine,MessageColumn); write ('WELL DONE !'); ClrEol; end; {proc Interactive} procedure MainDialog (temp : boolean; var n: integer; var t1,t2,t3: TTowerPtr; var auto: boolean); var resp : char; z1 : integer; r : TLine; k : TColumn; t : TTowerNumber; procedure InitDisks; var s : TDiskNumber; Width : integer; Line : TLine; Column : TColumn; begin z := 0; new (t1); t1^.nbr := 1; t1^.top := nil; new (t2); t2^.nbr := 2; t2^.top := nil; new (t3); t3^.nbr := 3; t3^.top := nil; for s := n downto 1 do begin new (x); with x^ do begin nbr := s; nxt := t1^.top; t1^.top := x; Width := 2*s+1; Line := (BaseLine-1)-n+s; Column := DiskColumn (1,Width); MoveVertical (Column,Line-1,Line,Width); end end end; begin ClrScr; Position (FirstLine,LeftMargin+29); write ('TOWERS OF HANOI'); Position (BaseLine,LeftMargin); for k:= LeftMargin to RightMargin do write (GrayChar); for t:= 1 to 3 do begin Position (BaseLine+1,DiskColumn(t,3)); write ('<',t:1,'>') end; if temp then HelpText; repeat Position (PromptLine,LeftMargin); write (' User play? (press U): '); ClrEol; resp := GetKey; until resp in ['A','U']; auto := resp='A'; if temp then ClearHelpText; repeat Position (PromptLine,LeftMargin); write ('Number of disks ','? (1-',Disks:1,') : ');ClrEol; n:= CharacterValue(GetKey); until (n>=1) and (n<=Disks); Position (FirstLine,LeftMargin); write (n:1,' Disks'); InitDisks; Position (FirstLine,RightMargin-15); write (GetStepCount(n):3,' steps needed'); if auto then begin repeat Position (PromptLine,LeftMargin); write ('speed ','? (1-9) : '); ClrEol; z1:= CharacterValue(GetKey) until (z1>=1) and (z1<=9); Position (ErrorLine,MessageColumn); write ('speed : ',z1:3); ClrEol; z:= 9-z1; StepNbr := 0; Wait (z*WaitTime) end else z := 0; Position (PromptLine,LeftMargin); ClrEol; end; {proc MainDialog} BEGIN InitGlobals; Help := true; repeat MainDialog (Help,Number,t1,t2,t3,Automatic); Help := false; Interactive (t1,t2,t3) until not Again END.