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

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.

• does this help in any way: Sort/@Select[DuplicateFreeQ]@IntegerPartitions[33, {4}, {1, 2, 3, 4, 6, 7, 8, 9, 10, 13, 14, 15}]
– kglr
Jul 1, 2018 at 14:52
• @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. Jul 1, 2018 at 16:44
• @ChenStatsYu Please review my edit of the question. Jul 1, 2018 at 20:36
• @AntonAntonov Thanks. I have also added a bit background information to this. Jul 1, 2018 at 23:03
• @ChenStatsYu Great, very nice! Jul 1, 2018 at 23:20

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



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]


• Your solutions contains the cases where five (repeated ones) numbers were used? Jul 1, 2018 at 16:51
• 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. Jul 1, 2018 at 23:13
• @ChenStatsYu, so realanswers = Table[RandomSample[domain, 4], 28]? :)
– kglr
Jul 1, 2018 at 23:19
• 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. Jul 1, 2018 at 23:20
• blog.sagradafamilia.org/en/divulgation/… Jul 1, 2018 at 23:24
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.