Форум «Всё о Паскале» _ Задачи _ Конкурс на решение задачи!
Автор: APAL 24.01.2005 19:19
Каюсь, иногда играю в комп. игры. И вот в "Космических рейнджерах" был квест с этой задачкой:
Дано: Река, лодка вместимостью 2 человека, два берега. Условия: На одном берегу 4 человека. Первый может проплыть на лодке на другой берег за 1 час, второй за 2 часа, третий за 5 часов, четвертый за 10 часов. Если в лодке два человека то она проплывет за время "самого медленного пассажира". Задача: Необходимо перевести всех людей на другой берег не более чем за 18 часов!
Сходу решить мне не удалось - написал на Паскале. Квест прошел. Свой вариант выложу по окончанию времени конкурса.
Условия конкурса: Свои решения присылать на "мыло": apalprival @ narod . ru. Срок проведения 2 недели, т.е. до 7 февраля 2005 г. (это еще можно обсудить)
Номинации: 1. Самое первое правильное решение. 2. Самое короткое-оптимальное решение. 3. Самое изощренное решение.
Каждому победителю +1 к повышению рейтинга на форуме.
Свои решения присылайте в архивированном виде! И не забудьте включить в архив исполняемый модуль (*.EXE), дабы избежать конфликтов компиляторов.
Автор: Altair 24.01.2005 20:22
Опровержение такой возможности: (ИМХО)
Скрытый текст
Если переправить троих человек - 2,5 и 10 часовых , то только ОТПРАВКА ИХ НА ТОТ БЕРЕГ будет занимать 2+5+10 часов =17 часов. А лодку еще надо возвращать обратно 2 раза. А в случае если поедут двое напрмиер 10+5 то обратно 5 часов возварщаться... Итого минимум 19 часов. вот доказательство на Паскале:
КОД:(в теги не заключать - пропадет невидимость!)
var a:array[1..4] of byte; i,j,k,l,time:byte; Function max(a,b:byte):byte; begin if a>b then max:=a else max:=b end; begin a[1]:=1; a[2]:=2; a[3]:=5; a[4]:=10;
For i:=1 to 4 do for j:=1 to 4 do for k:=1 to 4 do for l:=1 to 4 do begin If (i<>j)and(i<>k)and(i<>l)and(j<>k)and(j<>l)and(k<>l) then begin time:=max(a[i],a[j])+a[i]+ {ЇҐаҐўҐ§«Ё 1®Ј® ўҐаг«Ёбм} max(a[i],a[k])+a[i]+ {ЇҐаҐўҐ§«Ё в®в ЎҐаҐЈ ўв®а®Ј® 祫 } max(a[i],a[l]); If time<=18 then writeln(i,' ',j,' ',k,' ',l,' time = ',time); end end end.
Автор: APAL 24.01.2005 20:47
Oleg_Z, не совсем все так просто... вот один из вариантов решения:
Скрытый текст
1-2 2 10-5 1 2-1
Итог - 17 часов на переброску четырех человек.
Автор: Altair 24.01.2005 21:15
да, все понял.... я не учел что
Скрытый текст
может кто-то вернуться из тех, кто туда уже сплавал
Автор: Junkie 26.01.2005 0:18
я наверное тупой... но по-моему невозможно перевезти людей за 18 часов... минимальное время - 19 часов... разве-что пустую лодка сама может приплыть обратно на другой берег....
Первый едет с 4-ым на берег 2 +10 часов Первый возвращается на берег 1 +1 час Первый едет с 3-ым на берег 2 +5 часов Первый возвращается на берег 1 +1 час Первый едет с 2-ым на берег 2 +2 часов
10+1+5+1+2=19
Автор: volvo 26.01.2005 0:27
Junkie Возможно и не только за 18, а за 17 - точно. Может быть, можно и за меньшее время. Кто знает...
Автор: GoodWind 26.01.2005 0:28
Apal, ты мой герой !!!! я над этим квестом 3-е суток парился, так и не решил :no: стока денег и респекту потерял...
Автор: Altair 26.01.2005 0:30
Цитата
я наверное тупой... но по-моему невозможно перевезти людей за 18 часов... минимальное время - 19 часов... разве-что пустую лодка сама может приплыть обратно на другой берег....
Нет, просто ты забыл, что оттуда может вернуться кто-то кто уже там ;)
Автор: APAL 26.01.2005 0:32
Цитата(GoodWind @ 25.01.05 20:28)
Apal, ты мой герой !!!! я над этим квестом 3-е суток парился, так и не решил :no: стока денег и респекту потерял...
Я тоже немного посидел и вот сделал прогу которая сама все решила... :D А задачка хорошая, мне понравилась!
Автор: FreeMan 29.01.2005 16:21
Я Рейнджеров купил, как только они вышли. Этот квест проходил тупым перебором. Потом прошёл (17 часов). Кстати, там можно делать свои квесты (есть прога на сайте производителя).
Автор: APAL 29.01.2005 17:39
FreeMan - флейм! Давайте не отклоняться от темы.
Дамы и господа! Неужели все так сложно? Или сроки проведения конкурса продлить? Еще ни одного письма с решением не получил!
P.S.: Мозги надо иногда разминать...
Автор: APAL 31.01.2005 16:10
Первое решение поступило.
Автор: Jahnerus 31.01.2005 20:23
APAL :D Жди последнего дня ... тебя решениями завалят ... всё же как обычно делается в последний день. (точнее в последнюю ночь)
Автор: Jahnerus 4.02.2005 1:00
APAL Письмо моё получил?
Автор: APAL 4.02.2005 14:47
Цитата(Jahnerus @ 3.02.05 21:00)
APAL Письмо моё получил?
Да, письмо получил. От Volvo тоже пришло второе решение.
Автор: APAL 8.02.2005 0:48
Итак, можно подводить итог! К сожалению конкурсантов всего двое. Я рад такому бурному и оживленному решению поставленной задачи. (камень в огород тех кто не принял участи)
Автор: APAL 8.02.2005 0:53
1. Самое первое правильное решение VOLVO
Исходный код
const size = 4; type all_type = array[1 .. size] of integer; pair = array[1 .. 2] of word;
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;
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));
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 8.02.2005 1:01
3. Самое изощренное решение. VOLVO
Исходный код
uses crt; const players = 4; { players = 6; }
type all_type = array[1 .. players] of integer; pair = array[1 .. 2] of word;
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) );
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;
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);
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;