Конкурс на решение задачи!, Переправа через реку... ну очень широкую Опции

[APAL]

Каюсь, иногда играю в комп. игры. И вот в "Космических рейнджерах" был квест с этой задачкой:

Дано:
Река, лодка вместимостью 2 человека, два берега.
Условия:
На одном берегу 4 человека. Первый может проплыть на лодке на другой берег за 1 час, второй за 2 часа, третий за 5 часов, четвертый за 10 часов. Если в лодке два человека то она проплывет за время "самого медленного пассажира".
Задача:
Необходимо перевести всех людей на другой берег не более чем за 18 часов!

Сходу решить мне не удалось - написал на Паскале. Квест прошел.
Свой вариант выложу по окончанию времени конкурса.

Условия конкурса:
Свои решения присылать на "мыло": apalprival @ narod . ru.
Срок проведения 2 недели, т.е. до 7 февраля 2005 г. (это еще можно обсудить)

Номинации:
1. Самое первое правильное решение.
2. Самое короткое-оптимальное решение.
3. Самое изощренное решение.

Каждому победителю +1 к повышению рейтинга на форуме.

Свои решения присылайте в архивированном виде! И не забудьте включить в архив исполняемый модуль (*.EXE), дабы избежать конфликтов компиляторов.

[Altair]

Опровержение такой возможности: (ИМХО)

[APAL]

Oleg_Z, не совсем все так просто... вот один из вариантов решения:

[Altair]

да, все понял....
я не учел что

[Junkie]

я наверное тупой... но по-моему невозможно перевезти людей за 18 часов... минимальное время - 19 часов... разве-что пустую лодка сама может приплыть обратно на другой берег....

Первый едет с 4-ым на берег 2 +10 часов
Первый возвращается на берег 1 +1 час
Первый едет с 3-ым на берег 2 +5 часов
Первый возвращается на берег 1 +1 час
Первый едет с 2-ым на берег 2 +2 часов

10+1+5+1+2=19

Сообщение отредактировано: volvo - 3.02.2005 21:38

[volvo]

Junkie
Возможно и не только за 18, а за 17 - точно. Может быть, можно и за меньшее время. Кто знает...

[GoodWind]

Apal, ты мой герой !!!!
я над этим квестом 3-е суток парился, так и не решил :no:
стока денег и респекту потерял...

[Altair]

я наверное тупой... но по-моему невозможно перевезти людей за 18 часов... минимальное время - 19 часов... разве-что пустую лодка сама может приплыть обратно на другой берег....

Нет, просто ты забыл, что оттуда может вернуться кто-то кто уже там ;)

[APAL]

Apal, ты мой герой !!!!
я над этим квестом 3-е суток парился, так и не решил  :no:
стока денег и респекту потерял...

Я тоже немного посидел и вот сделал прогу которая сама все решила... :D
А задачка хорошая, мне понравилась!

[FreeMan]

Я Рейнджеров купил, как только они вышли. Этот квест проходил тупым перебором. Потом прошёл (17 часов). Кстати, там можно делать свои квесты (есть прога на сайте производителя).

[APAL]

FreeMan - флейм! Давайте не отклоняться от темы.



Дамы и господа!
Неужели все так сложно? Или сроки проведения конкурса продлить?
Еще ни одного письма с решением не получил!


P.S.: Мозги надо иногда разминать...

[APAL]

Первое решение поступило.

[Jahnerus]

APAL
:D Жди последнего дня ... тебя решениями завалят ... всё же как обычно делается в последний день. (точнее в последнюю ночь)

[Jahnerus]

APAL
Письмо моё получил?

[APAL]

APAL
Письмо моё получил?

Да, письмо получил.
От Volvo тоже пришло второе решение.

[APAL]

Итак, можно подводить итог!
К сожалению конкурсантов всего двое.
Я рад такому бурному и оживленному решению поставленной задачи. (камень в огород тех кто не принял участи)

[APAL]

1. Самое первое правильное решение
VOLVO

Исходный код

const
  size = 4;
type
  all_type = array[1 .. size] of integer;
  pair = array[1 .. 2] of word;

const
  s1_len = 6;
  step_one: array[1 .. s1_len] of pair =
    ((1, 2), (1, 3), (1, 4), (2, 3), (2, 4), (3, 4));

  s2_len = 2;
  step_two: array[1 .. s2_len] of word =
    (1, 2);

  s3_len = 3;
  step_three: array[1 .. s3_len] of pair =
    ((1, 2), (2, 3), (1, 3));

  s4_len = 3;
  step_four: array[1 .. s4_len] of word =
    (1, 2, 3);

  s5_len = 1;
  step_five: array[1 .. s5_len] of pair =
    ((1, 2));


