# Solving puzzle with sum

My dad really likes to play this kind of puzzle. And I've tried to help you get the values to my level of knowledge.

The puzzle looks like this:

The rule is to use numbers from 1 to 9, but it is not allowed to have repeated numbers in the same sum.

This prohibition I failed to create a logic to get the values.

So to figure out the values I had to go testing values visually.

Code:

Clear["Global*"]


Empty boxes

a5 = ■; a6 = ■; b5 = ■; b6 = ■; c4 = ■; c5 = ■; c6 = ■; d1 = ■; e3 = ■; e6 = ■; f2 = ■; g4 = ■;


Defined values

e1 = 7; e2 = 9; g2 = 2; a4 = 1; b4 = 3; d6 = 5; f1 = 9;


Solution

Solve[
a1 + a2 + a3 + a4 == 13 &&
b1 + b2 + b3 + b4 == 16 &&
c1 + c2 + c3 == 14 &&
d2 + d3 + d4 + d5 + d6 == 18 &&
e4 + e5 == 12 &&
f3 + f4 + f5 + f6 == 14 &&
g1 + g2 + g3 == 15 &&
g5 + g6 == 14 &&
a1 + b1 + c1 == 13 &&
a2 + b2 + c2 + d2 + e2 == 32 &&
a3 + b3 + c3 + d3 == 11 &&
e1 + f1 + g1 == 24 &&
f3 + g3 == 11 &&
d4 + e4 + f4 == 16 &&
d5 + e5 + f5 + g5 == 11 &&
f6 + g6 == 12,
{a1, a2, a3, b1, b2, b3, c1, c2, c3, d2, d3, d4, d5, e4, e5, g1,
g3, g5, g6, f3, f4, f5, f6}
] /. Rule -> Set;


Manual attempt

g5 = 5; d4 = 3; e4 = 9; a1 = 7; b1 = 5; a2 = 2; b2 = 6; c2 = 8;


Matrix

{
{a1, b1, c1, d1, e1, f1, g1},
{a2, b2, c2, d2, e2, f2, g2},
{a3, b3, c3, d3, e3, f3, g3},
{a4, b4, c4, d4, e4, f4, g4},
{a5, b5, c5, d5, e5, f5, g5},
{a6, b6, c6, d6, e6, f6, g6}
}


$\left( \begin{array}{ccccccc} 7 & 5 & 1 & \blacksquare & 7 & 9 & 8 \\ 2 & 6 & 8 & 7 & 9 & \blacksquare & 2 \\ 3 & 2 & 5 & 1 & \blacksquare & 6 & 5 \\ 1 & 3 & \blacksquare & 3 & 9 & 4 & \blacksquare \\ \blacksquare & \blacksquare & \blacksquare & 2 & 3 & 1 & 5 \\ \blacksquare & \blacksquare & \blacksquare & 5 & \blacksquare & 3 & 9 \\ \end{array} \right)$

The result is as follows:

EDIT

I'm trying to create the game board using Feyre solution. It would be more or less like this?

