Message Boards Message Boards

Solving Suguru (Tectonic) puzzles

GROUPS:

enter image description here

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:

enter image description here

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:

enter image description here

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]

enter image description here

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]

enter image description here

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]

enter image description here

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]

enter image description here

We can now execute the above code-pieces repeatedly to further eliminate all the candidates and solve the puzzle:

enter image description here

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:

enter image description here

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]

enter image description here

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.

POSTED BY: Sander Huisman
Answer
1 month ago

Hi Sander,

very nice indeed! And elegant.

Cheers,

M.

POSTED BY: Marco Thiel
Answer
27 days 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...

POSTED BY: Sander Huisman
Answer
26 days ago

enter image description here - Congratulations! This post is now a Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

POSTED BY: Moderation Team
Answer
27 days ago

Thanks!

POSTED BY: Sander Huisman
Answer
26 days ago

Group Abstract Group Abstract