const
  right: all_type = (1, 2, 5, 10);
  left: all_type = (-1, -1, -1, -1);

procedure compact(var x: all_type);
  var T: all_type;
  i, next: byte;
  begin
    move(x, T, sizeof(x));
    next := 0;
    for i := 1 to size do
      if T[i] <> -1 then
        begin
          inc(next);
          x[next] := T[i]
        end;
    for i := succ(next) to size do
      x[i] := -1;
  end;

procedure append(var x: all_type; a: word);
  var i: integer;
  begin
    i := 1;
    while x[i] <> -1 do inc(i);
    x[i] := a;
  end;

function max(a, b: word): word;
  begin
    max := a;
    if b > a then max := b
  end;

function get_two(by: pair; var x: pair): word;
  begin { from right }
    x[1] := right[by[1]]; right[by[1]] := -1;
    x[2] := right[by[2]]; right[by[2]] := -1;
    compact(right);
    get_two := max(x[1], x[2])
  end;

function get_one(by: word; var x: word): word;
  begin { from left }
    x := left[by]; left[by] := -1;
    compact(left);
    get_one := x
  end;

procedure print_array(x: all_type);
  var i: byte;
  begin
    for i := 1 to size do
      if x[i] <> -1 then write(x[i]:4);
    writeln
  end;


var
  min1, min2, min3, min4, min5: byte;
  mp: pair; path, T: word;

procedure create_path;
  var
  right0, right1, right2, right3, right4,
  left0, left1, left2, left3, left4: all_type;
  s1, s2, s3, s4: word;
  p1, p2, p3, p4, p5: byte;
  min_path: word;
  begin
    path := 0; min_path := maxInt;

    move(left, left0, sizeof(left));
    move(right, right0, sizeof(right));
    for p1 := 1 to s1_len do
      begin
        move(left0, left, sizeof(left));
        move(right0, right, sizeof(right));

        path := get_two(step_one[p1], mp);
        append(left, mp[1]); append(left, mp[2]);

        s1 := path;
        move(left, left1, sizeof(left));
        move(right, right1, sizeof(right));

        for p2 := 1 to s2_len do
          begin
            path := s1;
            move(left1, left, sizeof(left));
            move(right1, right, sizeof(right));

            inc(path, get_one(step_two[p2], T));
            append(right, T);

            s2 := path;
            move(left, left2, sizeof(left));
            move(right, right2, sizeof(right));
            for p3 := 1 to s3_len do
              begin
                path := s2;
                move(left2, left, sizeof(left));
                move(right2, right, sizeof(right));

                inc(path, get_two(step_three[p3], mp));
                append(left, mp[1]); append(left, mp[2]);

                s3 := path;
                move(left, left3, sizeof(left));
                move(right, right3, sizeof(right));
                for p4 := 1 to s4_len do
                  begin
                    path := s3;
                    move(left3, left, sizeof(left));
                    move(right3, right, sizeof(right));

                    inc(path, get_one(step_four[p4], T));
                    append(right, T);

                    s4 := path;
                    move(left, left4, sizeof(left));
                    move(right, right4, sizeof(right));

                    for p5 := 1 to s5_len do
                      begin
                        path := s4;
                        move(left4, left, sizeof(left));
                        move(right4, right, sizeof(right));

                        inc(path, get_two(step_five[p5], mp));
                        append(left, mp[1]); append(left, mp[2]);

                        if min_path > path then
                          begin
                            min1 := p1; min2 := p2; min3 := p3;
                            min4 := p4; min5 := p5;
                            min_path := path;
                          end;
                      end;
                  end;
              end;
          end;
      end;
    writeln('min path len = ', min_path);

    move(left0, left, sizeof(left));
    move(right0, right, sizeof(right));
  end;

