Puzzle with Mathematica

A non brute-force approach is the following, similar to my answer for the Zebra Puzzle.

Both puzzles are examples of constrainst satisfaction problems, that can be solved with Reduce/Minimize/Maximize or, more efficiently, with LinearProgramming.

The good about this approach is that you can easily extend and apply to many similar problems.

The common part:

  • Assign an index $i$ to each box from top left, $i=1,2,\ldots,9$.
  • In each box you should put a digit $k$, $k=1,\ldots,9$.
  • Assign an index $l$ to the whole number/row, $l=1,\ldots,5$.
  • the variable x[i,k] is $1$ if there is the digit $k$ in the cell $i$ and $0$ otherwise.
  • d[i] is the digit in cell $i$.
  • n[l] is the whole number in the row $l$ (one or two cell).

The easier and slower approach is with Maximize. Build constraints and pass to Maximize with a constant objective function, so Maximize will try only to satisfy constraints. Constraints are:

  • n[1] * n[2] == n[3]
  • n[3] + n[4] == n[5]
  • each cell should be filled with exactly one digit
  • each digit should be placed in exactly one cell
  • 0 <= x[i,k] <= 1, x[i,k] \elem Integers

That's all.

d[i_] := Sum[x[i, k] k, {k, 9}]
n[l_] := FromDigits[d /@ {{1, 2}, {3}, {4, 5}, {6, 7}, {8, 9}}[[l]]]

solution = Last@Maximize[{0, {
      n[1]*n[2] == n[3],
      n[3] + n[4] == n[5],
      Table[Sum[x[i, k], {k, 9}] == 1, {i, 9}],
      Table[Sum[x[i, k], {i, 9}] == 1, {k, 9}],
      Thread[0 <= Flatten@Array[x, {9, 9}] <= 1]}},
    Flatten@Array[x, {9, 9}], Integers];

Array[n, 5] /. solution

{17, 4, 68, 25, 93}

Not fast (not linear).

A faster approach is to use LinearProgramming, but you need to:

  • change the first constraint so that it become linear
  • manually build matrix and vectors input for LinearProgramming (see docs)

The next piece of code do that. Please note that the single non-linear constraint n[1]*n[2] == n[3] has been replaced with 18 linear "conditional" constraints.

d[i_] := Sum[x[i, k] k, {k, 9}]
n[l_] := FromDigits[d /@ {{1, 2}, {3}, {4, 5}, {6, 7}, {8, 9}}[[l]]]

vars = Flatten@Array[x, {9, 9}];

constraints = Flatten@{
    Table[{
      k n[1] >= n[3] - 75 (1 - x[3, k]),
      k n[1] <= n[3] + 859 (1 - x[3, k])
      }, {k, 9}],
    n[3] + n[4] == n[5],
    Table[Sum[x[i, k], {k, 9}] == 1, {i, 9}],
    Table[Sum[x[i, k], {i, 9}] == 1, {k, 9}]};

bm = CoefficientArrays[Equal @@@ constraints, vars];
solution = LinearProgramming[
   Table[0, Length@vars],
   bm[[2]],
   Transpose@{-bm[[1]], 
     constraints[[All, 0]] /. {LessEqual -> -1, Equal -> 0, 
       GreaterEqual -> 1}},
   Table[{0, 1}, Length@vars],
   Integers
   ];

Array[n, 5] /. Thread[vars -> solution]

{17, 4, 68, 25, 93}

The execution is now about instantaneous.


Can't think out a better method than brute force, it'll be conciser in Mathematica of course:

g = 10 # + #2 &;
Pick[#, g[#, #2] #3 == g[#4, #5] == g[#8, #9] - g[#6, #7] & @@@ #] &@Permutations@Range@9

{{1, 7, 4, 6, 8, 2, 5, 9, 3}}

To make the brute force solution a bit more pleasant for the eye of the observer:

testFunc = And[
   FromDigits @ {#1, #2} #3 == FromDigits @ {#4, #5},
   FromDigits @ {#4, #5} + FromDigits @ {#6, #7} == FromDigits @ {#8, #9}
]& ;

sol = Range[9] // RightComposition[

    Permutations,
    SelectFirst[ testFunc @@ # & ]

]

{1, 7, 4, 6, 8, 2, 5, 9, 3}

Tags:

Puzzle

Arithmetic

Recent Posts