Message Boards Message Boards

GROUPS:

Solving Suguru (Tectonic) puzzles

Posted 3 years ago
14102 Views
|
5 Replies
|
15 Total Likes
|

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.

5 Replies

Hi Sander,

very nice indeed! And elegant.

Cheers,

M.

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...

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

Thanks!

Thanks for your contribution. I just started to learn about the Wolfram language, I'm always coding in .NET (and, more specifically, in VB.NET, because I can do everything I want with it), and could use your examples to debug my try-outs in VB.NET. Which worked out nice.

As for the backtracking algorithm in the end: I found it difficult to decipher. I tried my own, it worked, and I can read and understand the VB.NET code with not much effort. As for your Wolfram language version, I found it pretty much incomprehensible. Debet to my lack of knowledge of the Wolfram language, I know.

Thank you for your code, it did help me very much, and it looks like a tour de force! But I prefer VB.NET to enhance my Suguru/Tectonic application. Much more friendly.

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract