Puzzle with Mathematica

18

12

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.

iFikr

Posted 2016-02-20T14:04:28.547

Reputation: 347

I'm not a chinese btw.. I'm just guessing from the '1-9' and the the nine empty boxes.. :) – iFikr – 2016-02-20T14:26:29.640

1

Similar topic

– garej – 2016-02-20T18:53:13.620

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. – Jawad_Mansoor – 2017-02-23T18:09:31.240

Answers

23

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.

unlikely

Posted 2016-02-20T14:04:28.547

Reputation: 6 755

14

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

xzczd

Posted 2016-02-20T14:04:28.547

Reputation: 44 878

1You could use g = FromDigits @ {#1, #2 } & and make it g[ #1, #2 ] #3 ... for readability maybe? – gwr – 2016-02-20T14:53:52.583

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 – 2016-02-20T15:11:16.760

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}

gwr

Posted 2016-02-20T14:04:28.547

Reputation: 11 083

9

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。

好玩吧

xiang

Posted 2016-02-20T14:04:28.547

Reputation: 356

4

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

Simon Woods

Posted 2016-02-20T14:04:28.547

Reputation: 81 905

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

ubpdqn

Posted 2016-02-20T14:04:28.547

Reputation: 53 491