linhas = 7; colunas = 9;
LH = {{0, #}, {colunas, #}} & /@ Range[0, linhas];
LV = {{#, 0}, {#, linhas}} & /@ Range[0, colunas];
LO = {
{{0.5, 2}, {0.5, 6}},
{{3.5, 0}, {3.5, 3}},
{{5.5, 0}, {5.5, 1}},
{{8.5, 3}, {8.5, 6}},
{{1, 6.5}, {4, 6.5}},
{{5, 6.5}, {8, 6.5}},
{{4, 5.5}, {5, 5.5}},
{{6, 4.5}, {7, 4.5}},
{{5, 3.5}, {6, 3.5}},
{{7, 2.5}, {8, 2.5}}
};

pAlist = {1.5, # + .5} & /@ Reverse[Range[0, 5]];
pBlist = {2.5, # + .5} & /@ Reverse[Range[0, 5]];
pClist = {3.5, # + .5} & /@ Reverse[Range[0, 5]];
pDlist = {4.5, # + .5} & /@ Reverse[Range[0, 5]];
pElist = {5.5, # + .5} & /@ Reverse[Range[0, 5]];
pFlist = {6.5, # + .5} & /@ Reverse[Range[0, 5]];
pGlist = {7.5, # + .5} & /@ Reverse[Range[0, 5]];
For[i = 1, i <= 6, i++,
ToExpression["pA" <> ToString[i] <> "=" <> ToString[pAlist[[i]]]]];
For[i = 1, i <= 6, i++,
ToExpression["pB" <> ToString[i] <> "=" <> ToString[pBlist[[i]]]]];
For[i = 1, i <= 6, i++,
ToExpression["pC" <> ToString[i] <> "=" <> ToString[pClist[[i]]]]];
For[i = 1, i <= 6, i++,
ToExpression["pD" <> ToString[i] <> "=" <> ToString[pDlist[[i]]]]];
For[i = 1, i <= 6, i++,
ToExpression["pE" <> ToString[i] <> "=" <> ToString[pElist[[i]]]]];
For[i = 1, i <= 6, i++,
ToExpression["pF" <> ToString[i] <> "=" <> ToString[pFlist[[i]]]]];
For[i = 1, i <= 6, i++,
ToExpression["pG" <> ToString[i] <> "=" <> ToString[pGlist[[i]]]]];

textHold = {
Text[e1, pE1],
Text[e2, pE2],
Text[g2, pG2],
Text[a4, pA4],
Text[b4, pB4],
Text[d6, pD6],
Text[f1, pF1]
};

value = ToExpression["s2[[1," <> ToString[#] <> "]]"] & /@ Range[23];
pos = {pA1, pA2, pA3, pB1, pB2, pB3, pC1, pC2, pC3, pD2, pD3, pD4,
pD5, pE4, pE5, pG1, pG3, pG5, pG6, pF3, pF4, pF5, pF6};

Graphics[{Map[Line, Join[LH, LV]], Dashed, Map[Line, LO],
FontSize -> 20, textResp, Red, textHold}]


• I have identified two solutions, can you check they're both correct? My second one is the one you had. Commented Jan 26, 2017 at 13:49
• What is the question? To find concrete solutions, to give a method to find solutions for the general problem, or to make a convenient interface (board) for the puzzle? Commented Jan 27, 2017 at 19:30
• @AntonAntonov I've already had an answer on how to get the solution, but I'm also interested in suggestions for a similar puzzle with the image. I think the lines I made were unprofessional. Commented Jan 27, 2017 at 19:41

We can set a range limitation and define integers as the domain, however, if we use all restrictions, Solve[] just hangs. It is best to get all possible solutions first, then restrict them.

eqs = Flatten@{1 + a1 + a2 + a3 == 13, 3 + b1 + b2 + b3 == 16,
c1 + c2 + c3 == 14, 5 + d2 + d3 + d4 + d5 == 18, e4 + e5 == 12,
f3 + f4 + f5 + f6 == 14, 2 + g1 + g3 == 15, g5 + g6 == 14,
a1 + b1 + c1 == 13, 9 + a2 + b2 + c2 + d2 == 32,
a3 + b3 + c3 + d3 == 11, 16 + g1 == 24, f3 + g3 == 11,
d4 + e4 + f4 == 16, d5 + e5 + f5 + g5 == 11, f6 + g6 == 12,
vars = {a1, a2, a3, b1, b2, b3, c1, c2, c3, d2, d3, d4, d5, e4, e5,
g1, g3, g5, g6, f3, f4, f5, f6};
a5 = ■; a6 = ■; b5 = ■; b6 = ■; c4 = ■; c5 = ■; c6 = ■; d1 = ■; e3 = ■; e6 = ■; f2 = ■; g4 = ■;


Solve:

s = Solve[eqs, vars, Integers];
Length@s


16756

Now select for those that don't have repeat integers, there seem to be two solutions:

s2 = Select[
vars /. s, #[[1]] != #[[2]] != #[[3]] !=
1 && #[[4]] != #[[5]] != #[[6]] !=
3 && #[[7]] != #[[8]] != #[[9]] && #[[10]] != #[[11]] !=
#[[12]] != #[[13]] !=
5 && #[[14]] != #[[15]] && #[[20]] != #[[21]] != #[[22]] !=
#[[23]] && #[[16]] != #[[17]] !=
2 && #[[18]] != #[[19]] && #[[1]] != #[[4]] != #[[7]] &&
#[[2]] != #[[5]] != #[[8]] != #[[10]] !=
9 && #[[3]] != #[[6]] != #[[9]] != #[[11]] &&
7 != 9 != #[[16]] && #[[20]] != #[[17]] && #[[12]] != #[[14]]
!= #[[21]] && #[[13]] != #[[15]] != #[[22]] != #[[18]] &];
Length@s2


2

{{a1, b1, c1, d1, 7, 9, g1}, {a2, b2, c2, d2, 9, f2, 2}, {a3, b3,
c3, d3, e3, f3, g3}, {1, 3, c4, d4, e4, f4, g4}, {a5, b5, c5,
d5, e5, f5, g5}, {a6, b6, c6, 5, e6, f6, g6}} /.


{{a1, b1, c1, d1, 7, 9, g1}, {a2, b2, c2, d2, 9, f2, 2}, {a3, b3,
c3, d3, e3, f3, g3}, {1, 3, c4, d4, e4, f4, g4}, {a5, b5, c5,
d5, e5, f5, g5}, {a6, b6, c6, 5, e6, f6, g6}} /.


Note that you can find the lists of which positions can't match in values and the values they can't match with:

var = Flatten[Position[vars, #] & /@ Variables[eqs[[#, 1]]]] & /@
Range[15]
con = Select[eqs[[#, 1]], IntegerQ] & /@ Range[15]


{{1, 2, 3}, {4, 5, 6}, {7, 8, 9}, {10, 11, 12, 13}, {14, 15}, {20, 21, 22, 23}, {16, 17}, {18, 19}, {1, 4, 7}, {2, 5, 8, 10}, {3, 6, 9, 11}, {16}, {20, 17}, {12, 14, 21}, {13, 15, 22, 18}}

{1, 3, 0, 5, 0, 0, 2, 0, 0, 9, 0, 16, 0, 0, 0}

I haven't solved the numerical aspect of your problem, I will have to return to it a little later. However here is some code which will process the image into a computable format, ready for a solution to create and solve the equations.

bimg = Binarize[img, 0.95];
ip = ImagePartition[bimg, {Scaled[1/9], Scaled[1/7]}];
ipc = Map[ImageCrop[#, 210 {1, 1}] &, ip, {2}];

(*Train a classifier for test recognition*)
characters =
Flatten[Table[
ImageCrop[
Rasterize[Text[Style[#, FontFamily -> "Century Gothic"]],
ImageSize -> size]] -> # & /@ (ToString /@
Range[45]), {size, {20, 30, 40, 50}}]];
simpleOcr = Classify[characters];

(*Dirty but does the trick for now*)
vals2[img_] := Module[{subimgs, v, p},

subimgs = {
ImageCrop[img, {210, 100}, Bottom],
ImageCrop[img, {210, 100}, Top],
ImageCrop[img, {100, 210}, Left],
ImageCrop[img, {100, 210}, Right]
};

v = N /@ Mean /@ Flatten /@ ImageData /@ subimgs;

If[v == {0., 0., 0., 0.}, Black,
If[v == {1., 1., 1., 1.}, White,
p = Flatten[Position[v, 1.]];
If[Length[p] == 1,
simpleOcr@ImageCrop[
subimgs[[{2, 1, 4, 3}]][[
p[[1]]
]]
],
Style[simpleOcr@ImageCrop[img], Red]
]
]
]

]

Grid[
Map[vals2, ipc, {2}]
]
`