9
$\begingroup$

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

combination lock

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.

$\endgroup$
  • 3
    $\begingroup$ 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. $\endgroup$ – David G. Stork Sep 25 at 18:32
8
$\begingroup$

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.

| improve this answer | |
$\endgroup$
  • 1
    $\begingroup$ Great! The Select version takes 1296 tests, this one takes just 73 evaluations + 20 calls to impossible which is pretty good. $\endgroup$ – flinty Sep 25 at 23:38
4
$\begingroup$

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}```
| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.