Finding sums of magic square cells (The “magic square” of the Sagrada Familia)

Question

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.

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.

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.

Answer 1

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

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

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

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]

Answer 2

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]

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

Hence

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

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