Above is the starting grid of a so called Suguru puzzle (also known as Tectonic or number block puzzles). See https://krazydad.com/suguru/ for many more puzzles.
The rules are simple:
- each cell (thin lines) contains a single integer.
- each container (cage, block) (thick lines) contains the non-repeating integer starting from 1 to the size of the container.
- adjacent (including diagonally touching) cells do not have the same number
So, for example, this means that in the bottom we have a container of size 2 that those cells will contain the numbers 1 and 2 or 2 and 1.
Let's set up the candidates for each cell, and the containers (I called them tectons):
tectons = {
{{1, 1}, {1, 2}, {2, 1}, {2, 2}, {3, 1}},
{{1, 3}, {1, 4}, {1, 5}, {2, 3}, {2, 4}},
{{1, 6}, {1, 7}, {2, 5}, {2, 6}, {3, 5}},
{{1, 8}, {2, 7}, {2, 8}, {3, 6}, {3, 7}},
{{1, 9}, {2, 9}, {3, 9}, {4, 8}, {4, 9}},
{{3, 8}},
{{5, 8}},
{{5, 9}, {6, 8}, {6, 9}, {7, 8}, {7, 9}},
{{4, 6}, {4, 7}, {5, 6}, {5, 7}, {6, 7}},
{{5, 5}, {6, 5}, {6, 6}, {7, 4}, {7, 5}},
{{5, 2}, {5, 3}, {6, 3}, {6, 4}, {7, 3}},
{{3, 3}, {3, 4}, {4, 4}, {4, 5}, {5, 4}},
{{3, 2}, {4, 1}, {4, 2}, {4, 3}, {5, 1}},
{{6, 1}, {6, 2}, {7, 1}, {7, 2}},
{{7, 6}, {7, 7}}
};
givens = <|
{1, 1} -> 1,
{2, 2} -> 2,
{3, 1} -> 4,
{1, 4} -> 1,
{2, 8} -> 3,
{3, 3} -> 4,
{3, 9} -> 4,
{4, 4} -> 1,
{5, 1} -> 4,
{5, 3} -> 5,
{5, 5} -> 4,
{5, 7} -> 5,
{6, 8} -> 3,
{7, 5} -> 2,
{7, 9} -> 5
|>;
Let's create the database (db) of candidates, and process the given hints:
If[! DuplicateFreeQ[Join @@ tectons], Print["Cells have to be unique among tectonics"]; Abort[];];
canddb = With[{x = #}, {#, Range[Length[x]]} & /@ x] & /@ tectons;
canddb = Association[Rule @@@ (Join @@ canddb)];
KeyValueMap[(canddb[#1] = {#2}) &, givens];
Now we need a way to visualize them:
ClearAll[VisualizeTectonic, VisualizeTectonicSideHelper, VisualizeTectonicNumberHelper]
VisualizeTectonicNumberHelper[{row_, column_}, cand_List] := Module[{p, l, poss, t},
l = Length[cand];
p = {column, -row};
If[l == 1,
Text[Style[First[cand], Black, 17], p]
,
MapThread[Text[Style[#1, 12, Red], #2] &, {cand, CirclePoints[p, 0.2, l]}]
]
]
VisualizeTectonicSideHelper[tecton_List] := Module[{p, sides},
p = {#2, -#1} & @@@ tecton;
sides = Partition[{# + {-0.5, -0.5}, # + {0.5, -0.5}, # + {0.5, 0.5}, # + {-0.5, 0.5}}, 2, 1, 1] & /@ p;
sides = Join @@ sides;
sides = Tally[Sort /@ sides];
Table[If[Last[s] == 1, {Thickness[0.01], Line[First[s]]}, Line[First[s]]], {s, sides}]
]
VisualizeTectonic[canddb_Association, tectons_List] := Module[{nums, sides, cb},
nums = KeyValueMap[VisualizeTectonicNumberHelper, canddb];
sides = VisualizeTectonicSideHelper /@ tectons;
cb = #2 - #1 & @@@ CoordinateBounds[Transpose[Join @@ tectons]];
Graphics[{nums, sides}, ImageSize -> Norm[cb] 15]
]
Trying out:
VisualizeTectonic[canddb, tectons]
gives:
The red numbers now indicates possible candidates for each cell, black numbers are solved. Now it is time to eliminate numbers until we find the correct answer for each cell.
We will start by defining two helper functions:
ClearAll[NeighbourQ, Neighbours]
NeighbourQ[p : {x_, y_}, p2 : {x2_, y2_}] := ChessboardDistance[p, p2] === 1
Neighbours[p : {x_, y_}] := Transpose[p + Transpose[{{-1, -1}, {-1, 0}, {-1, 1}, {0, -1}, {0, 1}, {1, -1}, {1, 0}, {1, 1}}]]
to test if two cells are neighbours, and what the neighbours of a cell are, respectively.
Now we can easily create a new function to delete candidates around cells that are solved:
Do[
{k, v} = List @@ Part[Normal[canddb], i];
If[Length[v] == 1,
neighbours = Neighbours[k];
Do[
If[KeyExistsQ[canddb, nb],
canddb[nb] = DeleteCases[canddb[nb], First[v]];
];
,
{nb, neighbours}
]
];
,
{i, Length[canddb]}
];
Executing this and then calling VisualizeTectonic[canddb, tectons] gives:
We can also delete any candidate that matches a solved number inside a container:
(* delete candidates from singles in same tecton *)
Do[
values = canddb /@ t;
If[Length[values] > 1,
singles = Select[Transpose[{t, values}], Length[Last[#]] == 1 &];
nonsingles = Complement[t, singles[[All, 1]]];
(canddb[#1] = Complement[canddb[#1], Join @@ singles[[All, 2]]]) & /@ nonsingles
]
,
{t, tectons}
];
VisualizeTectonic[canddb, tectons]
If a candidate only appears once inside a container then that must be the position:
(* hidden singles *)
Do[
values = canddb /@ t;
values = Tally[Join @@ values];
values = Select[values, Last[#] == 1 &][[All, 1]];
If[Length[values] > 0,
Do[
If[ContainsAny[canddb[c], values],
canddb[c] = Intersection[canddb[c], values]
];
,
{c, t}
];
]
,
{t, tectons}
];
VisualizeTectonic[canddb, tectons]
We can even try some more elaborate tests in order to eliminate candidates:
(* in each tecton search for cells with numbers that appear at least twice then
look at their common neighbours: eliminate that number from the common neighbours *)
Do[
values = canddb /@ t;
values = Tally[Join @@ values];
values = Select[values, Last[#] > 1 &][[All, 1]];
Do[
cells = Select[t, MemberQ[canddb[#], v] &];
nb = Neighbours /@ cells;
nb = Intersection @@ nb;
nb = Complement[nb, cells]; (*strictly speaking not necessary I think *)
nb = Intersection[nb, Join @@ tectons];
If[Length[nb] > 0,
Do[
canddb[n] = DeleteCases[canddb[n], v];
,
{n, nb}
];
];
,
{v, values}
]
,
{t, tectons}
];
VisualizeTectonic[canddb, tectons]
Lastly we can look at pairs of cells, if two adjacent cells both have the same 2 candidates left, then one can eliminate those two candidates from their common neighbours:
(* naked pairs *)
paircells = GatherBy[KeyValueMap[List, Select[canddb, Length[#] == 2 &]], Sort@*Last][[All, All, 1]];
pairedpaircells = Select[paircells, Length[#] > 1 &];
pairedpaircells = Join @@ (Subsets[#, {2}] & /@ pairedpaircells);
pairedpaircells = Select[pairedpaircells, NeighbourQ @@ # &];
neigbours = Intersection[##, Keys[canddb]] & @@@ Map[Neighbours, pairedpaircells, {2}];
vals = canddb /@ pairedpaircells[[All, 1]];
del = Transpose[{neigbours, vals}];
Do[
{nb, v} = d;
Do[
canddb[n] = Complement[canddb[n], v]
,
{n, nb}
]
,
{d, del}
];
VisualizeTectonic[canddb, tectons]
We can now execute the above code-pieces repeatedly to further eliminate all the candidates and solve the puzzle:
Here is all the code and a while loop that iterates the candidate-elimination functions until there is not progress any more:
ClearAll[VisualizeTectonic, VisualizeTectonicSideHelper, VisualizeTectonicNumberHelper, NeighbourQ, Neighbours]
VisualizeTectonicNumberHelper[{row_, column_}, cand_List] := Module[{p, l, poss, t},
l = Length[cand];
p = {column, -row};
If[l == 1,
Text[Style[First[cand], Black, 17], p]
,
MapThread[Text[Style[#1, 12, Red], #2] &, {cand, CirclePoints[p, 0.2, l]}]
]
]
VisualizeTectonicSideHelper[tecton_List] := Module[{p, sides},
p = {#2, -#1} & @@@ tecton;
sides = Partition[{# + {-0.5, -0.5}, # + {0.5, -0.5}, # + {0.5, 0.5}, # + {-0.5, 0.5}}, 2, 1, 1] & /@ p;
sides = Join @@ sides;
sides = Tally[Sort /@ sides];
Table[If[Last[s] == 1, {Thickness[0.01], Line[First[s]]}, Line[First[s]]], {s, sides}]
]
VisualizeTectonic[canddb_Association, tectons_List] :=
Module[{nums, sides, cb},
nums = KeyValueMap[VisualizeTectonicNumberHelper, canddb];
sides = VisualizeTectonicSideHelper /@ tectons;
cb = #2 - #1 & @@@ CoordinateBounds[Transpose[Join @@ tectons]];
Graphics[{nums, sides}, ImageSize -> Norm[cb] 15]
]
NeighbourQ[p : {x_, y_}, p2 : {x2_, y2_}] := ChessboardDistance[p, p2] === 1
Neighbours[p : {x_, y_}] := Transpose[p + Transpose[{{-1, -1}, {-1, 0}, {-1, 1}, {0, -1}, {0, 1}, {1, -1}, {1, 0}, {1, 1}}]]
tectons = {
{{1, 1}, {1, 2}, {2, 1}, {2, 2}, {3, 1}},
{{1, 3}, {1, 4}, {1, 5}, {2, 3}, {2, 4}},
{{1, 6}, {1, 7}, {2, 5}, {2, 6}, {3, 5}},
{{1, 8}, {2, 7}, {2, 8}, {3, 6}, {3, 7}},
{{1, 9}, {2, 9}, {3, 9}, {4, 8}, {4, 9}},
{{3, 8}},
{{5, 8}},
{{5, 9}, {6, 8}, {6, 9}, {7, 8}, {7, 9}},
{{4, 6}, {4, 7}, {5, 6}, {5, 7}, {6, 7}},
{{5, 5}, {6, 5}, {6, 6}, {7, 4}, {7, 5}},
{{5, 2}, {5, 3}, {6, 3}, {6, 4}, {7, 3}},
{{3, 3}, {3, 4}, {4, 4}, {4, 5}, {5, 4}},
{{3, 2}, {4, 1}, {4, 2}, {4, 3}, {5, 1}},
{{6, 1}, {6, 2}, {7, 1}, {7, 2}},
{{7, 6}, {7, 7}}
};
givens = <|
{1, 1} -> 1,
{2, 2} -> 2,
{3, 1} -> 4,
{1, 4} -> 1,
{2, 8} -> 3,
{3, 3} -> 4,
{3, 9} -> 4,
{4, 4} -> 1,
{5, 1} -> 4,
{5, 3} -> 5,
{5, 5} -> 4,
{5, 7} -> 5,
{6, 8} -> 3,
{7, 5} -> 2,
{7, 9} -> 5
|>;
If[! DuplicateFreeQ[Join @@ tectons], Print["Cells have to be unique among tectonics"]; Abort[];];
canddb = With[{x = #}, {#, Range[Length[x]]} & /@ x] & /@ tectons;
canddb = Association[Rule @@@ (Join @@ canddb)];
KeyValueMap[(canddb[#1] = {#2}) &, givens];
VisualizeTectonic[canddb, tectons]
oldcanddb = 1;
While[oldcanddb =!= canddb,
oldcanddb = canddb;
(* delete from neighbours of singles *)
Do[
{k, v} = List @@ Part[Normal[canddb], i];
If[Length[v] == 1,
neighbours = Neighbours[k];
Do[
If[KeyExistsQ[canddb, nb],
canddb[nb] = DeleteCases[canddb[nb], First[v]];
];
,
{nb, neighbours}
]
];
,
{i, Length[canddb]}
];
(* delete candidates from singles in same tecton *)
Do[
values = canddb /@ t;
If[Length[values] > 1,
singles = Select[Transpose[{t, values}], Length[Last[#]] == 1 &];
nonsingles = Complement[t, singles[[All, 1]]];
(canddb[#1] = Complement[canddb[#1], Join @@ singles[[All, 2]]]) & /@ nonsingles
]
,
{t, tectons}
];
(* hidden singles *)
Do[
values = canddb /@ t;
values = Tally[Join @@ values];
values = Select[values, Last[#] == 1 &][[All, 1]];
If[Length[values] > 0,
Do[
If[ContainsAny[canddb[c], values],
canddb[c] = Intersection[canddb[c], values]
];
,
{c, t}
];
]
,
{t, tectons}
];
(* in each tecton search for cells with numbers that appear at least \
twice then look at their common neighbours: eliminate that number \
from the common neighbours *)
Do[
values = canddb /@ t;
values = Tally[Join @@ values];
values = Select[values, Last[#] > 1 &][[All, 1]];
Do[
cells = Select[t, MemberQ[canddb[#], v] &];
nb = Neighbours /@ cells;
nb = Intersection @@ nb;
nb = Complement[nb, cells]; (* strictly speaking not necessary I think *)
nb = Intersection[nb, Join @@ tectons];
If[Length[nb] > 0,
Do[
canddb[n] = DeleteCases[canddb[n], v];
,
{n, nb}
];
];
,
{v, values}
]
,
{t, tectons}
];
(* pairs *)
paircells = GatherBy[KeyValueMap[List, Select[canddb, Length[#] == 2 &]], Sort@*Last][[All, All, 1]];
pairedpaircells = Select[paircells, Length[#] > 1 &];
pairedpaircells = Join @@ (Subsets[#, {2}] & /@ pairedpaircells);
pairedpaircells = Select[pairedpaircells, NeighbourQ @@ # &];
neigbours = Intersection[##, Keys[canddb]] & @@@ Map[Neighbours, pairedpaircells, {2}];
vals = canddb /@ pairedpaircells[[All, 1]];
del = Transpose[{neigbours, vals}];
Do[
{nb, v} = d;
Do[
canddb[n] = Complement[canddb[n], v]
,
{n, nb}
]
,
{d, del}
];
]
VisualizeTectonic[canddb, tectons]
Brute force solver
This however does not solve all puzzles:
tectons = {
{{1, 1}, {1, 2}, {2, 1}, {3, 1}, {4, 1}},
{{1, 3}, {1, 4}, {2, 2}, {2, 3}, {3, 2}},
{{1, 5}, {2, 4}, {2, 5}, {3, 3}, {3, 4}},
{{1, 6}, {1, 7}, {2, 7}, {2, 8}, {3, 8}},
{{1, 8}, {1, 9}, {1, 10}, {1, 11}, {2, 9}},
{{1, 12}, {2, 12}},
{{2, 6}, {3, 5}, {3, 6}, {3, 7}, {4, 5}},
{{2, 10}, {2, 11}, {3, 11}, {3, 12}, {4, 12}},
{{3, 9}, {3, 10}, {4, 8}, {4, 9}, {4, 10}},
{{4, 2}, {4, 3}, {5, 1}, {5, 2}, {6, 1}},
{{4, 4}, {5, 4}, {5, 5}, {5, 6}, {6, 5}},
{{4, 6}, {4, 7}, {5, 7}, {5, 8}, {6, 8}},
{{4, 11}, {5, 10}, {5, 11}, {5, 12}, {6, 11}},
{{5, 3}, {6, 3}, {6, 4}, {7, 4}, {7, 5}},
{{6, 6}},
{{6, 7}, {7, 7}, {8, 7}, {8, 8}, {9, 7}},
{{7, 8}, {7, 9}, {8, 9}, {8, 10}, {9, 10}},
{{8, 11}},
{{5, 9}, {6, 9}, {6, 10}, {7, 10}, {7, 11}},
{{6, 12}, {7, 12}, {8, 12}, {9, 11}, {9, 12}},
{{10, 12}},
{{9, 8}, {9, 9}, {10, 9}, {10, 10}, {10, 11}},
{{9, 6}, {10, 5}, {10, 6}, {10, 7}, {10, 8}},
{{9, 1}, {10, 1}, {10, 2}, {10, 3}, {10, 4}},
{{7, 1}, {8, 1}, {8, 2}, {9, 2}, {9, 3}},
{{6, 2}, {7, 2}, {7, 3}, {8, 3}, {8, 4}},
{{7, 6}, {8, 5}, {8, 6}, {9, 4}, {9, 5}}
};
givens = <|
{1, 1} -> 3,
{3, 1} -> 1,
{1, 3} -> 4,
{1, 5} -> 3,
{1, 10} -> 2,
{2, 12} -> 2,
{3, 11} -> 5,
{5, 1} -> 2,
{5, 8} -> 5,
{5, 11} -> 4,
{6, 3} -> 2,
{7, 1} -> 5,
{7, 11} -> 5,
{7, 12} -> 3,
{8, 6} -> 3,
{9, 9} -> 5,
{9, 12} -> 5,
{10, 2} -> 5,
{10, 8} -> 3
|>;
Which can be solved till the following state using the above techniques:
We can now define this depth-first recursive backtracking algorithm:
ClearAll[ValidGridQ, BackTrackHelper, BackTrack]
ValidGridQ[canddb_Association, tectons_, lastkey_] := Module[{vals, tecton, nbs},
nbs = Neighbours[lastkey];
nbs = Intersection[nbs, Keys[canddb]]; (* neighbours that exist *)
nbs = First /@ Select[canddb /@ nbs, Length[#] == 1 &]; (* get the values of neighbours with a single value *)
If[FreeQ[nbs, First@canddb[lastkey]], (* if this does not contain the 'set' one *)
tecton = SelectFirst[tectons, MemberQ[lastkey]];
vals = canddb /@ tecton;
If[ContainsAll[Flatten[vals], Range[Length[tecton]]], (* each tecton still has all its values in it *)
vals = First /@ Select[vals, Length[#] == 1 &];
DuplicateFreeQ[vals] (* and these set values does not have duplicates *)
,
False
]
,
False
]
]
BackTrackHelper[candidatesdb_Association, tectons_] := Module[{nextkey, options, copy},
nextkey = First[Keys[Select[candidatesdb, Length[#] > 1 &]], Missing[]];
If[Not[MissingQ[nextkey]],
options = candidatesdb[nextkey];
Do[
copy = candidatesdb;
copy[nextkey] = {o};
If[ValidGridQ[copy, tectons, nextkey], BackTrackHelper[copy, tectons]]
,
{o, options}
]
,
Throw[candidatesdb];
]
]
BackTrack[candidatesdb_Association, tectons_] := Catch[BackTrackHelper[candidatesdb, tectons]; Missing[]]
Calling the function and visualizing the output:
canddb = BackTrack[canddb, tectons];
VisualizeTectonic[canddb, tectons]
Which is correct! I hope you enjoyed this little solver code. Some related solvers I made can be found here:
Most of these solvers work in a similar manner: elimination of candidates.
