# Tom's family how to cross the bridge

A interesting question.Tom's family just have a flashlight which will extinguish after 30 seconds.They wanna go through a bridge to arrive opposite side with the flashlight.But as the picture,they need difference time to cross it alone.And a solw man with a faster man,the time depend on that slow man.The bridge only can bear two people at a time.They should how to cross it,then the time will be shortest?How to use method of graphs-and-networks to solve it?

• I'm voting to close this question as off-topic because the issue it raises is not a Mathematica issue but a mathematical one. That it is formulated in terms of Mathematica is not sufficient to make it an appropriate question for Mathematica.SE. Mar 28 '16 at 11:50
• @m_goldberg Confusion of the strict criterion about Mathematica and Mathematical
– yode
Mar 28 '16 at 12:02
• It's often a gray area, but in this case I think you asking for help with the logic of solving the problem much more than how to implement it in Mathematica. Others, may disagree with my assessment. If so, the question won't be closed. Mar 28 '16 at 12:07
• Oh I konw what you have say,I'll edit it in a right way
– yode
Mar 28 '16 at 12:09
• @barrycarter I have update a new method for this problem.
– yode
Feb 12 '17 at 16:03

A variant of the graph solution. I represent the flashlight as a sixth "person" with a crossing time of zero.

v = With[{s = Subsets[{0, 1, 3, 6, 8, 12}]}, Transpose[{Reverse@s, s}]];

f[{L1_, R1_}, {L2_, R2_}] := cross[R2 ⋂ L1, L2 ⋂ R1]

cross[LtoR : {0, Repeated[_, 2]}, {}] := Max[LtoR]
cross[{}, RtoL : {0, Repeated[_, 2]}] := Max[RtoL]
cross[__] := Infinity

g = WeightedAdjacencyGraph[v, Outer[f, v, v, 1]];

GraphDistance[g, First@v, Last@v]
(* 29. *)

Grid[FindShortestPath[g, First@v, Last@v], Alignment -> {{Right, Left}}]


Brief explanation

• v is the list of vertices for the graph, it contains every possible way of splitting the six people (actually five people plus one flashlight) between the two sides of the bridge.
• f takes two such vertices and works out who must cross from left to right, and who from right to left, to change from the first configuration to the second. For example R2 ⋂ L1 is the set of people who are on the right side in configuration 2 and on the left side in configuration 1 - these people must cross from left to right.
• cross returns the crossing time for a step, which will be the edge weight in the graph. The allowed steps consist of one or two people plus the flashlight crossing in one direction, and nobody crossing in the other direction. Any other step is forbidden and gets an infinite time.
• The graph is constructed from its weighted adjacency matrix, i.e. the result of applying f to each pair of vertices.
• The solution is the shortest path from the first configuration {{0, 1, 3, 6, 8, 12}, {}} to the last {{}, {0, 1, 3, 6, 8, 12}}
• I am getting a wonderful education from your answers. Thanks! +1 :) Mar 29 '16 at 8:46
• So inspiring!If you can add some explaination,it will be better.:)
– yode
Mar 29 '16 at 9:15
• Could you draw the graph?
– user1722
Mar 29 '16 at 13:26
• @barrycarter just evaluate g, then you see the graph. Mar 29 '16 at 13:30
• Have problem when two men with the same speed, maybe caused by Intersection. Nov 19 '17 at 5:04

Without graphs ... I don't see an easy way with them:

a = {1, 3, 6, 8, 12};
b = {};

