For smallish values of n
one can use integer programming. Below is one way to code that into Reduce
. I don'tpect it to be competitively fast, as written, for n>10
or so.
lacedTuples[n_] := Module[
{a, vars, fvars, c1, c2, c3, c4, c5, constraints, adjacents,
wrappedvars, colvals, coldiffs, soln},
vars = Array[a, {n, n}];
fvars = Flatten[vars];
c1 = Map[0 <= # <= 1 &, fvars];
c2 = Thread[Total[vars] == 1];
adjacents =
Flatten[Map[Partition[PadRight[#, n + 1, First[#]], 2, 1] &, vars],
1];
c3 = Map[Total[#] <= 1 &, adjacents];
wrappedvars = PadRight[vars, {n + 1, n + 1}, vars];
colvals = Range[n].vars;
coldiffs = Differences[PadRight[colvals, n + 1, colvals[[1]]]];
c4 = Map[-1 <= # <= 1 &, coldiffs];
constraints = Flatten[Join[c1, c2, c3, c4]];
soln = Solve[constraints, fvars, Integers];
If[Head[soln] === Solve, {},
colvals /. Solve[constraints, fvars, Integers]]
]
lacedTuples[6]
(* Out[263]= {{6, 5, 6, 5, 6, 5}, {5, 6, 5, 6, 5, 6}, {5, 6, 5, 6, 5,
4}, {6, 5, 6, 5, 4, 5}, {5, 6, 5, 4, 5, 6}, {5, 6, 5, 4, 5, 4}, {6,
5, 4, 5, 6, 5}, {6, 5, 4, 5, 4, 5}, {5, 4, 5, 6, 5, 6}, {5, 4, 5, 6,
5, 4}, {5, 4, 5, 4, 5, 6}, {5, 4, 5, 4, 5, 4}, {4, 5, 6, 5, 6,
5}, {4, 5, 6, 5, 4, 5}, {4, 5, 4, 5, 6, 5}, {4, 5, 4, 5, 4, 5}, {4,
5, 6, 5, 4, 3}, {4, 5, 4, 5, 4, 3}, {5, 6, 5, 4, 3, 4}, {5, 4, 5, 4,
3, 4}, {6, 5, 4, 3, 4, 5}, {4, 5, 4, 3, 4, 5}, {4, 5, 4, 3, 4,
3}, {5, 4, 3, 4, 5, 6}, {5, 4, 3, 4, 5, 4}, {5, 4, 3, 4, 3, 4}, {4,
3, 4, 5, 6, 5}, {4, 3, 4, 5, 4, 5}, {4, 3, 4, 5, 4, 3}, {4, 3, 4, 3,
4, 5}, {4, 3, 4, 3, 4, 3}, {3, 4, 5, 6, 5, 4}, {3, 4, 5, 4, 5,
4}, {3, 4, 5, 4, 3, 4}, {3, 4, 3, 4, 5, 4}, {3, 4, 3, 4, 3, 4}, {3,
4, 5, 4, 3, 2}, {3, 4, 3, 4, 3, 2}, {4, 5, 4, 3, 2, 3}, {4, 3, 4, 3,
2, 3}, {5, 4, 3, 2, 3, 4}, {3, 4, 3, 2, 3, 4}, {3, 4, 3, 2, 3,
2}, {4, 3, 2, 3, 4, 5}, {4, 3, 2, 3, 4, 3}, {4, 3, 2, 3, 2, 3}, {3,
2, 3, 4, 5, 4}, {3, 2, 3, 4, 3, 4}, {3, 2, 3, 4, 3, 2}, {3, 2, 3, 2,
3, 4}, {3, 2, 3, 2, 3, 2}, {2, 3, 4, 5, 4, 3}, {2, 3, 4, 3, 4,
3}, {2, 3, 4, 3, 2, 3}, {2, 3, 2, 3, 4, 3}, {2, 3, 2, 3, 2, 3}, {2,
3, 4, 3, 2, 1}, {2, 3, 2, 3, 2, 1}, {3, 4, 3, 2, 1, 2}, {3, 2, 3, 2,
1, 2}, {4, 3, 2, 1, 2, 3}, {2, 3, 2, 1, 2, 3}, {2, 3, 2, 1, 2,
1}, {3, 2, 1, 2, 3, 4}, {3, 2, 1, 2, 3, 2}, {3, 2, 1, 2, 1, 2}, {2,
1, 2, 3, 4, 3}, {2, 1, 2, 3, 2, 3}, {2, 1, 2, 3, 2, 1}, {2, 1, 2, 1,
2, 3}, {2, 1, 2, 1, 2, 1}, {1, 2, 3, 4, 3, 2}, {1, 2, 3, 2, 3,
2}, {1, 2, 3, 2, 1, 2}, {1, 2, 1, 2, 3, 2}, {1, 2, 1, 2, 1, 2}} *)
--- edit ---
Here is a related method, inspired by the (first) approach of @belisarius. We again use integer programming but avoid disjunction constraints as well as a plethora of 0-1 variables. We use n
of them just to enforce the condition that successive differences be either -1 or 1.
lacedTuples2[n_, s_] := Module[
{a, d, vars, dvars, padvars, c1, c2, c3, c4},
vars = Array[a, {n}];
dvars = Array[d, {n}];
padvars = PadRight[vars, n + 1, First[vars]];
c1 = Map[0 <= # <= 1 &, dvars];
c2 = Map[1 <= # <= s &, vars];
c3 = Table[
padvars[[j]] - padvars[[j - 1]] == -1 + 2*dvars[[j - 1]], {j, 2,
n + 1}];
c4 = Table[-padvars[[j]] + padvars[[j - 1]] ==
1 - 2*dvars[[j - 1]], {j, 2, n + 1}];
vars /. Solve[Join[c1, c2, c3], Join[vars, dvars], Integers]
]
Quick test.
lacedTuples2[4, 4]
(* Out[53]= {{1, 2, 1, 2}, {1, 2, 3, 2}, {2, 1, 2, 1}, {2, 1, 2, 3}, {2,
3, 2, 1}, {2, 3, 2, 3}, {2, 3, 4, 3}, {3, 2, 1, 2}, {3, 2, 3,
2}, {3, 2, 3, 4}, {3, 4, 3, 2}, {3, 4, 3, 4}, {4, 3, 2, 3}, {4, 3,
4, 3}} *)
Timing[lc12 = lacedTuples2[12, 12];]
(* Out[50]= {4.108000, Null} *)
Length[lc12]
(* Out[51]= 7916 *)
--- end edit ---
--- edit 2 ---
Here is a graph theory approach. I would post it as a separate answer but it gets very slow after n=10
or so. The idea is to create a directed graph where we have a "row" for each entry from 1 to n
, and "columns" 1 through s
. These together index the vertices. Edges connect row i
to row i+1
with the condition that they only connect contiguous column numbers. Also connect the last row to the first, with the same contiguity condition. Now get cycles of length n+1
and extract the column values.
lacedTuples3[s_, n_] := Module[
{a, n2 = Ceiling[n/2], verts, edges, gr, cycles},
verts = Array[a, {n, s}];
edges =
Flatten[Table[{DirectedEdge[a[i, j], a[i + 1, j + 1]],
DirectedEdge[a[i, j + 1], a[i + 1, j]]}, {i, n - 1}, {j,
s - 1}]];
edges =
Join[edges,
Flatten[Table[{DirectedEdge[a[n, j], a[1, j + 1]],
DirectedEdge[a[n, j + 1], a[1, j]]}, {j, s - 1}]]];
gr = Graph[edges];
cycles = FindCycle[gr, n + 1, All];
cycles[[All, All, 1, 2]]
]
lacedTuples3[4, 4]
(* ut[83]= {{3, 4, 3, 4}, {3, 4, 3, 2}, {3, 4, 3, 4}, {3, 2, 3, 4}, {2,
3, 4, 3}, {2, 3, 2, 3}, {2, 3, 2, 1}, {2, 1, 2, 3}, {2, 1, 2,
1}, {2, 3, 4, 3}, {2, 3, 2, 3}, {2, 1, 2, 3}, {1, 2, 3, 2}, {1, 2, 1, 2}} *)
--- end edit 2 ---
--- edit 3 ---
This is mostly to convince myself that the graph cycles approach was not entirely without merit.
extendCycle[cyc_List, edges_List] :=
Map[If[# > First[cyc] && ! MemberQ[cyc, #], Append[cyc, #],
Null /. Null :> Sequence[]] &, edges[[Last[cyc]]]]
allCycles[mat_, k_] :=
Module[{n = Length[mat], m2, cyc, cyclist},
m2 = Map[Last, Split[Sort[mat], First[#1] == First[#2] &], {2}];
cyclist =
Flatten[Drop[MapIndexed[{#2[[1]], #1} &, m2, {2}], -k + 1], 1];
Do[cyclist =
Flatten[Map[extendCycle[#, m2] &, cyclist], 1], {k - 2}];
Map[If[MemberQ[m2[[Last[#]]], First[#]], Append[#, First[#]],
Null /. Null :> Sequence[]] &, cyclist]]
lacedTuples4[s_, n_] := Module[
{a, verts, edges, vertvals, cycles},
verts = Array[a, {n, s}];
vertvals = Range[n^2];
edges =
Table[{{a[i, j], a[i + 1, j + 1]}, {a[i, j + 1], a[i + 1, j]}}, {i,
n - 1}, {j, s - 1}];
edges =
Partition[
Flatten[Join[edges,
Table[{{a[n, j], a[1, j + 1]}, {a[n, j + 1], a[1, j]}}, {j,
s - 1}]]], 2] /. Thread[Flatten[verts] -> Range[n^2]];
cycles = allCycles[edges, n] /. Thread[Range[n^2] -> Flatten[verts]];
cycles[[All, All, 2]]
]
The code for allCycles
was cribbed from a previous MSE thread. I need to ask hereabouts as to why the new in version 14 cycles code gets slow in this example; I had thought it was fairly fast on examples I tried in past. Even so, the above becomes orders of magnitude slower than the methods of @ybeltukov and others at n=12,s=12
or thereabouts.
By the way, I'm not really beating a dead horse on this; the dead horse is beating me.
--- end edit 3 ---