IPB
ЛогинПароль:

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

Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.

 
 Ответить  Открыть новую тему 
> Ханойские башни.
сообщение
Сообщение #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 килобайт ) Кол-во скачиваний: 1432

Исходный код

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.

Прикрепленное изображение


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 




- Текстовая версия 22.08.2017 12:12
Хостинг предоставлен компанией "Веб Сервис Центр" при поддержке компании "ДокЛаб"