VPF::Рекурсивное решение задачи о Хонойских башнях

bullvinkle

Дата 31.3.2008, 21:22 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 52
Регистрация: 18.3.2008

Репутация: нет
Всего: нет

Всемиизвестную задачу о Ханойских башнях нам предлагают решить рекурсивно при помощи стеков.
Я написал процедуру перемещения колец (MOV в программе) , и как по мне, так она обязана работать идеально, но
если кольцо всего одно, процедура работает (слава Богу, что хоть где то правильно), а когда делаю отладку при двух кольцах, то на строчке №28 происходит то, чего я не прошу - диск с третьей башни переходит на вторую.
Может я чего то не понимаю, объясните пожалуйсто.

На всякий случай дам алгоритм рекурсивного решения задачи о Ханойских башнях:

Если m=1, то перенеси один диск с s1 на s2. Если же m> 1, то перенеси временно m - 1 верхних дисков с s1 на s3. Потом перенеси один оставшийся диск с s1 на s2 и, наконец, перенеси m - 1 дисков, хранящихся на s3, на шпиль s2. Что касается перенесения m-1 дисков, то для этого подойдет тот же алгоритм, но с уменьшенным (от m до m-1) числом переносимых дисков. Таким образом, мы перейдем от m к m-1, oт m-1 к m-2, m-3,... и дойдем до единицы

А так же саму задачу:
В центре мира в вершинах равностороннего треугольника в землю вбиты три алмазных шпиля. На одном из них надето 64 золотых диска убывающих радиусов (самый большой – нижний). Трудолюбивые буддийские монахи день и ночь переносят диски с одного шпиля на другой. При этом, диски следует переносить по одному и нельзя класть больший диск на меньший. Когда все диски перенесут на другой шпиль, наступит конец света (задачу и рассказ придумал математик Эдуар Люка в 1883 г.).

Код


type stack = array [1..10] of integer ;
var s1,s2,s3:stack; {это и есть башни}
    m,i,n: integer;
    t1,t2,t3:integer; {указатели, на сколько заполнен стек}
procedure pop ( var s:stack;var t:integer);{извлечение}
 begin
  n:=s[t];         {взять в руки верхний диск}
  s[t]:=0;         {теперь то место, где был верхний диск, стало пустым}
  t:=t-1;          {сделать верхним диском пред. диск}
 end;
procedure push (var s:stack; var t: integer);  {добавление}
 begin
  t:=t+1;          {верхним диском стал след. диск}
  s[t]:=n;         {положили на верх то, что было у нас в руках}
 end;
