18
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ I'm not a chinese btw.. I'm just guessing from the '1-9' and the the nine empty boxes.. :) $\endgroup$ – iFikr Feb 20 '16 at 14:26
  • 1
    $\begingroup$ Similar topic $\endgroup$ – garej Feb 20 '16 at 18:53
  • $\begingroup$ 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. $\endgroup$ – Jawad_Mansoor Feb 23 '17 at 18:09
23
$\begingroup$

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.

$\endgroup$
13
$\begingroup$

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}}
$\endgroup$
  • 1
    $\begingroup$ You could use g = FromDigits @ {#1, #2 } & and make it g[ #1, #2 ] #3 ... for readability maybe? $\endgroup$ – gwr Feb 20 '16 at 14:53
  • 2
    $\begingroup$ @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 ) $\endgroup$ – xzczd Feb 20 '16 at 15:11
10
$\begingroup$

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}

$\endgroup$
9
$\begingroup$
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。

好玩吧

$\endgroup$
4
$\begingroup$

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]]
$\endgroup$
0
$\begingroup$

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}}}}
$\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.