3
$\begingroup$

Update

Finally got the background origin of this. And a more comprehensive article is here. This has has a total of 310 combinations that add up to 33.

And this IS more interesting way of highlighting. enter image description here

OP

Saw this math puzzle on Twitter, which asks with the given magic square to find 33 different ways of adding 4 of its cells to 33.

enter image description here

I tried to use Solve

Solve[x1 + x2 + x3 + x4 == 33 && x1 < x2 < x3 < x4, {x1, x2, x3, x4}, { x1, x2, x3, x4} ∈ {1, 2, 3, 4, 6, 7, 8, 9, 10, 13, 14, 15}]


Solve[x1 + x2 + x3 + x4 == 33 && x1 < x2 < x3 < x4, {
  x1 ∈ {1, 2, 3, 4, 6, 7, 8, 9, 10, 13, 14, 15},
  x2 ∈ {1, 2, 3, 4, 6, 7, 8, 9, 10, 13, 14, 15},
  x3 ∈ {1, 2, 3, 4, 6, 7, 8, 9, 10, 13, 14, 15},
  x4 ∈ {1, 2, 3, 4, 6, 7, 8, 9, 10, 13, 14, 15}
  }
 ]

Neither worked.

2nd problem is how to use the solutions to highlight it like in the graph? Should be easy after we obtain all solutions. Something like

m = {
  {1, 14, 14, 4},
  {11, 7, 6, 9},
  {8, 10, 10, 5},
  {13, 2, 3, 15}
  }

Grid[m /. {"answers"}, Frame -> All]

Thanks.

$\endgroup$
7
  • 1
    $\begingroup$ does this help in any way: Sort/@Select[DuplicateFreeQ]@IntegerPartitions[33, {4}, {1, 2, 3, 4, 6, 7, 8, 9, 10, 13, 14, 15}] $\endgroup$
    – kglr
    Jul 1, 2018 at 14:52
  • $\begingroup$ @AntonAntonov Sorry. I saw this last night just before I went to bed. It's meant to be a maths puzzle, where the magic square has 33 different ways of adding 4 numbers to 33. Couldn't find the OP now. $\endgroup$ Jul 1, 2018 at 16:44
  • $\begingroup$ @ChenStatsYu Please review my edit of the question. $\endgroup$ Jul 1, 2018 at 20:36
  • $\begingroup$ @AntonAntonov Thanks. I have also added a bit background information to this. $\endgroup$ Jul 1, 2018 at 23:03
  • $\begingroup$ @ChenStatsYu Great, very nice! $\endgroup$ Jul 1, 2018 at 23:20

2 Answers 2

4
$\begingroup$
domain = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 14, 15};

Pick + Subsets

answers1 = Pick[s = Subsets[domain, {4}], s.{1,1,1,1}, 33];

IntegerPartitions

answers2 = Sort/@Select[DuplicateFreeQ]@IntegerPartitions[33, {4}, domain]

Solve

xx = Array[x, {14}];
answers3 = DeleteCases[#, 0, 2] &[domain  xx /. 
  Solve[{33 == xx.domain, Total[xx] == 4, ## & @@ Thread[0 <= xx <= 1]}, xx, Integers]]

Reduce

answers4 = DeleteCases[#, 0, 2] &[domain xx /. List[ToRules @ 
  Reduce[{xx. domain == 33, Total[xx] == 4, ## & @@ Thread[0 <= xx <= 1]},  xx, Integers]]

FrobeniusSolve

answers5 = DeleteCases[domain # & /@ 
    Select[FrobeniusSolve[domain, 33], Max[#] == 1 && Total[#] == 4 &], 0, 2] ;


Sort@answers1 == Sort@answers2 == Sort@answers3 == Sort@answers4 == Sort@answers5

True

Highlighting

img = Import["https://i.stack.imgur.com/O55Kb.png"]

enter image description here

Grid @ Partition[ImageMultiply[img, 
   MatrixPlot[m , DataReversed -> False,Frame -> True, Mesh -> All, 
     FrameTicks -> None, ImageSize -> 1 -> 10, 
     ColorRules -> { ## & @@ Map[# -> Orange &, #, {-1}], _ :>  White}]] & /@ answers1, 8]

enter image description here

Grid @ Partition[Grid[m /. Map[# -> Item[#, Background -> Orange] &, #, {-1}], 
     Dividers -> All] & /@ answers1, 8]

enter image description here

Update: Highlighting only 4 elements (ignoring one of the duplicate elements):

Grid @ Partition[ImageMultiply[img, 
  MatrixPlot[MapAt[Orange &, m, Position[m, #, 2, 1][[1]] & /@ #] ,
    DataReversed -> False, Frame -> True, Mesh -> All, 
    FrameTicks -> None, ImageSize -> 1 -> 10, 
    ColorRules -> { _ :> White}]] & /@ answers1, 8]

enter image description here

$\endgroup$
9
  • $\begingroup$ Your solutions contains the cases where five (repeated ones) numbers were used? $\endgroup$ Jul 1, 2018 at 16:51
  • $\begingroup$ Thanks. I had added a bit background to this now. It does not seem to be "magic" to be at all. To start with, MMA found many more solutions then the given solutions. Secondly, the numbers in the matrix does not follow any pattern. It's just some "random" combinations. $\endgroup$ Jul 1, 2018 at 23:13
  • $\begingroup$ @ChenStatsYu, so realanswers = Table[RandomSample[domain, 4], 28]? :) $\endgroup$
    – kglr
    Jul 1, 2018 at 23:19
  • $\begingroup$ I have no idea, see my updated post with the new image. I am just doing background reading on this now, to see what's so special about it. $\endgroup$ Jul 1, 2018 at 23:20
  • $\begingroup$ blog.sagradafamilia.org/en/divulgation/… $\endgroup$ Jul 1, 2018 at 23:24
3
$\begingroup$
m = {{1, 14, 14, 4}, {11, 7, 6, 9}, {8, 10, 10, 5}, {13, 2, 3, 15}};
Sort@DeleteDuplicates@Flatten@m

{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 14, 15}

To find the solutions:

sol = Sort /@ Select[#, DuplicateFreeQ[#] &] & @
        IntegerPartitions[33, {4}, Sort@DeleteDuplicates@Flatten@m];
Length@sol

48

(or with kglr's Sort/@Select[DuplicateFreeQ]@IntegerPartitions[33, {4}, {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 14, 15}]

and then

Grid@Partition[MatrixForm[m /. (# -> Highlighted[#] & /@ #)] & /@ sol, 6, 6]

enter image description here

10 and 14 appear twice in m. To neglect one of them in Highlighting, I employ a rather crude approach of changing one of the 10s and 14s to 10. and 14., Highlighting and the Rationalizeing:

pos10 = Position[m, 10]
pos14 = Position[m, 14]
m2 = ReplacePart[m, {pos10[[1]] -> 10., pos14[[1]] -> 14.}];

so for example

MatrixForm[m2 /. (# -> Highlighted[#] & /@ sol[[1]])]

enter image description here

Hence

Grid@Partition[MatrixForm[Rationalize[m2 /. (# -> Highlighted[#] & /@ #)]] & /@ sol, 6, 6]

enter image description here

Changing the Parts in m2 one can obtain the Highlightings for the other three cases.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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