# Solving Suguru (Tectonic) puzzles

Posted 1 year ago
4661 Views
|
4 Replies
|
14 Total Likes
|

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:

1. each cell (thin lines) contains a single integer.
2. each container (cage, block) (thick lines) contains the non-repeating integer starting from 1 to the size of the container.
3. 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.

4 Replies
Sort By:
Posted 1 year ago
 Hi Sander,very nice indeed! And elegant.Cheers,M.
Posted 1 year ago
 Thanks Marco! It was 'in the works' for a long time, but somehow I never found the time to make a brute force solver for the really hard puzzles. In the end it quite easy and only took me ~5 minutes to make...