Mathematica Stack Exchange is a question and answer site for users of Mathematica. Join them; it only takes a minute:

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

puzzle

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.

share|improve this question
    
I'm not a chinese btw.. I'm just guessing from the '1-9' and the the nine empty boxes.. :) – iFikr Feb 20 at 14:26
1  
Similar topic – garej Feb 20 at 18:53
up vote 19 down vote accepted

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.

share|improve this answer

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}}
share|improve this answer
1  
You could use g = FromDigits @ {#1, #2 } & and make it g[ #1, #2 ] #3 ... for readability maybe? – gwr Feb 20 at 14:53
2  
@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 ) – xzczd Feb 20 at 15:11
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。

好玩吧

share|improve this answer

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}

share|improve this answer

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]]
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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