Версия для FreePascal

1 files changed, 249 insertions, 0 deletions

diff --git a/tower.pas b/tower.pas
new file mode 100644
index 0000000..f4ead7a
--- /dev/null
+++ b/tower.pas
@@ -0,0 +1,249 @@
+Program Hanoi_Tower;    {$B-}

+Uses    Crt;

+Var

+  n,h,flag: BYTE;

+  q,mq,z,r,t: INTEGER;

+  allrings,k: BOOLEAN;

+  hp:   ARRAY [1..3] Of BYTE;

+  rings: ARRAY [1..9] Of STRING [20];

+  heaps: ARRAY [1..3,0..9] Of BYTE;

+

+Const   m:    ARRAY [3..9] Of STRING [50] = ('Not bad.', 'Good !',

+                                             'Very well !!',

+                                             'Do not stop !',

+                                             'Patience!',

+                                             'Terrific! One more game !!!',

+                                             'THAT IS IT !!!');

+

+Label BEGINNING_OF_MAIN_BLOC;

+Procedure Cancel;

+Begin

+  flag := 11;

+End;

+

+Procedure Title;

+Begin

+  While KeyPressed Do ReadKey;

+  n := 3;

+  flag := 29;

+  clrscr;

+  Window(1,1,40,25);

+  GotoXY(1,2);

+  Write('----------------------------------------');

+  GotoXY(1,24);

+  Write('----------------------------------------');

+  For z:=2 To 23 Do

+    Begin

+      GotoXY(1,z);

+      Write('|');

+      GotoXY(40,z);

+      Write('|');

+    End;

+  textcolor(white);

+  GotoXY(12,17);

+  Write('Author: I. Pashev, 11g');

+  GotoXY(15,18);

+  Write('Severoonezhsk');

+  window (12,8,30,14);

+  clrscr;

+  TextColor(Magenta);

+  Window(11,7,29,13);

+  ClrScr;

+  GotoXY(6,2);

+  Write('H A N O I');

+  GotoXY(6,6);

+  Write('T O W E R');

+  window(1,1,40,25);

+  GotoXY(2,25);

+  Write('       - Dec 1997 - Jan 2023 -         ');

+  Repeat

+    z := Ord(ReadKey);

+    Case z Of

+      120: If n>3 Then Dec(n);

+      105: If n<8 Then Inc(n);

+      27: halt;

+    End;

+  Until z=13;

+End;

+

+Procedure Prepare;

+Procedure maxq;

+Begin

+  mq := 1;

+  For z:=1 To n Do

+    mq := mq*2;

+  mq := mq-1;

+End;

+Begin

+  ClrScr;

+  Window(1,1,80,25);

+  k := FALSE;

+  flag := 29;

+  hp[1] := n;

+  hp[2] := 0;

+  hp[3] := 0;

+  h := 1;

+  allrings := FALSE;

+  MAXQ;

+  q := 0;

+  TextColor(Yellow);

+  WriteLN('Max moves: ',mq);

+  Write('Moves done: ');

+  TextColor(White);

+  Write(q);

+  TextColor(LightCyan);

+  GotoXY(1,20);

+  Write('================================================================================');

+  t := 17-n;

+  For z:=n Downto 1 Do

+    Begin

+      rings[n-z+1] := '';

+      For r:=1 To 10-z Do

+        rings[n-z+1] := rings[n-z+1] + #32;

+      For r := 1  To  2 * z  Do

+        rings[n-z+1] := rings[n-z+1] + 'O';

+      For r:=1 To 10-z Do

+        rings[n-z+1] := rings[n-z+1] + #32;

+    End;

+  TextColor(White);

+  GotoXY(16,21);

+  Write('^');

+  For z:=1 To n Do

+    Begin

+      GotoXY(7,20-z);

+      Write(rings[z]);

+      heaps[1,z] := z;

+    End;

+End;

+

+Procedure Playing;

