Solving puzzle with sum
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}
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}]
]