Puzzle with Mathematica

Question

Hello everyone, This is a puzzle I got from someone via social media. Basically, we need to fill up the boxes with the numbers 1-9 (no repetitions) that fit the multiplication and addition operations.

I managed to solve this puzzle by using a brute force method in Excel+VBA. However, it would be very interesting if it can be solved in Mathematica with its specialty as computational software. Any idea will be appreciated.

Thanks.

Answer 1

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.

Answer 2

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}}

Answer 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}

Answer 4

Range[9] // Permutations // 
  Select[(10 #[[1]] + #[[2]])*#[[3]] == 10 #[[4]] + #[[5]] &] // 
 SelectFirst[
  10 #[[4]] + #[[5]] + 10 #[[6]] + #[[7]] == 10 #[[8]] + #[[9]] &]

So,17*4=68；68+25=93。

好玩吧

Answer 5

A relatively fast one (ugly though)

Module[{x = Permutations@Range@9, y},
 y = Pick[x, 
  (10 x[[All, 1]] + x[[All, 2]]) x[[All, 3]] - 10 x[[All, 4]] - x[[All, 5]], 0];
 Pick[y,
   10 y[[All, 4]] + y[[All, 5]] + 10 y[[All, 6]] + y[[All, 7]] - 10 y[[All, 8]] - y[[All, 9]], 0]]

Answer 6

Ugly but just wanted to play:

a = Range[9];
can = {#, Complement[a, #]} & /@ 
   Select[{##}~Join~IntegerDigits[(10 #1 + #2) #3] & @@@ 
     Select[Permutations[
       a, {3}], (10 #[[1]] + #[[2]]) #[[3]] < 100 &], 
    Length[#] == Length[Union[#]] && FreeQ[#, 0] &];
fun[a_, b_] := Module[{perm = Permutations[b], res},
  res = a[[4 ;; 5]].{10, 1} + #[[1 ;; 2]].{10, 1} == #[[3 ;; 4]].{10, 
        1} & /@ perm;
  {a, Pick[perm, res]}
  ]
DeleteCases[fun @@@ can, {_, {}}]

yields:

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