From e5d4aaf526edb3e01e0ccebd0465f6e9e930094b Mon Sep 17 00:00:00 2001
From: Igor Pashev <pashev.igor@gmail.com>
Date: Tue, 10 Jan 2023 13:50:37 +0200
Subject: Версия для FreePascal
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 tower.pas | 249 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 249 insertions(+)
 create mode 100644 tower.pas

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.
-- 
cgit v1.2.3