go[{a_, b_, t_, c_}] := ({Complement[a, #], Join[b, #], t + Max@#, Append[c, #]} &/@
Subsets[a, {2}])

ret[{a_, b_, t_, c_}] := {Join[a, #], Complement[b, #], t + Max@#, Append[c, #]} &/@
Subsets[b, {1}]

gf[x_] := Flatten[go /@ x, 1];
rf[x_] := Flatten[ret /@ x, 1];

res = gf@rf@gf@rf@gf@rf[go /@ {{a, b, 0, {}}} // First];

Select[res, #1[[3]] <= 30 &][[All,3;;]]

(*
{{29, {{1, 3}, {1}, {6, 1}, {3}, {8, 12}, {1}, {3, 1}}},
{29, {{1, 3}, {1}, {6, 1}, {1}, {8, 12}, {3}, {1, 3}}},
{29, {{1, 3}, {1}, {8, 12}, {3}, {1, 6}, {1}, {3, 1}}},
{29, {{1, 3}, {1}, {8, 12}, {3}, {1, 3}, {1}, {6, 1}}},
{29, {{1, 3}, {3}, {8, 12}, {1}, {3, 1}, {1}, {6, 1}}},
{29, {{1, 3}, {3}, {8, 12}, {1}, {6, 1}, {1}, {3, 1}}},
{29, {{1, 6}, {1}, {3, 1}, {3}, {8, 12}, {1}, {3, 1}}},
{29, {{1, 6}, {1}, {3, 1}, {1}, {8, 12}, {3}, {1, 3}}}}
*)

• Good solution.Just didn't use graph.:)
– yode
Mar 29 '16 at 4:08

Here you have it solved by using graph functions. I don't think you gain anything by doing it this way

a = {1, 3, 6, 8, 12}; int = Intersection; len = Length;
validTransitionFwd[{a_, _}, {x_, _}]  :=  len@a - len@x == 2 && int[a, x] == x
validTransitionBkwd[{a_, _}, {x_, _}] :=  len@x - len@a == 1 && int[a, x] == a
transCost[{s1_, s2_}] := Max[Complement @@@ Transpose@{s1, s2}]

sa = Subsets[Flatten[{#, Reverse@#}&/@ ({Complement[a, #], #} & /@ Subsets@a), 1], {2}];

transitionsFwd = Thread[{{f, b}, #}] & /@ Select[sa, validTransitionFwd @@ # &];
transitionsBwd = Thread[{{b, f}, #}] & /@ Select[sa, validTransitionBkwd @@ # &];

g = Graph[DirectedEdge @@@ #, EdgeWeight -> transCost /@ #[[All, All, 2]]] &@
Union[transitionsBwd, transitionsFwd]

FindShortestPath[g, {f, {{1, 3, 6, 8, 12}, {}}}, {b, {{}, {1, 3, 6, 8,  12}}}][[All, 2]]
(*
{{{1, 3, 6, 8, 12}, {}},
{{6, 8, 12},       {1, 3}},
{{1, 6, 8, 12},    {3}},
{{1, 6},           {3, 8, 12}},
{{1, 3, 6},        {8, 12}},
{{6},              {1, 3, 8, 12}},
{{1, 6},           {3, 8, 12}},
{{},               {1, 3, 6, 8, 12}}}
*)

• It seems my original request are little sharp..
– yode
Mar 29 '16 at 6:30
• Could you draw the graph?
– user1722
Mar 29 '16 at 13:26
• @barrycarter !Mathematica graphics Mar 29 '16 at 13:36

One more method without graphs is by using IntegerPartition.

## Method in brief

For this particular problem there are 7 trips from start to end and let $t_1$ to $t_7$ represent those time. All $t_i \in \{1,3,6,8,12\}$.

Let $t_f$ be the total time. Then $t_f$ must partitions into 7 integers all of which belong to $\{1,3,6,8,12\}$.

If $t_f$ happens to be 30 then the result of

 IntegerPartitions[30, {7}, {1, 3, 6, 8, 12}]


including all its Permutations will contain the time of the successful journey. So the idea is to go over all permutations of these time and select only the ones which can fit the initial condition.

## Mathematica Part

split2Bytime[list_, time_] :=
Module[{p1, p2, p3, p4, flag = 1, trip, pos, onwardPart, returnPart},
onwardPart = list[[3]];
returnPart = Last@list;
Which[Not@MemberQ[onwardPart, First@time], flag = 0, True,
Which[First@time == First@onwardPart, flag = 0, True,
pos = Flatten@Position[onwardPart, First@time];
p2 = onwardPart[[First@pos - 1 ;; First@pos]];
p3 = Reverse@TakeDrop[onwardPart, {First@pos - 1, First@pos}];
p4 = PadRight[Last@p3, Length[Last@p3] + Length@returnPart, returnPart];
trip[1] = Join[{First@p3}, {p4}];
Which[Not@DuplicateFreeQ[time],
p3 = Reverse@TakeDrop[onwardPart, {First@pos - 1}];
p4 = PadRight[Last@p3, Length[Last@p3] + Length@returnPart,returnPart];
trip[2] = Join[{First@p3}, {p4}];, True,
Which[Not@MemberQ[Last@trip[1], Last@time], flag = 0, True,
p3 = Insert[First@trip[1], Last@time, 1];
p4 = DeleteCases[Last@trip[1], Last@time];
trip[2] = Join[{p3, p4}];]]
];
];

If[flag == 1, Flatten[Array[trip, 2], 1], "failed"]

];


The function split2Bytime takes the initial list and two time values and throws the allowed configuration based on that time.

For e.g.

split2Bytime[{{}, {}, {1, 3, 6, 8, 12}, {}}, {2, 3}]
(*failed*)


will return failed because the time argument i.e. {2,3} represents the time taken for the first and second trip. But the first trip cannot take 2 units with {{}, {}, {1, 3, 6, 8, 12}, {}} as the initial conflagration.

split2Bytime[{{}, {}, {1, 3, 6, 8, 12}, {}}, {3, 3}]
(*{{6, 8, 12}, {1, 3}, {3, 6, 8, 12}, {1}}*)


The above e.g. works because {3,3} is possible. The result is displayed as four sub-list where the first two part i.e. {6, 8, 12}, {1, 3} means {1,3} goes to the other side taking 3 seconds and the last two parts {3, 6, 8, 12}, {1} means that {3} comes back taking 3 seconds again.

splitAll[timings_] :=
Module[{flag = 1, last, trip, nlist = {{}, {}, {1, 3, 6, 8, 12}, {}}},
trip[1] = split2Bytime[nlist, timings[[1 ;; 2]]] // Quiet;
trip[2] = split2Bytime[trip[1], timings[[3 ;; 4]]] // Quiet;
trip[3] = split2Bytime[trip[2], timings[[5 ;; 6]]] // Quiet;
last = trip[3][[3]];
If[Not[Max@last == Last@timings] ||
Not[MemberQ[last, Last@timings]], flag = 0];
If[flag == 1, Array[trip, 3], "failed"]]


splitAll applies split2Bytime to all the timings 2 at a time and clubs them together at the end.

Now we can check for any total time $t_f$ whose integer partitions plus all its permutations satisfies splitAll.

check[n_] :=
Module[{sol, perms},
sol = IntegerPartitions[n, {7}, {1, 3, 6, 8, 12}];
perms =
Partition[
Flatten[Table[Permutations[sol[[i]]], {i, 1, Length[sol]}]], 7];
DeleteCases[
Table[If[
Not[ContainsAny[{splitAll[perms[[i]]]}, {"failed"}] ||
ContainsAny[splitAll[perms[[i]]], {"failed"}]], Sow[i]] //
Quiet, {i, 1, Length[perms]}], Null]]


check checks for all those Permutations which results in a failure. We can use it to see which ones are working. Lets check from 20 to 30

DeleteCases[Table[If[Not[check[n] == {}], Sow[n]], {n, 20, 30}], Null]
(*29*)


We get the correct total time $t_f=29$.

Now that we now $t_f=29$ we can display the full result of splitAll.

showResult[n_] :=
Module[{sol, result, perms, res, start = {{1, 3, 6, 8, 12}, {}}},
sol = IntegerPartitions[n, {7}, {1, 3, 6, 8, 12}];
perms =
Partition[
Flatten[Table[Permutations[sol[[i]]], {i, 1, Length[sol]}]], 7];
res = DeleteCases[
Table[If[
Not[ContainsAny[{splitAll[perms[[i]]]}, {"failed"}] ||
ContainsAny[splitAll[perms[[i]]], {"failed"}]], Sow[i]] //
Quiet, {i, 1, Length[perms]}], Null];
result[i_] :=
Partition[
Flatten[Append[Prepend[splitAll[perms[[res[[i]]]]], start],
Reverse@start], 1], 2];
Row[Table[Grid[result[i], Frame -> All], {i, 1, Length[res]}], " "]
]


As the help with many people in this post,I solve this proble with Graph Theory method.Build all possible in a graph based on the costed time on people:

time = {1, 3, 6, 8, 12};
people = StringReplace[ToString[time], " " -> ""];
seq[n_ /; n > 1] := Reverse[Riffle[Range[0, n - 2], Range[2, n]]]
Clear[exsited];
exsited[_] = False;
postfix =
Rest[If[exsited[#], StringJoin[ToString[#], ToString[Unique[]]],
exsited[#] = True; ""] & /@ seq[Length[time]]] //. {a___,
p : Except["", _String], "", b___} :> {a, p, p, b};
graphs = Function[{before, behind},
Graph[First[
WeaklyConnectedGraphComponents[
RelationGraph[
Equal[Length[#1], before] && Equal[Length[#2], behind] &&
SubsetQ @@ SortBy[{##}, -Length[#] &] &, Subsets[time]]]],
VertexLabels -> "Name", ImageSize -> 400]] @@@
Subsequences[seq[Length[time]], {2}];
Graph[graph =
GraphUnion @@
VertexReplace, {graphs,
Apply[If[
ToString[Length[#1]] === Quiet[First[StringSplit[#2, "$"]]], Rule[#1, StringReplace[StringJoin[{ToString[#1], #2}], " " -> ""]], Rule[#1, StringReplace[ToString[#1], " " -> ""]]] &, Tuples /@ Transpose[{VertexList /@ graphs, List /@ postfix}], {2}]}], VertexLabels -> Table[i -> First[StringSplit[i, RegularExpression["\\d+?\\$"]]], {i,
VertexList[graph]}], GraphLayout -> "LayeredDigraphEmbedding"]


### Find one possible shortest path in graph with FindShortestPath.

weighGraph =
Graph[EdgeList[graph],
EdgeWeight ->
Table[i ->
Quiet[Max[
Complement @@
SortBy[ToExpression[
First[StringSplit[#, RegularExpression["\\d+?\\$"]]]] & /@ List @@ i, -Length[#] &]]], {i, EdgeList[graph]}], EdgeLabels -> Placed["EdgeWeight", 1/4], VertexLabels -> "Name"]; path = FindShortestPath[weighGraph, people, "{}"]; HighlightGraph[graph, Subgraph[weighGraph, path], EdgeLabels -> (Rule @@@ Transpose[{#, Style[ToString[PropertyValue[{weighGraph, #}, EdgeWeight]], Bold, Medium, Darker@Green, 18] & /@ #} &@ EdgeList@Subgraph[weighGraph, path]]), VertexLabels -> Map[Rule[#, Style[StringReplace[ First[StringSplit[#, RegularExpression["\\d+?\\$"]]], {"{" ->
"", "}" -> ""}], Bold, Medium, Blue, 18]] &, path],
GraphHighlightStyle -> "Thick",
GraphLayout -> "LayeredDigraphEmbedding"]


As you can see,the cost time is $3 + 1 + 12 + 3 + 3 + 1 + 6=29(minute)$.

### Find all shortest path.

If we want to find all path,we can use FindPath to do it,and select that path shortest.

allPath =
MinimalBy[FindPath[weighGraph, people, "{}", Infinity, All],
Total[PropertyValue[{weighGraph, #}, EdgeWeight] & /@
EdgeList@Subgraph[weighGraph, #]] &];
HighlightGraph[graph, Subgraph[weighGraph, #],
EdgeLabels -> (Rule @@@
Transpose[{#,
Style[ToString[PropertyValue[{weighGraph, #}, EdgeWeight]],
Bold, Medium, Darker@Green, 18] & /@ #} &@
EdgeList@Subgraph[weighGraph, #]]),
VertexLabels ->
Map[Rule[#,
Placed[Style[
StringReplace[
First[StringSplit[#,
RegularExpression["\\d+?\\$"]]], {"{" -> "", "}" -> ""}], Bold, Medium, Blue, 18], Center]] &, #], GraphHighlightStyle -> "Thick", GraphLayout -> "LayeredDigraphEmbedding", ImageSize -> 320] & /@ allPath  As you can see,all the shortest path is$29(minute)\$j,and the green number is time of every step cost.