# Solving a rotating combination lock puzzle

The following puzzle appears in The House of da Vinci II and I thought it might be interesting to tackle in Mathematica:

There are numbers marked on four rotating cylinders. These numbers must add up to the Roman numerals on the plate. I want an efficient way to solve these sorts of puzzles and I had a look at using ResourceFunction["BacktrackSearch"] but to make that work I'd need to list all rotations.

The puzzle requires the sums to appear in the right order (allowing looping around). There should be some values rotations = {r1,r2,r3,r4} that rotate each cylinder into the correct position.

cylinders = {
{4, 1, 1, 1, 3, 1},
{3, 1, 1, 1, 2, 1},
{1, 2, 2, 4, 1, 3},
{3, 2, 1, 2, 3, 1}
};

sums = FromRomanNumeral[{"XI", "V", "X", "IV", "IX", "VI"}];


I can solve this by brute force:

test[rotations_] :=
Total[MapThread[RotateRight[#1, #2] &, {cylinders, rotations}]] == sums

Select[Tuples[Range[0, 5], {4}], test]
(* {{0, 2, 3, 4}} *)


Is there a more efficient method that doesn't involving filtering from a big list of tuples? I'm aware that for this particular instance it's fast, but this technique does not scale well to larger problems.

• I would search for configurations that add to IV as these are the most restrictive. (Must be 1,1,1,1, thus given just two alternatives for rings $3$ and $4$.) Next I'd ensure the sum of VI as these are the next-most restrictive, which involves only two rings, etc. This will cut down the search immensely. Sep 25, 2020 at 18:32

I'd implement backtracking like this:

cylinders = {{4, 1, 1, 1, 3, 1}, {3, 1, 1, 1, 2, 1}, {1, 2, 2, 4, 1, 3}, {3, 2, 1, 2, 3, 1}};
sums = FromRomanNumeral[{"XI", "V", "X", "IV", "IX", "VI"}];

bt[rotations_] := If[
Length[rotations] == 4,
If[evaluate[rotations] == sums, Throw[rotations]],
If[
! impossible[rotations],
bt[Append[rotations, #]] & /@ Range[0, 5]
]
]

evaluate[rotations_, l_ : All] := Total@MapThread[
RotateRight,
{Take[cylinders, l], rotations}
]

impossible[rotations_] := AnyTrue[
sums - evaluate[rotations, Length[rotations]],
# < 0 &
]

bt[{0}] // Catch


{0, 2, 3, 4}

The more ways you can come up with to exclude series of rotations that you know cannot occur, the better it will perform. In this case I used sums - evaluate[rotations, Length[rotations]] to rule out solutions. However, it is possible to restrict the solutions even more by using sums - evaluate[rotations, Length[rotations]] - (4 - Length[rotations]) because the smallest value a cylinder can have is 1.

• Great! The Select version takes 1296 tests, this one takes just 73 evaluations + 20 calls to impossible which is pretty good. Sep 25, 2020 at 23:38

Here is another approach. Use Solve to find the 129 solutions without considerations for the order of elements in a cylinder. Then, check these solutions and keep the one consistent with rotation of the given order.

Clear[a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6, c1, c2, c3, c4,
c5, c6, d1, d2, d3, d4, d5, d6];

cylinders = {{4, 1, 1, 1, 3, 1}, {3, 1, 1, 1, 2, 1}, {1, 2, 2, 4, 1,
3}, {3, 2, 1, 2, 3, 1}};
sums = FromRomanNumeral[{"XI", "V", "X", "IV", "IX", "VI"}];

(* function takes two lists and returns True if equivalent by \
rotation *)
isRotation[cyl_List, sol_List] := (
double = Flatten[Append[cyl, cyl]];
seq = SequenceCases[double, sol];
If[seq == {}, False, True]
)

(* To name variables to solve for,the four cylinders are assigned a \
letter a to d. Each of the six values for a cylinder is assigned a \
number from 1 to 6. This gives 129 solutions. *)

mySolution =
Solve[a1 + b1 + c1 + d1 == sums[[1]] &&

a2 + b2 + c2 + d2 == sums[[2]] &&

a3 + b3 + c3 + d3 == sums[[3]] &&

a4 + b4 + c4 + d4 == sums[[4]] &&

a5 + b5 + c5 + d5 == sums[[5]] &&

a6 + b6 + c6 + d6 == sums[[6]] &&

a1 + a2 + a3 + a4 + a5 + a6 == Total[cylinders[[1]]] &&

b1 + b2 + b3 + b4 + b5 + b6 == Total[cylinders[[2]]] &&

c1 + c2 + c3 + c4 + c5 + c6 == Total[cylinders[[3]]] &&

d1 + d2 + d3 + d4 + d5 + d6 == Total[cylinders[[4]]] &&

5 > a1 > 0 && 5 > a2 > 0 && 5 > a3 > 0 && 5 > a4 > 0 &&
5 > a5 > 0 && 5 > a6 > 0 &&
5 > b1 > 0 && 5 > b2 > 0 &&
5 > b3 > 0 && 5 > b4 > 0 && 5 > b5 > 0 && 5 > b6 > 0 &&

5 > c1 > 0 && 5 > c2 > 0 && 5 > c3 > 0 && 5 > c4 > 0 &&
5 > c5 > 0 && 5 > c6 > 0 &&
5 > d1 > 0 && 5 > d2 > 0 &&
5 > d3 > 0 && 5 > d4 > 0 && 5 > d5 > 0 && 5 > d6 > 0 &&

a1 a2 a3 a4 a5 a6 == Times @@ cylinders[[1]] &&

b1 b2 b3 b4 b5 b6 == Times @@ cylinders[[2]] &&

c1 c2 c3 c4 c5 c6 == Times @@ cylinders[[3]] &&

d1 d2 d3 d4 d5 d6 == Times @@ cylinders[[4]],

{a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6, c1, c2, c3, c4,
c5, c6, d1, d2, d3, d4, d5, d6}, Integers
];

(* Go through the solutions and select the one consistent with \
cylinder rotation *)
n = 1;
While[n <= Length[mySolution],
truthValues = {};
v = Values[mySolution[[n]]];
parts = Partition[v, 6];
i = 1;
While[i <= Length[parts],
truthValues =
Append[truthValues, isRotation[cylinders[[i]], parts[[i]]]];
i++;
];
If[truthValues == {True, True, True, True},
Print[Column[Partition[Values[mySolution[[n]]], 6]]]
];

n++;
]

(* ==== SOLUTION ==== *)
{4,1,1,1,3,1}
{2,1,3,1,1,1}
{4,1,3,1,2,2}
{1,2,3,1,3,2}$$$$


Using the comment by Mr. David G. Stork as a guide:

cylinders = {{4, 1, 1, 1, 3, 1}, {3, 1, 1, 1, 2, 1}, {1, 2, 2, 4, 1,
3}, {3, 2, 1, 2, 3, 1}};
sums = FromRomanNumeral[{"XI", "V", "X", "IV", "IX", "VI"}]


{11, 5, 10, 4, 9, 6}

Consider the integer partitions of the entries in the sums.

iparts = IntegerPartitions[#, {4}, Range @@ MinMax[cylinders]] & /@
sums // Grid


All rotated positions:

combs = Table[RotateRight[#, i], {i, 0, Length@# - 1}] & /@ cylinders


The filtered possibilities can be computed where the fourth position is always all 1s and the second position can have 1s or 2s:

t = (combs // DeleteCases[#, {_, _, _, Except[1], _, _}, {2}] & //
DeleteCases[#, {_, Except[1 | 2], _, _, _, _}, {2}] &
)


{{{4, 1, 1, 1, 3, 1}, {3, 1, 4, 1, 1, 1}, {1, 1, 3, 1, 4, 1}}, {{3, 1, 1, 1, 2, 1}, {2, 1, 3, 1, 1, 1}, {1, 1, 2, 1, 3, 1}}, {{4, 1, 3, 1, 2, 2}, {2, 2, 4, 1, 3, 1}}, {{1, 2, 3, 1, 3, 2}}}

{Length /@ t, Times @@ Length /@ t}


{{3, 3, 2, 1}, 18}

Hence the search has been cut down to 18 possibilities only.

pos = First@Position[Outer[Plus, Sequence @@ t, 1], sums]
res = Outer[List, Sequence @@ t, 1][[Sequence @@ pos]]


{{4, 1, 1, 1, 3, 1}, {2, 1, 3, 1, 1, 1}, {4, 1, 3, 1, 2, 2}, {1, 2, 3, 1, 3, 2}}

MapThread[Position[#1, #2] &, {combs, res}] - 1 // Flatten
`

{0, 2, 3, 4}