# Puzzle with Mathematica

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.

• I'm not a chinese btw.. I'm just guessing from the '1-9' and the the nine empty boxes.. :) Commented Feb 20, 2016 at 14:26
• Similar topic Commented Feb 20, 2016 at 18:53
• I need serious help regarding Mathematica. I am learning it as recreational tool (plus it helps me in financial modeling) that is why I'm interested in puzzles being solved in Mathematica because I can learn more easily the language. However I did not understand anything happening above, except for part of @xiang 's reply as it contained the operations (x,+ and -) but nothing more. Where can I learn the language to be able to formulate solutions like I have seen above. Thank you. Commented Feb 23, 2017 at 18:09

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

• You could use g = FromDigits @ {#1, #2 } & and make it g[ #1, #2 ] #3 ... for readability maybe?
– gwr
Commented Feb 20, 2016 at 14:53
• @gwr I was just trying to make the code as concise as possible. ( Since I failed to think out a better method, I decided to make the answer distinctive in some way :D ) Commented Feb 20, 2016 at 15:11

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}

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。

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


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