Ханойские башни. - Форум «Всё о Паскале»

Ханойские башни.
Переместить некоторое число упорядоченных по убыванию дисков разного размера, нанизанных на вертикальный стержень 1, с помощью стержня 2 на стержень 3. Диски перемещаются согласно двум простым правилам

Перекладывать диски можно только по одному
Нельзя класть большой диск на меньший.

Эта головоломка известна давно. В русской литературе она впервые появилась в 1902 году в книге Е.Игнатьева "В царстве смекалки", а автором принято считать французского математика Э. Люка, создавшего ее на основе древних легенд. Вот одна из них. На стержне надето 64 золотых диска, и буддийские монахи с момента сотворения мира, без устали сменяя друг друга, день и ночь переносят их с одного стержня на другой. Когда все диски будут перенесены, наступит конец света.

Доказано, что оптимальное количество перекладываний 2^n-1, где число дисков равно n. Поэтому монахам понадобится 2^64-1 действие, что бы выполнить свою работу. Если тратить на каждое действие по секунде, то пройдет 18 446 744 073 709 551 615 секунд, т.е. более 500 миллиардов лет.

Если бы в пирамиде был только один диск, решение очевидно - перенесем его на третий стержень, и пирамида собранна. А если дисков два ? Тогда положим сначала меньший диск на второй стержень, затем перенесем второй диск на третий стержень, а за ним и третий. За три действия мы смогли переложить оба диска на третий. Назовем стержни соответственно исходный, вспомогательный, и конечный. Так как задачу можно решить для n-1 дисков, то ее можно решить и для n дисков, т.е. рекурсия очевидна, а ключ к решению лежит в решении задачи всего лишь для двух дисков, которое состоит из 3 основных шагов, описанных выше:
1. перенести башню из n-1 дисков с исходного на вспомогательный.
2. переложить n-ый диск с исходного на конечный.
3. перенести башню из n-1 дисков со вспомогательного на конечный.

Разбирая алгоритм и программу, важно понять "изменение" нумерации стержней.

uses
    crt;
const
     n=4; {число колец}
