Solving puzzle with sum

Question

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};
textResp = MapThread[Text, {value, pos}];

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

Answer 1

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, 
    Thread[0 < vars < 10]};
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}} /. 
  Thread[vars -> s2[[1]]] // MatrixForm

{{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}} /. 
  Thread[vars -> s2[[2]]] // MatrixForm

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}

Answer 2

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