# [seqfan] Minimal simple loop puzzle

Elijah Beregovsky elijah.beregovsky at gmail.com
Sat Feb 26 18:15:46 CET 2022

```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.
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, #] &][]*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}, {#}][] & /@ 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]

```