procedure tower (n:byte; init, aux,fin:char);
begin
     if n=1 then write (init, #26, fin, ' ') else begin
        tower (n-1, init, fin, aux );
        write (init, #26, fin, ' ');
        tower (n-1, aux, init, fin);
     end
end;

begin
     tower (n,'1','2','3'); readkey;
end.

Нерекурсивное решение было придуманно только в 1980 году. Оно состояло из чередования перемещений двух видов:

Перенести наименьший диск с того стержня, на котором он находиться в данный момент, на стержень, следующий в порядке движения часовой стрелки.
Перенести любой диск, кроме наименьшего. Второй шаг не произвольный, т.е. всегда найдется лишь одно перемещение.

Этот алгоритм медленнее рекурсивного.

А вот, программа, визуализирующая решение задачи. (TP7, BP7, текст предоставила fms) текст:

hanoy.pas ( 7.33 килобайт ) Кол-во скачиваний: 2244

Исходный код

uses crt,graph;
type
  nodeptr=^node;
       node=record
       no:integer;
       next:nodeptr;
  end;
  aray20=array[1..20]of byte;
var
  yeni,top1,top2,top3,temp1,temp2,temp3:nodeptr;
  n,i,tekcift,son,control,sayac1,sayac2,sayac3:byte;
  source,dest:char;
  counter,deger:longint;
  uzun1,uzun2,uzun3:aray20;
  gd,gm :integer;
  cevir:string;
{-------------------------------------------------------}
Procedure Initialize;
begin
  clrscr;
  top1:=nil; top2:=nil; top3:=nil;
  tekcift:=0; counter:=1; control:=0;  sayac1:=1; sayac2:=1; sayac3:=1;

    gotoxy(25,2); textcolor(red); write('HANOI TOWERS');
    gotoxy(1,4); textcolor(white);
    writeln('   There are 3 pegs named A,B,C. One peg is source peg,');
    writeln('one is destination peg, the other peg is temporary peg.');writeln;
    writeln('   There are N discs. The smallest disc is disc1 and the ');
    writeln('largest disc is disc N. There can be maximum 20 discs.');textcolor(red);writeln;
      write('   GOAL  : ');textcolor(white);
    writeln('All discs will be carried from source peg into');
    writeln('           the destination peg.'); writeln;textcolor(red);
      write('   RULES : 1) ');textcolor(white);
    writeln('Only one disc can be moved at a time, and');
    writeln('              this disc must be the top disc on a peg.');textcolor(red);writeln;
      write('           2) ');textcolor(white);
      writeln('A larger disc can never be placed on top');
      writeln('              of a smaller disc.');writeln;
      writeln('          IT IS NOT A RECURSIVE PROGRAM');writeln;
      writeln('           Press any key to continue');
    readkey;clrscr;
    repeat
    write('Enter the N number          : ');readln(n);
    if (n=0)or(n=1)or(n>20) then clrscr;
  until (n<>0)and(n<>1)and(n<=20);

  write('Enter the source peg(A,B,C) : ');readln(source);
  source:=upcase(source);
  repeat
   write('Enter the destination peg   : ');readln(dest);
   source:=upcase(source); dest:=upcase(dest);
   if dest=source then begin gotoxy(28,3); clreol; gotoxy(1,3);end;
  until dest<>source;
  detectgraph(gd,gm);
  initgraph(gd,gm,'');
  cleardevice;
  setbkcolor(7);
end;
{----------------------------------------------------------}
Procedure Push(item:integer; var head:nodeptr);
begin
  new(yeni);         yeni^.no:=item;
  yeni^.next:=head;  head:=yeni;
end;
{-----------------------------------------------------------}
Function Pop(var head:nodeptr):integer;
var
 temp:nodeptr;
begin
  temp:=head;       head:=head^.next;
  pop:=temp^.no;  dispose(temp);
end;
{-----------------------------------------------------------}
Function usalma(a:integer):integer;
var i,s:integer;
begin
  s:=1;
  if a=1 then s:=2
         else for i:=1 to n do s:=s*2;
  usalma:=s-1;
end;
{-----------------------------------------------------------}
Function tekmi(a:integer):byte;
begin
if a mod 2=1 then tekmi:=1
             else tekmi:=2;
end;
{-----------------------------------------------------------}
Procedure ciz(s1,s2,s3:aray20; sa1,sa2,sa3:byte);
var i,m1,m2,m3:byte;
begin
  setfillstyle(1,red);   m1:=0; m2:=0; m3:=0;
  setcolor(1);
  outtextxy(95,325,'A'); outtextxy(295,325,'B'); outtextxy(495,325,'C');
  setcolor(red);
  outtextxy(295,370,'Press any key to continue');
  setcolor(yellow);
  for i:=sa1-1 downto 1 do
               begin
                 m1:=m1+1; str(s1[i],cevir);
                 bar(85-4*s1[i],313-13*m1,109+4*s1[i],323-13*m1);
                 outtextxy(95,313-13*m1,cevir);
               end;

  for i:=sa2-1 downto 1 do
               begin
                 m2:=m2+1; str(s2[i],cevir);
                 bar(85-4*s2[i]+200,313-13*m2,309+4*s2[i],323-13*m2);
                 outtextxy(295,313-13*m2,cevir);
               end;

  for i:=sa3-1 downto 1 do
               begin
                 m3:=m3+1; str(s3[i],cevir);
                 bar(85-4*s3[i]+400,313-13*m3,509+4*s3[i],323-13*m3);
                 outtextxy(495,313-13*m3,cevir);
               end;
setcolor(red);
end;
{----------------------------------------------------------}
Procedure yazdir;
var i:byte;
begin
  cleardevice;
  sayac1:=1; sayac2:=1; sayac3:=1;
  temp1:=top1; temp2:=top2; temp3:=top3;

  while temp1<>nil do begin
  uzun1[sayac1]:=temp1^.no;
  temp1:=temp1^.next; sayac1:=sayac1+1;
  end;

  while temp2<>nil do begin
  uzun2[sayac2]:=temp2^.no;
  temp2:=temp2^.next; sayac2:=sayac2+1;
  end;

  while temp3<>nil do begin
  uzun3[sayac3]:=temp3^.no;
  temp3:=temp3^.next; sayac3:=sayac3+1;
  end;

  if (source='A')and(dest='C') then ciz(uzun1,uzun2,uzun3,sayac1,sayac2,sayac3);
  if (source='A')and(dest='B') then ciz(uzun1,uzun3,uzun2,sayac1,sayac3,sayac2);
  if (source='B')and(dest='C') then ciz(uzun2,uzun1,uzun3,sayac2,sayac1,sayac3);
  if (source='B')and(dest='A') then ciz(uzun3,uzun1,uzun2,sayac3,sayac1,sayac2);
  if (source='C')and(dest='A') then ciz(uzun3,uzun2,uzun1,sayac3,sayac2,sayac1);
  if (source='C')and(dest='B') then ciz(uzun2,uzun3,uzun1,sayac2,sayac3,sayac1);
end;
{-----------------------------------------------------------}
begin
  initialize;

  for i:=n downto 1 do push(i,top1); yazdir;
  readkey;

  if tekmi(n)=1 then begin
                       if tekmi(top1^.no)=1 then push(pop(top1),top3)
                                            else push(pop(top1),top2);
                     end
                else begin
                       if tekmi(top1^.no)=1 then push(pop(top1),top2)
                                            else push(pop(top1),top3);
                     end;

  son:=1; yazdir;
  outtextxy(20,370,'Number of move : 1');
  readkey;
  deger:=usalma(n);

  if tekmi(n)=1 then begin

    repeat

      if (top1<>nil)and(top1^.no<>son) then
         begin
           if (tekmi(top1^.no)=1)and(top1^.no<top3^.no) then
              begin
                son:=top1^.no;  str(son,cevir);
                Push(pop(top1),top3); control:=10;
                yazdir;
              end;
           if (tekmi(top1^.no)=2)and(top1^.no<top2^.no)and(control=0) then
              begin
                son:=top1^.no; str(son,cevir);
                Push(pop(top1),top2); control:=10;
                yazdir;
              end;
         end;


      if (top2<>nil)and(top2^.no<>son)and(control=0) then
         begin
           if (tekmi(top2^.no)=1)and(top2^.no<top1^.no) then
              begin
                son:=top2^.no;   str(son,cevir);
                Push(pop(top2),top1); control:=10;
                yazdir;
              end;
           if (tekmi(top2^.no)=2)and(top2^.no<top3^.no)and(control=0) then
              begin
                son:=top2^.no;    str(son,cevir);
                Push(pop(top2),top3); control:=10;
                yazdir;
              end;
         end;


      if (top3<>nil)and(top3^.no<>son)and(control=0) then
         begin
           if (tekmi(top3^.no)=1)and(top3^.no<top2^.no) then
              begin
                son:=top3^.no;  str(son,cevir);
                Push(pop(top3),top2); control:=10;
                yazdir;
              end;
           if (tekmi(top3^.no)=2)and(top3^.no<top1^.no)and(control=0) then
              begin
                son:=top3^.no;  str(son,cevir);
                Push(pop(top3),top1); control:=10;
                yazdir;
              end;
         end;
      control:=0;
      counter:=counter+1;
      str(counter,cevir);
      outtextxy(20,370,'Number of move :');outtextxy(150,370,cevir);
      readkey;
      until deger=counter;
                     end;


  if tekmi(n)=2 then begin
    repeat
      if (top1<>nil)and(top1^.no<>son) then
         begin
           if (tekmi(top1^.no)=1)and(top1^.no<top2^.no) then
              begin
                son:=top1^.no;  str(son,cevir);
                Push(pop(top1),top2); control:=10;
                yazdir;
              end;
           if (tekmi(top1^.no)=2)and(top1^.no<top3^.no)and(control=0) then
              begin
                son:=top1^.no;  str(son,cevir);
                Push(pop(top1),top3); control:=10;
                yazdir;
              end;
         end;


      if (top2<>nil)and(top2^.no<>son)and(control=0) then
         begin
           if (tekmi(top2^.no)=1)and(top2^.no<top3^.no) then
              begin
                son:=top2^.no;  str(son,cevir);
                Push(pop(top2),top3); control:=10;
                yazdir;
              end;
           if (tekmi(top2^.no)=2)and(top2^.no<top1^.no)and(control=0) then
              begin
                son:=top2^.no;  str(son,cevir);
                Push(pop(top2),top1); control:=10;
                yazdir;
              end;
         end;


      if (top3<>nil)and(top3^.no<>son)and(control=0) then
         begin
           if (tekmi(top3^.no)=1)and(top3^.no<top1^.no) then
              begin
                son:=top3^.no;  str(son,cevir);
                Push(pop(top3),top1); control:=10;
                yazdir;
              end;
           if (tekmi(top3^.no)=2)and(top3^.no<top2^.no)and(control=0) then
              begin
                son:=top3^.no;  str(son,cevir);
                Push(pop(top3),top2); control:=10;
                yazdir;
              end;
         end;
      control:=0;
      counter:=counter+1;
      str(counter,cevir);
      outtextxy(20,350,'Number of move :');outtextxy(150,350,cevir);
      readkey;
      until deger=counter;
                     end;
end.

Вот скриншот работы программы:

А вот один из нерекурсивных алгоритмов (автор Atos)


                       program HanoyTower;
type TInt=longint;
procedure Tower(n:TInt);
var m,k,l,s:TInt;
   iz,v,c,x:byte;
begin
n:=longint(round(exp(n*ln(2))))-1;
for m:=1 to n do
 begin
 iz:=1; c:=2; v:=3; k:=1; l:=n; s:=(k+l) div 2;
 repeat
 if m<s then begin x:=v;  v:=c;  c:=x; l:=s-1; end;
 if m>s then begin x:=iz; iz:=c; c:=x; k:=s+1; end;
 if m=s then begin writeln(iz,'-',v); break; end;
 s:=(k+l) div 2;
 until 2*2=5;
 end;
end;

var n:TInt;
begin
n:=4;
Tower(n);
readln;
end.

И на последок, еще одна программа (автор volvo)
визуализирующая решение.


program Hanoy;
uses Crt,Graph;
type ArrType =array [1..1] of byte;
var Col,
    Beg,End_ :byte;
    Arr      :^ArrType;
    i,j      :integer;

    CountMoves: longint;

procedure GraphInit;
 var GrDr,GrMode:smallint;
 begin
   GrDr:=d8bit;
   GrMode:=m640x480;
   InitGraph(GrDr,GrMode,'');
 end;
procedure DrawRings;
 var a,b,c:byte;
 begin
   ClearDevice;
   SetColor(White);
   Line(100,200,100,400);
   Line(300,200,300,400);
   Line(500,200,500,400);
   Line(50,400,550,400);
   SetFillStyle(SolidFill, Red);
   SetColor(Yellow);
   j:=0;a:=0;b:=0;c:=0;
   for i:=1 to Col do
     case Arr^[i] of
       0:Inc(a);
       1:Inc(b);
       2:Inc©;
     end;
   for i:=1 to Col do
     begin
       case Arr^[i] of
         0:begin
             Bar(100+Arr^[i]*200-i*5,400-a*5,100+Arr^[i]*200+i*5,400-a*5-5);
             Rectangle(100+Arr^[i]*200-i*5,400-a*5,100+Arr^[i]*200+i*5,400-a*5-5);
             Dec(a);
           end;
         1:begin
             Bar(100+Arr^[i]*200-i*5,400-b*5,100+Arr^[i]*200+i*5,400-b*5-5);
             Rectangle(100+Arr^[i]*200-i*5,400-b*5,100+Arr^[i]*200+i*5,400-b*5-5);
             Dec(b);
           end;
         2:begin
             Bar(100+Arr^[i]*200-i*5,400-c*5,100+Arr^[i]*200+i*5,400-c*5-5);
             Rectangle(100+Arr^[i]*200-i*5,400-c*5,100+Arr^[i]*200+i*5,400-c*5-5);
             Dec©;
           end;
       end;
     end;
   if ReadKey=#27 then begin
      CloseGraph;
      halt(1);
   end;
   while KeyPressed do Readkey;
 end;
procedure PrintQuant(c,b,e:byte);
 begin
   Arr^[c]:=e;
   DrawRings;
   Inc(CountMoves);
 end;
procedure Move(c,b,e:byte);
 begin
   if c=1 then PrintQuant(c,b,e)
   else
     begin
       Move(c-1,b,3-b-e);
       PrintQuant(c,b,e);
       Move(c-1,3-b-e,e);
     end;
 end;
begin
  CountMoves := 0;

  GraphInit;
  Beg:=0;
  End_:=2;
  Col:=4;
  GetMem(Arr,Col);
  for i:=1 to Col do
    Arr^[i]:=Beg;
  DrawRings;
  Move(Col,Beg,End_);
  Freemem(Arr,Col);
  CloseGraph;

  writeln('Count = ', CountMoves);
  ReadLn;
end.

Altair	10.02.2006 16:38 Сообщение #1
Ищущий истину Группа: Пользователи Сообщений: 4 825 Пол: Мужской Реальное имя: Олег Репутация: 45	Ханойские башни. Переместить некоторое число упорядоченных по убыванию дисков разного размера, нанизанных на вертикальный стержень 1, с помощью стержня 2 на стержень 3. Диски перемещаются согласно двум простым правилам Перекладывать диски можно только по одному Нельзя класть большой диск на меньший. Эта головоломка известна давно. В русской литературе она впервые появилась в 1902 году в книге Е.Игнатьева "В царстве смекалки", а автором принято считать французского математика Э. Люка, создавшего ее на основе древних легенд. Вот одна из них. На стержне надето 64 золотых диска, и буддийские монахи с момента сотворения мира, без устали сменяя друг друга, день и ночь переносят их с одного стержня на другой. Когда все диски будут перенесены, наступит конец света. Доказано, что оптимальное количество перекладываний 2^n-1, где число дисков равно n. Поэтому монахам понадобится 2^64-1 действие, что бы выполнить свою работу. Если тратить на каждое действие по секунде, то пройдет 18 446 744 073 709 551 615 секунд, т.е. более 500 миллиардов лет. Если бы в пирамиде был только один диск, решение очевидно - перенесем его на третий стержень, и пирамида собранна. А если дисков два ? Тогда положим сначала меньший диск на второй стержень, затем перенесем второй диск на третий стержень, а за ним и третий. За три действия мы смогли переложить оба диска на третий. Назовем стержни соответственно исходный, вспомогательный, и конечный. Так как задачу можно решить для n-1 дисков, то ее можно решить и для n дисков, т.е. рекурсия очевидна, а ключ к решению лежит в решении задачи всего лишь для двух дисков, которое состоит из 3 основных шагов, описанных выше: 1. перенести башню из n-1 дисков с исходного на вспомогательный. 2. переложить n-ый диск с исходного на конечный. 3. перенести башню из n-1 дисков со вспомогательного на конечный. Разбирая алгоритм и программу, важно понять "изменение" нумерации стержней. uses crt; const n=4; {число колец} procedure tower (n:byte; init, aux,fin:char); begin if n=1 then write (init, #26, fin, ' ') else begin tower (n-1, init, fin, aux ); write (init, #26, fin, ' '); tower (n-1, aux, init, fin); end end; begin tower (n,'1','2','3'); readkey; end. Нерекурсивное решение было придуманно только в 1980 году. Оно состояло из чередования перемещений двух видов: Перенести наименьший диск с того стержня, на котором он находиться в данный момент, на стержень, следующий в порядке движения часовой стрелки. Перенести любой диск, кроме наименьшего. Второй шаг не произвольный, т.е. всегда найдется лишь одно перемещение. Этот алгоритм медленнее рекурсивного. А вот, программа, визуализирующая решение задачи. (TP7, BP7, текст предоставила fms) текст: hanoy.pas ( 7.33 килобайт ) Кол-во скачиваний: 2244 Исходный код uses crt,graph; type nodeptr=^node; node=record no:integer; next:nodeptr; end; aray20=array[1..20]of byte; var yeni,top1,top2,top3,temp1,temp2,temp3:nodeptr; n,i,tekcift,son,control,sayac1,sayac2,sayac3:byte; source,dest:char; counter,deger:longint; uzun1,uzun2,uzun3:aray20; gd,gm :integer; cevir:string; {-------------------------------------------------------} Procedure Initialize; begin clrscr; top1:=nil; top2:=nil; top3:=nil; tekcift:=0; counter:=1; control:=0; sayac1:=1; sayac2:=1; sayac3:=1; gotoxy(25,2); textcolor(red); write('HANOI TOWERS'); gotoxy(1,4); textcolor(white); writeln(' There are 3 pegs named A,B,C. One peg is source peg,'); writeln('one is destination peg, the other peg is temporary peg.');writeln; writeln(' There are N discs. The smallest disc is disc1 and the '); writeln('largest disc is disc N. There can be maximum 20 discs.');textcolor(red);writeln; write(' GOAL : ');textcolor(white); writeln('All discs will be carried from source peg into'); writeln(' the destination peg.'); writeln;textcolor(red); write(' RULES : 1) ');textcolor(white); writeln('Only one disc can be moved at a time, and'); writeln(' this disc must be the top disc on a peg.');textcolor(red);writeln; write(' 2) ');textcolor(white); writeln('A larger disc can never be placed on top'); writeln(' of a smaller disc.');writeln; writeln(' IT IS NOT A RECURSIVE PROGRAM');writeln; writeln(' Press any key to continue'); readkey;clrscr; repeat write('Enter the N number : ');readln(n); if (n=0)or(n=1)or(n>20) then clrscr; until (n<>0)and(n<>1)and(n<=20); write('Enter the source peg(A,B,C) : ');readln(source); source:=upcase(source); repeat write('Enter the destination peg : ');readln(dest); source:=upcase(source); dest:=upcase(dest); if dest=source then begin gotoxy(28,3); clreol; gotoxy(1,3);end; until dest<>source; detectgraph(gd,gm); initgraph(gd,gm,''); cleardevice; setbkcolor(7); end; {----------------------------------------------------------} Procedure Push(item:integer; var head:nodeptr); begin new(yeni); yeni^.no:=item; yeni^.next:=head; head:=yeni; end; {-----------------------------------------------------------} Function Pop(var head:nodeptr):integer; var temp:nodeptr; begin temp:=head; head:=head^.next; pop:=temp^.no; dispose(temp); end; {-----------------------------------------------------------} Function usalma(a:integer):integer; var i,s:integer; begin s:=1; if a=1 then s:=2 else for i:=1 to n do s:=s2; usalma:=s-1; end; {-----------------------------------------------------------} Function tekmi(a:integer):byte; begin if a mod 2=1 then tekmi:=1 else tekmi:=2; end; {-----------------------------------------------------------} Procedure ciz(s1,s2,s3:aray20; sa1,sa2,sa3:byte); var i,m1,m2,m3:byte; begin setfillstyle(1,red); m1:=0; m2:=0; m3:=0; setcolor(1); outtextxy(95,325,'A'); outtextxy(295,325,'B'); outtextxy(495,325,'C'); setcolor(red); outtextxy(295,370,'Press any key to continue'); setcolor(yellow); for i:=sa1-1 downto 1 do begin m1:=m1+1; str(s1[i],cevir); bar(85-4s1[i],313-13m1,109+4s1[i],323-13m1); outtextxy(95,313-13m1,cevir); end; for i:=sa2-1 downto 1 do begin m2:=m2+1; str(s2[i],cevir); bar(85-4s2[i]+200,313-13m2,309+4s2[i],323-13m2); outtextxy(295,313-13m2,cevir); end; for i:=sa3-1 downto 1 do begin m3:=m3+1; str(s3[i],cevir); bar(85-4s3[i]+400,313-13m3,509+4s3[i],323-13m3); outtextxy(495,313-13m3,cevir); end; setcolor(red); end; {----------------------------------------------------------} Procedure yazdir; var i:byte; begin cleardevice; sayac1:=1; sayac2:=1; sayac3:=1; temp1:=top1; temp2:=top2; temp3:=top3; while temp1<>nil do begin uzun1[sayac1]:=temp1^.no; temp1:=temp1^.next; sayac1:=sayac1+1; end; while temp2<>nil do begin uzun2[sayac2]:=temp2^.no; temp2:=temp2^.next; sayac2:=sayac2+1; end; while temp3<>nil do begin uzun3[sayac3]:=temp3^.no; temp3:=temp3^.next; sayac3:=sayac3+1; end; if (source='A')and(dest='C') then ciz(uzun1,uzun2,uzun3,sayac1,sayac2,sayac3); if (source='A')and(dest='B') then ciz(uzun1,uzun3,uzun2,sayac1,sayac3,sayac2); if (source='B')and(dest='C') then ciz(uzun2,uzun1,uzun3,sayac2,sayac1,sayac3); if (source='B')and(dest='A') then ciz(uzun3,uzun1,uzun2,sayac3,sayac1,sayac2); if (source='C')and(dest='A') then ciz(uzun3,uzun2,uzun1,sayac3,sayac2,sayac1); if (source='C')and(dest='B') then ciz(uzun2,uzun3,uzun1,sayac2,sayac3,sayac1); end; {-----------------------------------------------------------} begin initialize; for i:=n downto 1 do push(i,top1); yazdir; readkey; if tekmi(n)=1 then begin if tekmi(top1^.no)=1 then push(pop(top1),top3) else push(pop(top1),top2); end else begin if tekmi(top1^.no)=1 then push(pop(top1),top2) else push(pop(top1),top3); end; son:=1; yazdir; outtextxy(20,370,'Number of move : 1'); readkey; deger:=usalma(n); if tekmi(n)=1 then begin repeat if (top1<>nil)and(top1^.no<>son) then begin if (tekmi(top1^.no)=1)and(top1^.no<top3^.no) then begin son:=top1^.no; str(son,cevir); Push(pop(top1),top3); control:=10; yazdir; end; if (tekmi(top1^.no)=2)and(top1^.no<top2^.no)and(control=0) then begin son:=top1^.no; str(son,cevir); Push(pop(top1),top2); control:=10; yazdir; end; end; if (top2<>nil)and(top2^.no<>son)and(control=0) then begin if (tekmi(top2^.no)=1)and(top2^.no<top1^.no) then begin son:=top2^.no; str(son,cevir); Push(pop(top2),top1); control:=10; yazdir; end; if (tekmi(top2^.no)=2)and(top2^.no<top3^.no)and(control=0) then begin son:=top2^.no; str(son,cevir); Push(pop(top2),top3); control:=10; yazdir; end; end; if (top3<>nil)and(top3^.no<>son)and(control=0) then begin if (tekmi(top3^.no)=1)and(top3^.no<top2^.no) then begin son:=top3^.no; str(son,cevir); Push(pop(top3),top2); control:=10; yazdir; end; if (tekmi(top3^.no)=2)and(top3^.no<top1^.no)and(control=0) then begin son:=top3^.no; str(son,cevir); Push(pop(top3),top1); control:=10; yazdir; end; end; control:=0; counter:=counter+1; str(counter,cevir); outtextxy(20,370,'Number of move :');outtextxy(150,370,cevir); readkey; until deger=counter; end; if tekmi(n)=2 then begin repeat if (top1<>nil)and(top1^.no<>son) then begin if (tekmi(top1^.no)=1)and(top1^.no<top2^.no) then begin son:=top1^.no; str(son,cevir); Push(pop(top1),top2); control:=10; yazdir; end; if (tekmi(top1^.no)=2)and(top1^.no<top3^.no)and(control=0) then begin son:=top1^.no; str(son,cevir); Push(pop(top1),top3); control:=10; yazdir; end; end; if (top2<>nil)and(top2^.no<>son)and(control=0) then begin if (tekmi(top2^.no)=1)and(top2^.no<top3^.no) then begin son:=top2^.no; str(son,cevir); Push(pop(top2),top3); control:=10; yazdir; end; if (tekmi(top2^.no)=2)and(top2^.no<top1^.no)and(control=0) then begin son:=top2^.no; str(son,cevir); Push(pop(top2),top1); control:=10; yazdir; end; end; if (top3<>nil)and(top3^.no<>son)and(control=0) then begin if (tekmi(top3^.no)=1)and(top3^.no<top1^.no) then begin son:=top3^.no; str(son,cevir); Push(pop(top3),top1); control:=10; yazdir; end; if (tekmi(top3^.no)=2)and(top3^.no<top2^.no)and(control=0) then begin son:=top3^.no; str(son,cevir); Push(pop(top3),top2); control:=10; yazdir; end; end; control:=0; counter:=counter+1; str(counter,cevir); outtextxy(20,350,'Number of move :');outtextxy(150,350,cevir); readkey; until deger=counter; end; end. Вот скриншот работы программы: А вот один из нерекурсивных алгоритмов (автор Atos) program HanoyTower; type TInt=longint; procedure Tower(n:TInt); var m,k,l,s:TInt; iz,v,c,x:byte; begin n:=longint(round(exp(nln(2))))-1; for m:=1 to n do begin iz:=1; c:=2; v:=3; k:=1; l:=n; s:=(k+l) div 2; repeat if m<s then begin x:=v; v:=c; c:=x; l:=s-1; end; if m>s then begin x:=iz; iz:=c; c:=x; k:=s+1; end; if m=s then begin writeln(iz,'-',v); break; end; s:=(k+l) div 2; until 22=5; end; end; var n:TInt; begin n:=4; Tower(n); readln; end. И на последок, еще одна программа (автор volvo) визуализирующая решение. program Hanoy; uses Crt,Graph; type ArrType =array [1..1] of byte; var Col, Beg,End_ :byte; Arr :^ArrType; i,j :integer; CountMoves: longint; procedure GraphInit; var GrDr,GrMode:smallint; begin GrDr:=d8bit; GrMode:=m640x480; InitGraph(GrDr,GrMode,''); end; procedure DrawRings; var a,b,c:byte; begin ClearDevice; SetColor(White); Line(100,200,100,400); Line(300,200,300,400); Line(500,200,500,400); Line(50,400,550,400); SetFillStyle(SolidFill, Red); SetColor(Yellow); j:=0;a:=0;b:=0;c:=0; for i:=1 to Col do case Arr^[i] of 0:Inc(a); 1:Inc(b); 2:Inc©; end; for i:=1 to Col do begin case Arr^[i] of 0:begin Bar(100+Arr^[i]200-i5,400-a5,100+Arr^[i]200+i5,400-a5-5); Rectangle(100+Arr^[i]200-i5,400-a5,100+Arr^[i]200+i5,400-a5-5); Dec(a); end; 1:begin Bar(100+Arr^[i]200-i5,400-b5,100+Arr^[i]200+i5,400-b5-5); Rectangle(100+Arr^[i]200-i5,400-b5,100+Arr^[i]200+i5,400-b5-5); Dec(b); end; 2:begin Bar(100+Arr^[i]200-i5,400-c5,100+Arr^[i]200+i5,400-c5-5); Rectangle(100+Arr^[i]200-i5,400-c5,100+Arr^[i]200+i5,400-c5-5); Dec©; end; end; end; if ReadKey=#27 then begin CloseGraph; halt(1); end; while KeyPressed do Readkey; end; procedure PrintQuant(c,b,e:byte); begin Arr^[c]:=e; DrawRings; Inc(CountMoves); end; procedure Move(c,b,e:byte); begin if c=1 then PrintQuant(c,b,e) else begin Move(c-1,b,3-b-e); PrintQuant(c,b,e); Move(c-1,3-b-e,e); end; end; begin CountMoves := 0; GraphInit; Beg:=0; End_:=2; Col:=4; GetMem(Arr,Col); for i:=1 to Col do Arr^[i]:=Beg; DrawRings; Move(Col,Beg,End_); Freemem(Arr,Col); CloseGraph; writeln('Count = ', CountMoves); ReadLn; end. -------------------- Помогая друг другу, мы справимся с любыми трудностями! "Не опускать крылья!" (С)

Внимание! Действует предмодерация