+Var    h2: BYTE;

+Const spc = '                   ';{ 19 spaces}

+Procedure LevelComplete;

+Begin

+  GotoXY(1,4);

+  Write(m[n]);

+  allrings := TRUE;

+  GotoXY(1,5);

+  Write('P R E S S "Space"');

+  If n=9 Then flag := 1

+  Else Inc(n);

+  Delay(500);

+End;

+Procedure Go_to_heap (x:SHORTINT);

+Begin

+  If (x < 1) Or (x > 3) Then EXIT;

+  GotoXY((h-1)*24+16,21);

+  Write(#32);

+  h := x;

+  GotoXY((h-1)*24+16,21);

+  Write('^');

+End;

+Procedure Up;

+Begin

+  If hp[h]=0 Then

+    Begin

+      Write(#7);

+      Exit;

+    End;

+  k := TRUE;

+  For z:=19-hp[h] Downto t Do

+    Begin

+      GotoXY((h-1) * 24 + 7, z + 1);

+      Write(spc);

+      GotoXY((h-1) * 24 + 7, z);

+      Write(rings [heaps [h,hp [h]]]);

+      Delay(40);

+    End;

+  h2 := h;

+End;

+Procedure Down;

+Begin

+  If heaps[h2,hp[h2]]>heaps[h,hp[h]] Then

+    Begin

+      Exit;

+    End;

+  If h2<>h Then

+    Begin

+      Inc(hp[h2]);

+      heaps[h2,hp[h2]] := heaps[h,hp[h]];

+    End;

+  For z:=t To 19-hp[h2] Do

+    Begin

+      GotoXY((h2-1)*24+7,z);

+      Write(spc);

+      GotoXY((h2-1)*24+7,z+1);

+      Write(rings[heaps[h,hp[h]]]);

+      Delay(40);

+    End;

+  k := FALSE;

+  If h2<>h Then Dec(hp[h]);

+  If Not (allrings) And (h2<>h) Then

+    Begin

+      Inc(q);

+      GotoXY(13,2);

+      Write(q);

+    End;

+End;

+Procedure Right;

+Begin

+  If h2=3 Then Exit;

+  For z:=(h2-1)*24+8 To 24*h2+7 Do

+    Begin

+      GotoXY(z,t);

+      Write(rings[heaps[h,hp[h]]]);

+      Delay(6);

+    End;

+  Inc(h2);

+End;

+Procedure Left;

+Begin

+  If h2=1 Then Exit;

+  For z:=(h2-1)*24+6 Downto 24*(h2-2)+7 Do

+    Begin

+      GotoXY(z,t);

+      Write(rings[heaps[h,hp[h]]]);

+      Delay(6);

+    End;

+  Dec(h2);

+End;

+Begin

+  Repeat

+    Case ReadKey Of

+      'H': If Not k Then Up;

+      'P': If   k Then Down;

+      'M': If k Then Right

+           Else Go_to_heap(h + 1);

+      'K': If k Then Left

+           Else Go_to_heap(h - 1);

+      #27: Cancel;

+      #32, #13: If allrings Then flag := 0;

+      Else CONTINUE;

+    End;

+    If q>mq Then flag := 2

+    Else If (hp[3]=n) And Not allrings Then LevelComplete;

+  Until flag<>29;

+End;

+

+Procedure BadLuck;

+Begin

+  GotoXY(30,20);

+  Write(' L O S E R! ');

+  Delay(2500);

+End;

+

+Begin

+

+  CheckBreak := FALSE;

+  heaps[1,0] := 0;

+  heaps[2,0] := 0;

+  heaps[3,0] := 0;

+BEGINNING_OF_MAIN_BLOC:

+  Title;

+  Repeat

+    Prepare;

+    Playing;

+  Until flag<>0;

+  If flag=2 Then BadLuck;

+  GOTO BEGINNING_OF_MAIN_BLOC;

+End.