完美间隔配对排列

王守恩

(* 终极优化：成对放置算法(支持大 n 计算)*) LangfordCount[n_Integer] := Module[{L = 2n+1, count = 0, stack, positions, used, firstVal, lastVal, pos, k, newState, candidates, nextPos, i, prevPos, startTime},
  
(* 初始化状态 *) positions = ConstantArray[-1, L]; used = Table[0, {n+1}]; stack = {{positions, used, -1, -1}}; startTime = AbsoluteTime[]; While[Length[stack] > 0,

(* 进度显示 *) If[Mod[count, 100000] == 0 && count > 0, Print["n=", n, " 已计算: ", count, " 状态数: ", Length[stack], " 耗时: ", Round[AbsoluteTime[] - startTime], "秒"]];

{positions, used, firstVal, lastVal} = Last[stack]; stack = Most[stack];
   
(* 找到第一个空位 *) pos = FirstPosition[positions, -1]; If[pos === Missing["NotFound"], If[firstVal > lastVal && firstVal >= 2 && lastVal >= 1, count++]; Continue[]; ]; pos = pos[[1]];
   
(* 1. 特殊处理：首位放置 *) If[pos == 1 && firstVal == -1,Do[If[used[[k+1]] == 0 && (nextPos = 1 + k + 1) <= L && positions[[nextPos]] == -1,

newState = { ReplacePart[positions, {1 -> k, 1+k+1 -> k}],ReplacePart[used, k+1 -> 2], k, lastVal}; stack = Append[stack, newState]; ], {k, 2, n} (* 首位只放2~n *)]; Continue[]; ];
   
(* 2. 特殊处理：尾位放置 *) If[pos == L && lastVal == -1,maxK = If[firstVal > -1, firstVal - 1, n]; Do[If[used[[k+1]] == 0 && (prevPos = L - (k + 1)) >= 1 && positions[[prevPos]] == -1,

newState = {ReplacePart[positions, {L -> k, L-(k+1) -> k}], ReplacePart[used, k+1 -> 2], firstVal, k}; stack = Append[stack, newState]; ], {k, 1, maxK} (* 尾位放1~(firstVal-1) *)]; Continue[]; ];
   
(* 3. 常规放置 *) candidates = {};
   
(* 3.1 放置0 *) If[pos != 1 && pos != L && used[[1]] == 0, AppendTo[candidates, 0]];
   
(* 3.2 放置数字 *) Do[If[used[[k+1]] == 0, (* 检查作为第一个k的位置 *) nextPos = pos + k + 1; If[nextPos <= L && positions[[nextPos]] == -1, AppendTo[candidates, k]; ]; ], {k, 1, n}];
   
(* 处理候选 *) Do[k = candidates[];If[k == 0,(* 放置0 *) newState = {ReplacePart[positions, pos -> 0], ReplacePart[used, 1 -> 1], firstVal, lastVal},

(* 放置数字 *) newState = {ReplacePart[positions, {pos -> k, pos+k+1 -> k}], ReplacePart[used, k+1 -> 1],  

(* 只标记使用一次 *)If[pos == 1, k, firstVal], If[pos+k+1 == L, k, lastVal]}]; stack = Append[stack, newState]; , {i, Length[candidates]}]];
  
Print["n=", n, " -> ", count, " (总耗时: ", Round[AbsoluteTime[] - startTime], "秒)"];count]; (* 计算n=14 *) LangfordCount[14]

01  1,
02  1,
03  1,
04  3,
05  11,
06  38,   
07  130,  n=7 -> 130 (总耗时: 0秒)
08  638,    n=8 -> 638 (总耗时: 2秒)
09  4158,   n=9 -> 4158 (总耗时: 11秒)
10  23384,  n=10 -> 23384 (总耗时: 87秒)
11  124520,  n=11 -> 124520 (总耗时: 711秒)
12  847484,   n=12 -> 847484 (总耗时: 6265秒)
13  6987380,   
14  53746000,
15  400346544,    谢谢网友uk702！
16  3529108816,    谢谢网友l4m2！
17  35963592624,    谢谢网友l4m2！
18  351432650816,    谢谢网友l4m2！
19  3346590201888,   谢谢网友l4m2！
20  36341624453568,   谢谢网友l4m2！
21  443385597340544,   谢谢网友mathe！
22  5245806847699840,   谢谢网友mathe！——这个太伟大了！！！——比了才知道！！！

王守恩

用楼上的代码,连14也出不来(我已经很努力了了)！——22  5245806847699840,   谢谢网友mathe！——这个太伟大了！！！——比了才知道！！！