[seqfan] Minimal simple loop puzzle

[Elijah Beregovsky]

Dear seqfans!
Simple loop (usually shortened to sloop) is a logic puzzle consisting of a
square grid with some cells colored black. You have to draw a single loop
passing through centers of all white cells. So, basically, the task is to
find a hamiltonian cycle in a grid graph with some vertices deleted.
(Example puzzle: https://puzz.link/p?simpleloop/8/8/201000000g010)
Question: what is a(n), the smallest possible number of shaded cells in a
uniquely solvable n x n sloop puzzle?

Checking all possible arrangements of shaded cells is not feasible --
there's just too many of them, so I tried finding upper bounds for a(n). As
all grid graphs, and by extension all sloop graphs, are bipartite, a sloop
graph can be hamiltonian only if it is balanced (i.e. if you color it in a
checkerboard pattern, it contains equal numbers of vertices of each color).
I wrote a Mathematica program checking 500000 randomly chosen arrangements
of i black cells for each i of the same parity as board size n between n/2
and 2n (no mathematical reason for such bounds, just a hunch). If an
arrangement is balanced, then I attempt to FindHamiltonianCycle, at most 2
of them.

My very naive solution found the following upper bounds:
2 0
3 1
4 2
5 3
6 4
7 5
8 4
9 7
10 10

The main problem is, most arrangements, even balanced ones, are not
hamiltonian. So, more than 2/3 of the time the code runs it's trying to
solve broken puzzles. It is very slow, so slow that a(11) didn't terminate
in 2 hours. Is there another simple test for non-Hamiltonian graphs, which
is faster than just running FindHamiltonianCycle?

Best wishes, Elijah



My code, if you want:
BlackCellQ[n_, k_] :=
 If[OddQ[n], OddQ[k], Xor[OddQ[k], OddQ[Floor[(k - 1)/n]]]]

BalancedQ[n_, sub_] :=
 Mod[n, 2] == CountsBy[sub, BlackCellQ[n, #] &][[1]]*2 - Length[sub]

MinimalSloop[n_] :=
 Module[{black = {}, i = 0, g = Graph, c = {}, wrogn = 0},
  For[i = Mod[n, 2] + 2*Floor[n/4], i <= 2 n,
   wrogn = 0;
   m = Binomial[n^2, i];
   samp = RandomInteger[{1, m}, Min[m, 500000]];
   black =
    Select[Subsets[Range[n^2], {i}, {#}][[1]] & /@ samp,
     BalancedQ[n, #] &];
   Print["\n", "Number of black cells: ", i, "\n",
    "Number of test arrangements: ", Length[black]];
   For[j = 1, j <= Length[black],
    g = VertexDelete[GridGraph[{n, n}], black[[j]]];
    c = FindHamiltonianCycle[g, 2];
    If[Length[c] == 1,
     Print[GraphPlot[HighlightGraph[GridGraph[{n, n}], c]], " ", i];
     j = Length[black]; i = 2 n];
    If[Length[c] == 0, wrogn++];
    j++;];
   Print["Number of non hamiltonian arrangements: ", wrogn];
   i += 2;]]
Timing[MinimalSloop[9]]