# How to divide the wine into two equal portions

There is a 8-liter bottle is full of wine. There are two empty bottles that have capacity 5-liters and 3-liters. How can these three bottles be used to separate the wine into two 4-liter portions?

This is my current method:

a = Range[0, 8];
b = Range[0, 5];
c = Range[0, 3];
list = Select[Tuples[{a, b, c}], Total[#] == 8 &];

SetAttributes[CirclePlus, HoldFirst]
CirclePlus[l_[[a_]], b_] :=
Module[{temp = l}, temp[[a]] = temp[[a]] + b; temp]

g = RelationGraph[
Or @@ Table[(#1[[1]]\[CirclePlus]-a)[[2]]\[CirclePlus]a === #2, {a,
5}] || Or @@
Table[(#1[[1]]\[CirclePlus]-a)[[3]]\[CirclePlus]a === #2, {a,
3}] || Or @@
Table[(#1[[2]]\[CirclePlus]-a)[[3]]\[CirclePlus]a === #2, {a,
3}] || Or @@
Table[(#1[[2]]\[CirclePlus]-a)[[1]]\[CirclePlus]a === #2, {a,
5}] || Or @@
Table[(#1[[3]]\[CirclePlus]-a)[[1]]\[CirclePlus]a === #2, {a,
3}] || Or @@
Table[(#1[[3]]\[CirclePlus]-a)[[2]]\[CirclePlus]a === #2, {a,
3}] &, list]


But I get a wrong answer.

FindShortestPath[g, {8, 0, 0}, {4, 4, 0}]


{{8, 0, 0}, {4, 4, 0}}

{8,0,0}->{3,5,0}->{3,2,3}->{6,2,0}->{6,0,2}->{1,5,2}->{1,4,3}->{4,4,0}

How can I use Mathematica to solve this problem?

-

list = Select[Tuples@Range[0, {8, 5, 3}], Total[#] == 8 &];

f[x_, y_] := Count[y ({8, 5, 3} - y) (x - y), 0] >= 2

sp = FindShortestPath[RelationGraph[f, list], {8, 0, 0}, {4, 4, 0}]
(* {{8, 0, 0}, {3, 5, 0}, {3, 2, 3}, {6, 2, 0}, {6, 0, 2}, {1, 5, 2}, {1, 4, 3}, {4, 4, 0}} *)


Explanation for f

• The transfer is from one bottle to one other, therefore the uninvolved bottle does not change - so $(y - x)$ must contain a zero for that bottle.

• The transfer must either empty the source bottle (in which case there is a zero in $y$) or fill the destination bottle (in which case there is a zero in $(\{8, 5, 3\} - y)$

• So overall the product $y(\{8, 5, 3\} - y) (y-x)$ must contain at least two zeros for a valid step.

Gratuitous animation

To make the animation I used the animation sequencing code from here and:

rules = MapThread[Thread[{a, b, c} -> Transpose@{#1, #2}] &,
{Most@sp, Rest@sp}] ~Riffle~ 0.5 ~Append~ 1;

grfx = {EdgeForm[Blue], FaceForm[],
Rectangle[{0, 0}, {1, 8}], Rectangle[{2, 0}, {3, 5}], Rectangle[{4, 0}, {5, 3}],
FaceForm[Red],
Rectangle[{0, 0}, {1, a}], Rectangle[{2, 0}, {3, b}], Rectangle[{4, 0}, {5, c}]};

{fn, tmax} = anim[grfx, rules];
Animate[Graphics[fn[t]], {t, 0, tmax}]

-
I cannot understand your f – yode Mar 28 at 10:17
@yode, I added some explanation – Simon Woods Mar 28 at 10:21
@SimonWoods Nice one (+1). Personally, I would have done JohnMcClane[{8, 5, 3}, {4, 4, 0}]. – Xavier Mar 28 at 10:32
@Xavier I think it would be ZeusCarver[...] or both :) – ubpdqn Mar 28 at 11:14
@iFikr I added the animation code. – Simon Woods Apr 3 at 19:54