begin
  write('right'); print_array(right);
  write('left'); print_array(left);

  writeln('starting...');
  create_path;

  {#1}
  path := get_two(step_one[min1], mp);
  append(left, mp[1]); append(left, mp[2]);
  writeln('right > left: ', mp[1]:4, mp[2]:4, ' time = ', path);

  {#2}
  inc(path, get_one(step_two[min2], T));
  append(right, T);
  writeln('left > right: ', T:4, ' time = ', path);

  {#3}
  inc(path, get_two(step_three[min3], mp));
  append(left, mp[1]); append(left, mp[2]);
  writeln('right > left: ', mp[1]:4, mp[2]:4, ' time = ', path);

  {#4}
  inc(path, get_one(step_four[min4], T));
  append(right, T);
  writeln('left > right: ', T:4, ' time = ', path);

  {#5}
  inc(path, get_two(step_five[min5], mp));
  append(left, mp[1]); append(left, mp[2]);
  writeln('right > left: ', mp[1]:4, mp[2]:4, ' time = ', path);
end.

[APAL]

2. Самое короткое-оптимальное решение.
Jahnerus

Исходный код

{© by Jahnerus}
type
 ma3x=array[1..4] of byte;
 ma3x_moves=array[1..5,1..2] of byte;
 ma3x_bool=array[1..4] of boolean;
const
 time:ma3x=(1,2,5,10);
var
 ident:ma3x_bool;
 moves:ma3x_moves;
 f:text;

{------------ Podschet vremeni --------------}

function get_time(moves:ma3x_moves):byte;
var
 i,tmp:byte;
begin
 tmp:=0;
 for i:=1 to 5 do begin
   if time[moves[i,1]]>time[moves[i,2]] then tmp:=tmp+time[moves[i,1]]
   else tmp:=tmp+time[moves[i,2]];
 end;
 get_time:=tmp;
end;

{------- Proverka vremeni i vivod dannih ---------}

procedure check(moves:ma3x_moves);
var
 i:byte;
begin
 if get_time(moves)<=18 then begin
   for i:=1 to 5 do begin
     if i mod 2 = 0 then write(f,' ',time[moves[i,1]],' ')
     else write(f,time[moves[i,1]],'-',time[moves[i,2]]);
   end;
   writeln(f,' za ',get_time(moves),' chasov');
 end;
end;

{------------- Peredvijeniya lodki ------------}

procedure boat_moves(moves:ma3x_moves; n:byte; ident:ma3x_bool; flag:boolean);
var
 i,j:byte;
begin
 if n<=5 then begin
   for i:=1 to 4 do begin
     if (ident[i]) xor (flag) then begin
       moves[n,1]:=i;
       ident[i]:=flag;
       if flag then begin
         for j:=i+1 to 4 do begin
           if not(ident[j]) then begin
             moves[n,2]:=j;
             ident[j]:=flag;
             boat_moves(moves,n+1,ident,not(flag));
             ident[j]:=not(flag);
           end;
         end;
       end
       else begin
         moves[n,2]:=i;
         boat_moves(moves,n+1,ident,not(flag));
       end;
       ident[i]:=not(flag);
     end;
   end;
 end
 else check(moves);
end;

{------------ Osnovnoy blok --------------}

begin
 assign(f,'out.txt');
 rewrite(f);
 boat_moves(moves,1,ident,true);
 close(f);
end.

[APAL]

3. Самое изощренное решение.
VOLVO

Исходный код

uses crt;
const
 players = 4;
 {
   players = 6;
 }

type
 all_type = array[1 .. players] of integer;
 pair = array[1 .. 2] of word;

const
 right: all_type = (1, 10, 5, 2);
   {
     (1, 10, 5, 2, 11, 3);
   }
 left: all_type = (-1, -1, -1, -1);
   {
     (-1, -1, -1, -1, -1, -1);
   }

type
 PTForward = ^step_forward;
 step_forward = array[1 .. maxInt div sizeof(pair)] of pair;
 PTBackward = ^step_backward;
 step_backward = array[1 .. maxint div sizeof(word)] of word;

type
 TDirection =
   (drForward, drBackward);
 TOptimized =
   Record
     save_left, save_right: all_type;
     save_path: integer;

     len: word;
     case going: TDirection of
       drForward : (arr_f: PTForward);
       drBackward: (arr_b: PTBackward);
   End;

 TArrOptimized = ^arrOptimized;
 arrOptimized =
   array[0 .. pred(maxint) div sizeof(TOptimized)] of TOptimized;

var
 opt_arr_index: integer;
 opt_arr: TArrOptimized;

function count_forward(n: byte): byte;
 begin
   if n <= 1 then count_forward := 0
   else count_forward :=
     count_forward(pred(n)) + pred(n)
 end;

function moves(n: byte): byte;
 begin
   moves := succ((n - 2) shl 1)
 end;

procedure generate;

 function generate_forward(right: integer;
          var arr: PTForward): integer;
   var
     i, j, count: integer;
   begin
     count := count_forward(right);
     getmem(arr, count*sizeof(pair));

     count := 0;
     for i := 1 to pred(right) do
       for j := succ(i) to right do
         begin
           inc(count);
           arr^[count][1] := i;
           arr^[count][2] := j;
         end;
     generate_forward := count;
   end;

 function generate_backward(left: integer;
          var arr: PTBackward): integer;
   var count: integer;
   begin
     getmem(arr, left*sizeof(word));
     for count := 1 to left do
       arr^[count] := count;
     generate_backward := count;
   end;

 var
   on_right: integer;
 begin
   getmem( opt_arr,
           succ(moves(players)) * sizeof(TOptimized) );

   opt_arr_index := 0;

   move(left, opt_arr^[0].save_left, sizeof(left));
   move(right, opt_arr^[0].save_right, sizeof(right));
   opt_arr^[0].save_path := 0;

   on_right := players;
   while on_right > 0 do
     begin
       inc(opt_arr_index);
       with opt_arr^[opt_arr_index] do
         begin
           going := drForward;
           len := generate_forward(on_right, arr_f);
         end;
       dec(on_right, 2);

       if on_right = 0 then break;

       inc(opt_arr_index);
       with opt_arr^[opt_arr_index] do
         begin
           going := drBackward;
           len := generate_backward(players-on_right, arr_b);
         end;
       inc(on_right)
     end;
 end;

procedure compact_array(var x: all_type);
 var T: all_type;
 i, next: byte;
 begin
   move(x, T, sizeof(x));
   next := 0;
   for i := 1 to players do
     if T[i] <> -1 then
       begin
         inc(next);
         x[next] := T[i]
       end;
   for i := succ(next) to players do
     x[i] := -1;
 end;

procedure append_array(var x: all_type;
         const n: byte; var avar);
 var
   a: pair absolute avar;
   i, j: integer;
 begin
   i := 1;
   while x[i] <> -1 do inc(i);
   for j := 0 to pred(n) do
     x[i + j] := a[succ(j)]
 end;

procedure print_array(x: all_type);
 var i: byte;
 begin
   for i := 1 to players do
     if x[i] <> -1 then write(x[i]:4);
   writeln
 end;

function get_number(var from: all_type;
        const n: byte; var byvar, xvar): word;
 var
   x: pair absolute xvar;
   by: pair absolute byvar;
   i: byte;
 begin
   for i := 1 to n do
     begin
       x[i] := from[by[i]]; from[by[i]] := -1;
     end;
   compact_array(from);
   get_number := x[1];
   if (n = 2) and (x[2] > x[1])
     then get_number := x[2]
 end;


var
 mins, ps: PTBackward;
 mp: pair; path, T: word;

const
 min_path: integer = maxInt;


procedure go_for_it(n: integer);
 var p, i: integer;
 begin

   move(left, opt_arr^[n].save_left, sizeof(left));
   move(right, opt_arr^[n].save_right, sizeof(right));
   for p := 1 to opt_arr^[n].len do
     begin
       path := opt_arr^[pred(n)].save_path;
       move(opt_arr^[pred(n)].save_left, left, sizeof(left));
       move(opt_arr^[pred(n)].save_right, right, sizeof(right));

       ps^[n] := p;

       with opt_arr^[n] do
         case going of
         drForward:
           begin
             inc(path, get_number(right, 2, arr_f^[p], mp));
             append_array(left, 2, mp)
           end;
         drBackward:
           begin
             inc(path, get_number(left, 1, arr_b^[p], T));
             append_array(right, 1, T)
           end;
         end;

       if n = opt_arr_index then
         begin
           if min_path > path then
             begin
               move(ps^[1], mins^[1], n * sizeof(word));
               min_path := path
             end;

           move(opt_arr^[n].save_left, left, sizeof(left));
           move(opt_arr^[n].save_right, right, sizeof(right));
         end
       else
         begin
           opt_arr^[n].save_path := path;

           move(left, opt_arr^[n].save_left, sizeof(left));
           move(right, opt_arr^[n].save_right, sizeof(right));

           go_for_it(succ(n))
         end;
     end;
 end;

var
 i: integer;

begin
 clrscr;
 write('right'); print_array(right);
 write('left'); print_array(left);
 writeln;

 generate;
 getmem(mins, opt_arr_index*sizeof(word));
 getmem(ps, opt_arr_index*sizeof(word));

 go_for_it(1);
   move(opt_arr^[0].save_left, left, sizeof(left));
   move(opt_arr^[0].save_right, right, sizeof(right));

 path := 0;
 for i := 1 to opt_arr_index do
   with opt_arr^[i] do
     begin
       case going of
       drForward:
         begin
           inc(path, get_number(right, 2, arr_f^[mins^[i]], mp));
           append_array(left, 2, mp);
           writeln('right > left: ', mp[1]:4, mp[2]:4, ' time = ', path);

           freemem(arr_f, len*sizeof(pair))
         end;
       drBackward:
         begin
           inc(path, get_number(left, 1, arr_b^[mins^[i]], T));
           append_array(right, 1, T);
           writeln('left > right: ', T:4, ' time = ', path);

           freemem(arr_b, len*sizeof(word))
         end;
       end
     end;

 freemem(ps, opt_arr_index*sizeof(word));
 freemem(mins, opt_arr_index*sizeof(word));
 freemem( opt_arr,
          succ(moves(players)) * sizeof(TOptimized) );
end.

[APAL]

И наконец мой вариант:

Uses MyServis {из этого модуля используется только функция IntToStr - преобразование числа в строку};
Type
  tm = Array[1..4,1..2] of Byte;
  tr = Record
         mm  : tm;   {kto gde}
         n {proshlo chasov},
         k {kakoy bereg 1-Left,2-Right} : Byte;
         S   : String; {LOG}
       End;

Var
  m : tr;

Function CheckEnd(vv : tr) : Boolean;
Var jj : Byte;
Begin
  CheckEnd:=True;
  For jj:=1 to 4 do
    If (vv.mm[jj,1]<>0) then CheckEnd:=False;
End;

Function Revers(r : Byte) : Byte;
Begin
  If r=1 then Revers:=2 else Revers:=1;
End;

Function Compare(a,b : Byte) : Byte;
Begin
  If a>b then Compare:=a else Compare:=b;
End;

Function NumSide(vv : tr) : Byte;
Var jj,kk : Byte;
Begin
  kk:=0;
  For jj:=1 to 4 do If vv.mm[jj,vv.k]<>0 then Inc(kk);
  NumSide:=kk;
End;

Procedure Sortmm(Var vv : tr);
Var ii,jj,tmp,q : Byte;
Begin
 For q:=1 to 2 do
  For ii:=1 to 3 do
   For jj:=ii+1 to 4 do
   Begin
     If vv.mm[ii,q]<vv.mm[jj,q] then
     Begin
       tmp:=vv.mm[ii,q];
       vv.mm[ii,q]:=vv.mm[jj,q];
       vv.mm[jj,q]:=tmp;
     End;
   End;
End;

Procedure Go(v : tr);
Var i,j : Byte;
    v0  : tr;
Begin
  Case v.k of
    2 : Begin
          For i:=1 to NumSide(v) do
          Begin
            v0:=v;
            v0.S:=v0.S+' '+IntToStr(v0.mm[i,2])+' ';
            v0.k:=1;
            v0.mm[NumSide(v0)+1,1]:=v0.mm[i,2];
            Inc(v0.n,v0.mm[i,2]);
            v0.mm[i,2]:=0;
            Sortmm(v0);
            Go(v0);
          End;
        End;

    1 : Begin
          For i:=1 to NumSide(v)-1 do
           For j:=i+1 to NumSide(v) do
           Begin
             v0:=v;
             v0.S:=v0.S+IntToStr(v0.mm[i,1])+'-'+IntToStr(v0.mm[j,1]);
             v0.k:=2;
             v0.mm[NumSide(v0)+1,2]:=v0.mm[i,1];
             v0.mm[NumSide(v0)+2,2]:=v0.mm[j,1];
             Inc(v0.n,Compare(v0.mm[i,1],v0.mm[j,1]));
             v0.mm[i,1]:=0;
             v0.mm[j,1]:=0;
             Sortmm(v0);
             If CheckEnd(v0) and (v0.n<=18) then
             Begin
               Writeln(v0.S);
               {Halt(0);}Exit;
             End;
             Go(v0);
           End;
        End;
  End;
End;

Begin
  m.mm[1,1]:=1; m.mm[2,1]:=2; m.mm[3,1]:=5; m.mm[4,1]:=10;
  m.mm[1,2]:=0; m.mm[2,2]:=0; m.mm[3,2]:=0; m.mm[4,2]:=0;
  m.n:=0; m.S:=''; m.k:=1;
  Go(m);
End.