I made a little solver that seems to work (tested 2 different grids), but might not solve all grids. Here is the code:
hintstyle = Sequence[11, Red];
candstyle = Sequence[8, Gray];
fixedstyle = Sequence[22];
opchars = {Plus -> "+", Minus -> "-", Times -> "\[Times]",
Divide -> "\[Divide]"};
ClearAll[SquareSides, ClueText, DrawGrid]
SquareSides[n_, m_] := Module[{},
{{{n, -m}, {n + 1, -m}},
{{n, -m}, {n, -m - 1}},
{{n + 1, -m}, {n + 1, -m - 1}},
{{n, -m - 1}, {n + 1, -m - 1}}
}
]
ClueText[cands_, {x_, y_}] := Module[{center, r = 0.2, cp},
center = {x + 0.5, -y - 0.5};
If[Length[cands] == 1,
Text[Style[First[cands], fixedstyle], center]
,
cp = CirclePoints[center, {r, \[Pi]/2}, n];
cp = MapThread[
Text[Style[#1, candstyle], #2] &, {Range[n], cp}][[cands]];
cp
]
]
DrawGrid[cands_List, hints_List] :=
Module[{hor, ver, all, rem, boxborders, topleft, hinttext, candpos,
candtext},
hor = Flatten[Outer[List, Range[n], Range[n + 1]], 1];
ver = Flatten[Outer[List, Range[n + 1], Range[n]], 1];
all = Join[{#, # + {1, 0}} & /@ hor, {#, # + {0, 1}} & /@ ver];
all[[All, All, 2]] *= -1;
topleft = First[TakeSmallestBy[#, Total, 1]] & /@ hints[[All, 3]];
topleft += 0.08;
topleft[[All, 2]] *= -1;
hinttext = ToString[#1] <> (#2 /. opchars) & @@@ hints;
hinttext =
MapThread[
Text[Style[#1, hintstyle], #2, {-1, 1}] &, {hinttext, topleft}];
boxborders = Apply[SquareSides, hints[[All, 3]], {2}];
boxborders = Flatten[#, 1] & /@ boxborders;
boxborders =
Select[Tally[#], Last[#] == 1 &][[All, 1]] & /@ boxborders;
boxborders = Flatten[boxborders, 1];
rem = Complement[all, boxborders];
candpos = Tuples[Range[n], 2];
candtext = MapThread[ClueText, {Flatten[cands, 1], candpos}];
Graphics[{{Gray, Thickness[0.005], Line /@ rem},
hinttext,
{Thickness[0.01], Line[boxborders]},
candtext
}, ImageSize -> 65 n]
]
ClearAll[ApplyHint, DivideFunc, MinusFunc]
DivideFunc[x_, y_] := Abs[Log[x/y]]
MinusFunc[x_, y_] := Abs[x - y]
ApplyHint[ans_Integer, op : Divide | Minus, cells_List] :=
Module[{cns},
If[Length[cells] == 2,
Switch[op,
Divide, ApplyHint[Log[ans], DivideFunc, cells],
Minus, ApplyHint[ans, MinusFunc, cells]
]
,
Print["Divide/Minus should have 2 cells!!"];
Abort[];
]
]
ApplyHint[ans_, op : (Times | Plus | DivideFunc | MinusFunc),
cells_List] := Module[{cns},
cns = Extract[cands, cells];
cns = Select[Tuples[cns], op @@ # == ans &];
(* TODO: not only should the 'ans' match,
but also we can not have the same values in the same row/column,
filter for that here\[Ellipsis] *)
cns = DeleteDuplicates /@ (cns\[Transpose]);
MapThread[(Part[cands, Sequence @@ #2] = #1) &, {cns, cells}]
]
ClearAll[DeleteCands]
DeleteCands[{n_, m_},
del_] := (Part[cands, n, m] = Complement[Part[cands, n, m], del])
ClearAll[NakedSubset, SameValsCorrectnQ, NakedDelete]
SameValsCorrectnQ[cells_, n_Integer] := Module[{celldata},
celldata = Extract[cands, cells];
If[AllTrue[celldata, Length[#] == n &],
Equal @@ (Sort /@ celldata)
,
False
]
]
NakedSubset[m_Integer] := Module[{cellgroups},
cellgroups =
Join[Outer[List, Range[n], Range[n]],
Outer[List, Range[n], Range[n]]\[Transpose]];
Do[NakedSubset[m, cg], {cg, cellgroups}]
]
NakedSubset[m_Integer, cells_List] := Module[{subsets},
subsets = Subsets[cells, {m}];
subsets = Select[subsets, SameValsCorrectnQ[#, m] &];
Do[NakedDelete[cells, ss], {ss, subsets}]
]
NakedDelete[cells_List, samesubs_List] := Module[{other, digits},
other = Complement[cells, samesubs];
digits = First[Extract[cands, samesubs[[{1}]]]];
Do[DeleteCands[o, digits], {o, other}]
]
A puzzle has a size and some hints, and then we solve it:
n = 6;
hints = {
{3, Plus, {{1, 1}}},
{7, Plus, {{2, 1}, {1, 2}, {2, 2}}},
{4, Minus, {{3, 1}, {4, 1}}},
{16, Plus, {{5, 1}, {5, 2}, {6, 2}}},
{2, Plus, {{6, 1}}},
{60, Times, {{3, 2}, {4, 2}, {4, 3}}},
{3, Minus, {{1, 3}, {1, 4}}},
{108, Times, {{3, 3}, {2, 3}, {2, 4}}},
{5, Plus, {{5, 3}}},
{5, Plus, {{6, 3}, {6, 4}}},
{11, Plus, {{3, 4}, {3, 5}, {4, 5}}},
{2, Divide, {{4, 4}, {5, 4}}},
{20, Times, {{1, 5}, {2, 5}, {2, 6}}},
{9, Times, {{5, 5}, {5, 6}, {6, 5}}},
{6, Plus, {{1, 6}}},
{2, Divide, {{3, 6}, {4, 6}}},
{5, Plus, {{6, 6}}}
};
AbsoluteTiming[
cands = ConstantArray[Range[n], {n, n}];
old = False;
While[old =!= cands,
old = cands;
AbsoluteTiming[ApplyHint @@@ hints;];
NakedSubset /@ Range[Ceiling[n/2]];
];
]
DrawGrid[cands, hints]
Giving:
Or for the original problems:
n = 4;
hints = {
{12, Times, {{1, 1}, {2, 1}, {2, 2}}},
{2, Divide, {{3, 1}, {4, 1}}},
{11, Plus, {{1, 2}, {1, 3}, {1, 4}, {2, 3}}},
{2, Minus, {{3, 2}, {3, 3}}},
{2, Plus, {{4, 2}}},
{4, Plus, {{4, 3}, {4, 4}}},
{3, Minus, {{2, 4}, {3, 4}}}
};
AbsoluteTiming[
cands = ConstantArray[Range[n], {n, n}];
old = False;
While[old =!= cands,
old = cands;
AbsoluteTiming[ApplyHint @@@ hints;];
NakedSubset /@ Range[Ceiling[n/2]];
];
]
DrawGrid[cands, hints]
Giving:
Solves it within 10 milliseconds for me.
It by no means solves all the KenKen puzzles, once should add the Hidden Subsets technique and eliminate possibilities that I commented in the code.
Cheers!