procedure mov (var m:integer;var s1,s2,s3:stack);   {переместить все диски с 1 на 2}
 begin
  if m=1 then      {если диск всего один}
   begin
    pop (s1,t1);   {сниммем с исходного штыря диск}
    push (s2,t2);  {повесим на конечный}
   end;
  if t1 > 1 then   {если дисков больше одного}
   begin
    pop (s1,t1);   {снять диск с исходного}
    push (s3,t3);  {положить его на промежуточный}
    m:=t1;
    mov (m,s1,s3,s2); {повторить все то же, считая промежуточный диск конечным и наоборот}
   { pop (s1,t1);   {переместить оставшийся один}
   { push (s2,t2);  {диск с начального диска на конечный}
    m:=t3;
    mov (m,s3,s1,s2); {сделать все то же самое, считая начальный вспомогателным и наоборот}
   end;
end;

BEGIN
  write ('Введите число дисков ');
  read(m);
  t1:=0;
  t2:=0;
  t3:=0;
  n:=0;
  for i:=1 to m do    {заполняем стеки}
   begin
    n:=n+1;
    push (s1,t1);
   end;
  mov (n,s1,s2,s3);
END.

Буду очень благодарен за помощь, так как преподаватель считает неправильным мне помогать.

megabist

Дата 1.4.2008, 00:23 (ссылка)

(нет голосов)

Загрузка ...

Mart Slaaf

Профиль
Группа: Участник
Сообщений: 455
Регистрация: 3.4.2006
Где: Мск

Репутация: нет
Всего: 31

разрешите в ответ просто предложить вам свой вариант решения.

Код


program bashan;

 const
  C=50;

 type
  name=string[255];
  strish=string[6];
  sterjni=array[1..3,1..C] of byte;

 procedure chistko (Var massiv:sterjni; N:byte);
  Var
   i,j:byte;
  begin
   for i:=1 to 3 do{'очищаем' 'стержни'}
    for j:=1 to N do
     massiv[i,j]:=0;
  end;

 function namster(number:byte):strish;
  begin
   case number of
    1: namster:='A';
    2: namster:='B';
    3: namster:='C';
   end;
  end;

 procedure pereklad (var outputfile:text; var massiv:sterjni; Inp,Out,N:byte);
  Var
   i,rings:byte;
   vivod,tmp:strish;
  begin
   rings:=N;
   str(massiv[Inp,N],tmp); {писалось для вывода в форме номер стержня: действие поэтому сейчас строка не используется}
   vivod:=namster(Inp)+'->'+namster(Out);
   writeln(outputfile,Vivod);
   if massiv[Out,rings]=0 then{если стержень пуст-}
    begin
     massiv[Out,rings]:=massiv[Inp,N];{-перекладываем кольцо}
     massiv[Inp,N]:=0;
    end
   else{если нет-}
    begin
     i:=1;
      while not (massiv[Out,i]=0) and (massiv[Out,i+1]<>0) do{ищем на какое место можно положить кольцо}
       inc(i);
      massiv[Out,i]:=massiv[Inp,i];
      massiv[Inp,i]:=0;
    end;
  end;

 procedure recure (N,StInp,StOut:byte; var massiv:sterjni; var outputfile:text);
  Var
   StProm:byte;
  begin
   StProm:=6-(StInp+StOut);
   if N=1 then{если надо переложить 1 кольцо-}
    begin
     pereklad(outputfile,massiv,StInp,StOut,N);{-перекладываем}
    end
   else{иначе}
    begin
    recure(N-1,StInp,StProm,massiv,outputfile);{перекладываем N-1 кольцо на вспомогательный стержень}
    pereklad(outputfile,massiv,StInp,StOut,N);{перекладываем 1 кольцо на нужный стержень}
    recure(N-1,StProm,StOut,massiv,outputfile);{перекладываем кольца с вспомогательного на нужный стержень}
    end;
  end;

procedure numerr(var Mas: sterjni; N: byte);
  var
   j,i: byte;
 begin
  j:=0;
  for i:=1 to N do{нумеруем кольца снизу вверх}
   begin
    Mas[1,i]:=N-j;
    inc(j);
   end;
 end;

  Var
  output,finput,foutput:text;
  N:byte;
  outputname:name;
  Mas:sterjni;
 begin
    writeln('Введите число колец');
    readln(N);{получить число колец}
    writeln('Введите имя файла, куда запишутся действия');
    readln(outputname);{получить имя файла}
    assign(output,outputname);
    rewrite(output);
    chistko(Mas,N);{'очищаем' 'стержни'}
    numerr(Mas,N);
    recure(N,1,2,Mas,output);{записать в файл последовательность действий по перекладыванию колец}
    close(output);
    readln;
 end.

надеюсь это вам поможет в чём-то.
сейчас не смогу посмотреть ваш код, устал. завтра постараюсь.

Добавлено через 13 минут и 37 секунд
я посмотрел, вы так сами сделали, вы туда передаёте s3 а принимаете его в процедуре, как s2. поэтому с вашим диском всё в порядке.

--------------------

Don't panic!

Жди, и Фатум тебя приведёт...

bullvinkle

Дата 1.4.2008, 12:30 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 52
Регистрация: 18.3.2008

Репутация: нет
Всего: нет

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

"я посмотрел, вы так сами сделали, вы туда передаёте s3 а принимаете его в процедуре, как s2. поэтому с вашим диском всё в порядке."
Подскажите, что нужно поменять - у меня ступор уже 4 дня )).
Я действительно считаю, что процедура должна работать правильно и в упор не вижу ошибки, т.к. разрабатывая ее, опирался на вот этот алгоритм

Код


program Hanoi_Towers;
uses Crt;
var n : Integer;
procedure Move_Disks (n : Byte; Source, Dest, Tmp : Char);
{ n      - Число дисков на столбике Source             }
{ Source - Исходный столбик                            }
{ Dest   - Столбик, на который нужно переставить диски }
{ Tmp    - Вспомогательный столбик                     }
begin
    if n = 1 then
      Writeln('Переставить диск номер 1 со столбика ',
               Source, ' на столбик ', Dest)
    else begin
{Переставляем n-1 верхних дисков с исходного столбика на}
{вспомогательный, используя целевой диск как промежуточный}
      Move_Disks ( n-1, Source, Tmp, Dest );
      Writeln('Переставить диск номер ', n:1, ' со столбика ',
               Source, ' на столбик ', Dest);
{Переставляем все n-1 диск, расположенные на вспомогательном}
{ столбике, на целевой, используя исходный диск как
  промежуточный }
      Move_Disks ( n-1, Tmp, Dest, Source);
    end
end;
begin
  ClrScr;
  Write('Введите число дисков: ');
  Readln(n);
  Writeln;
  Writeln('Последовательность инструкций для решения задачи:');
  Writeln;
  Move_Disks (n, 'A', 'C', 'B')
end.

Dobermann

Дата 1.4.2008, 17:10 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 992
Регистрация: 7.1.2008

Репутация: нет
Всего: 0

Код


type position=(left, centre, right);
var n: integer;
procedure movedisk(from,tol: position);
  procedure writepos(p: position);
  begin
    case p of
      left:  write('1');
      centre: write('2');
      right: write('3');
    end;
  end;
begin
  writepos(from); write('->'); writepos(tol); writeln
end;
procedure movetower(hight: integer; from,tol,work: position);
begin
 if hight>0 then
   begin
     movetower(hight-1,from,work,tol);
     movedisk(from,tol);
     movetower(hight-1,work,tol,from);
   end;
end;
begin
writeln('Vvedite chislo kolec: ');readln(n);
movetower(n,right,left,centre);
readln
end.

Наверное проще некуда.....

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Object Pascal: кроссплатформенные технологии \| Следующая тема »