6
$\begingroup$

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:

Imagem1

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:

enter image description here

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

enter image description here

$\endgroup$
  • $\begingroup$ I have identified two solutions, can you check they're both correct? My second one is the one you had. $\endgroup$ – Feyre Jan 26 '17 at 13:49
  • $\begingroup$ 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? $\endgroup$ – Anton Antonov Jan 27 '17 at 19:30
  • $\begingroup$ @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. $\endgroup$ – LCarvalho Jan 27 '17 at 19:41
6
$\begingroup$

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

enter image description here

{{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

enter image description here

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}

$\endgroup$
6
$\begingroup$

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

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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