Advertisement
melnikovmaxim

KLENINA_hanoi_towers

Dec 16th, 2019
320
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Pascal 2.40 KB | None | 0 0
  1. //https://yadi.sk/d/DFAM8fHp7sedfQ
  2. uses
  3.    GraphABC;
  4.    
  5. const
  6.   Max1 = 10;
  7.  
  8. type
  9.   tDiskCoords = record
  10.     X, Y, H, W : Integer;
  11.   end;
  12.  
  13. var
  14.   Disks : Integer;
  15.  
  16. var
  17.   Coords : array [-1..+1, 1..Max1] of tDiskCoords;
  18.   U : array [-1..+1, 0..Max1] of Integer;
  19.  
  20. procedure coords1;
  21. begin
  22.   var Y := 600;
  23.   var H := 550 div Disks;
  24.   var W := 100 div Disks;
  25.   for var i := 1 to Disks do
  26.     begin
  27.       Y -= H;
  28.       Coords[-1,i].X := 150; Coords[-1,i].Y := Y; Coords[-1,i].H := H-1; Coords[-1,i].W := W;
  29.       Coords[ 0,i].X := 400; Coords[ 0,i].Y := Y; Coords[ 0,i].H := H-1; Coords[ 0,i].W := W;
  30.       Coords[+1,i].X := 650; Coords[+1,i].Y := Y; Coords[+1,i].H := H-1; Coords[+1,i].W := W;
  31.     end;
  32. end;
  33.  
  34. procedure osnovanie;
  35. var
  36.   R : Integer;
  37. begin
  38.   Brush.Color := clWhite;
  39.   Pen.Color   := clWhite;
  40.   Rectangle(0, 0, Window.Width, Window.Height);
  41.  
  42.   Pen.Color := clGray;
  43.   Rectangle( 45, 600, 255, 610);
  44.   Rectangle(295, 600, 505, 610);
  45.   Rectangle(545, 600, 755, 610);
  46.   Rectangle(146,  30, 154, 601);
  47.   Rectangle(396,  30, 404, 601);
  48.   Rectangle(646,  30, 654, 601);
  49.  
  50.   Pen.Color   := clBlack;
  51.   Brush.Color := clBlue;
  52.   for var Row := 1 to Disks do
  53.     for var Col := -1 to +1 do
  54.       begin
  55.         R := U[Col, Row];
  56.         if R > 0 then
  57.           with Coords[Col, Row] do
  58.             Rectangle(X - R*W, Y, X + R*W, Y+H);
  59.       end;
  60. end;
  61.  
  62. procedure diskp(fromColumn, toColumn : Integer);
  63. begin
  64.   U[toColumn, 0] += 1;
  65.   U[toColumn, U[toColumn, 0]] := U[fromColumn, U[fromColumn, 0]];
  66.   U[fromColumn, U[fromColumn, 0]] := 0;
  67.   U[fromColumn, 0] -= 1;
  68.  
  69.   osnovanie;
  70.   sleep(250);
  71. end;
  72.  
  73. procedure hanoy(count, init, aux, fin : Integer);
  74. begin
  75.   if count = 1 then
  76.     diskp(init, fin)
  77.   else
  78.     begin
  79.       hanoy(count-1, init, fin, aux);
  80.       diskp(init, fin);
  81.       hanoy(count-1, aux, init, fin);
  82.     end;
  83. end;
  84.  
  85. procedure poisk;
  86. begin
  87.   Window.Title := 'Ханойские башни. Дисков: ' + Disks.ToString;
  88.   coords1;
  89.  
  90.   U[-1, 0] := Disks;
  91.   for var i := 1 to Disks do
  92.     U[-1, i] := Disks - i + 1;
  93.    
  94.   osnovanie;
  95.   ReadLn;
  96.  
  97.   hanoy(Disks, -1, 0, +1);
  98. end;
  99.  
  100. begin
  101.    Window.SetSize(800, 650);
  102.    
  103.    WriteLn('Введите количество дисков от 1 до  ', Max1); ReadLn(Disks);
  104.    if Not(Disks in [1..Max1]) then
  105.      WriteLn('Кол-во дисков от 1 до 10.')
  106.    else
  107.      poisk;
  108. end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement