How I Solved Sparse Rulers

Ed Pegg Jr, Wolfram Research

(RowDefault[, (Spacer1), , (Spacer1), ])  #WolframTechConf

ABSTRACT

A ruler with 6 marks at {0,1,2,3,8,12} can measure all distances 1 to 12. What is the minimal number of marks (Subscript[M, n])  for a general length n? Turns out the number of marks is (Subscript[E, n])=(Subscript[M, n])-⌈(Sqrt[3 n +9/4])⌋, with (Subscript[E, n]) being 0 or 1.

Variations

In a sparse ruler, all differences must be covered, but they can be repeated.

rulerpic[ruler_, color_]:= Module[{size,diff},
size=Last[ruler]-First[ruler];
diff=Select[{#[[2]]-#[[1]],Mean[#]}&/@Partition[ruler,2,1],#[[1]]>2&];
Graphics[{Black,Rectangle[{First[ruler]-1/2,0},{Last[ruler]+1/2,4}],
color,Thick,Line[{{#,.3},{#,3.7}}]&/@ruler, Black,
White,Style[Text[#[[1]],{#[[2]]+.2,1.8}],18, Bold]&/@diff}, ImageSize->{2 2.9size,70}]];
rulerpic[{0,1,2,3,4,5,6,7,107,112,117,122,130,138,146,154,162,170,178,186,194,202,205,208,211,214}, Yellow]

Flatten[Sort[Split[Sort[#[[2]]-#[[1]]&/@Subsets[{0,1,2,3,4,5,6,7,107,112,117,122,130,138,146,154,162,170,178,186,194,202,205,208,211,214},{2}]]]]]

In a Golomb ruler, differences can be missed, but none can be repeated.

golomb={{0,2,5,6},{0,3,4,9,11},{0,4,6,9,16,17}, {0,1,4,10,12,17},{0,1,4,10,15,17}, {0,1,8,11,13,17},{0,1,8,12,14,17},{0,1,4,10,18,23,25},{0,1,7,11,20,23,25},{0,1,11,16,19,23,25},{0,2,3,10,16,21,25},{0,2,7,13,21,22,25},{0,1,4,9,15,22,32,34},{0,1,5,12,25,27,35,41,44},{0,1,6,10,23,26,34,41,53,55},{0,1,4,13,28,33,47,54,64,70,72},{0,1,9,19,24,31,52,56,58,69,72},{0,2,6,24,29,40,43,55,68,75,76,85},{0,2,5,25,37,43,59,70,85,89,98,99,106},{0,4,6,20,35,52,59,77,78,86,89,99,122,127},{0,4,20,30,57,59,62,76,100,111,123,136,144,145,151},{0,1,4,11,26,32,56,68,76,115,117,134,150,163,168,177},{0,5,7,17,52,56,67,80,81,100,122,138,159,165,168,191,199},{0,2,10,22,53,56,82,83,89,98,130,148,153,167,188,192,205,216},{0,1,6,25,32,72,100,108,120,130,153,169,187,190,204,231,233,242,246},{0,1,8,11,68,77,94,116,121,156,158,179,194,208,212,228,240,253,259,283},{0,2,24,56,77,82,83,95,129,144,179,186,195,255,265,285,293,296,310,329,333},{0,1,9,14,43,70,106,122,124,128,159,179,204,223,253,263,270,291,330,341,353,356},{0,3,7,17,61,66,91,99,114,159,171,199,200,226,235,246,277,316,329,348,350,366,372},{0,9,33,37,38,97,122,129,140,142,152,191,205,208,252,278,286,326,332,353,368,384,403,425},{0,12,29,39,72,91,146,157,160,161,166,191,207,214,258,290,316,354,372,394,396,431,459,467,480},{0,1,33,83,104,110,124,163,185,200,203,249,251,258,314,318,343,356,386,430,440,456,464,475,487,492},{0,3,15,41,66,95,97,106,142,152,220,221,225,242,295,330,338,354,382,388,402,415,486,504,523,546,553}};
rulerpic[ruler_, color_]:= Module[{size,diff},
size=Last[ruler]-First[ruler];
diff=Select[{#[[2]]-#[[1]],Mean[#]}&/@Partition[ruler,2,1],#[[1]]>2&];
Graphics[{Black,Rectangle[{First[ruler]-1/2,0},{Last[ruler]+1/2,4}],
color,Thick,Line[{{#,.3},{#,3.7}}]&/@ruler, Black,
White,Style[Text[#[[1]],{#[[2]]+.2,1.8}],18, Bold]&/@diff}, ImageSize->{2 2.9size,80}]];
rulerpic[{0,2,10,22,53,56,82,83,89,98,130,148,153,167,188,192,205,216}, Cyan]

gol={0,2,10,22,53,56,82,83,89,98,130,148,153,167,188,192,205,216};Union[Last/@Tally[#[[2]]-#[[1]]&/@Subsets[gol,{2}]]]

Complement[Range[216],#[[2]]-#[[1]]&/@Subsets[gol,{2}]]

In a difference set, all modular distances must be covered, and none can be repeated.

diffsets ={{{7,3},{1,2,4}},{{13,4},{0,1,3,9}},{{21,5},{3,6,7,12,14}},{{31,6},{1,5,11,24,25,27}},{{57,8},{0,1,6,15,22,26,45,55}},{{73,9},{0,1,12,20,26,30,33,35,57}},{{91,10},{0,2,6,7,18,21,31,54,63,71}},{{133,12},{1,10,11,13,27,31,68,75,83,110,115,121}},{{183,14},{1,13,20,21,23,44,61,72,77,86,90,116,122,169}},{{273,17},{0,1,22,33,83,122,135,141,145,159,175,200,226,229,231,238,246}},{{307,18},{0,1,3,30,37,50,55,76,98,117,129,133,157,189,199,222,293,299}},{{381,20},{0,1,19,28,96,118,151,153,176,202,240,254,290,296,300,307,337,361,366,369}}};
Manipulate[With[{diffset = diffsets[[setindex,2]], circ= diffsets[[setindex,1,1]], len = diffsets[[setindex,1,2]]},With[{jj =Drop[Sort[Flatten[Table[{Mod[diffset[[a]]-diffset[[b]],circ],diffset[[a]],diffset[[b]]},{a,1,len},{b,1,len}],1]],len]},Graphics[{RGBColor[.67,.75,.15],Circle[{0,0},1],Black,Table[Circle[{0,0},1 -  n/(circ+5),{2 jj[[n,2]] Pi/circ, If[jj[[n,2]]<jj[[n,3]],2 jj[[n,3]] Pi/circ,2 jj[[n,3]] Pi/circ+2 Pi]}],{n,1,circ-1}], Table[Point[{Cos[2 Pi n/circ],Sin[2 Pi n/circ]}],{n,1,circ}],RGBColor[1,.47,0],AbsolutePointSize[6],Table[Point[{Cos[2 Pi diffset[[n]]/circ],Sin[2 Pi diffset[[n]]/circ]}],{n,1,len}]}]]],{{setindex,4,"pick a difference set"},1,12,1,Appearance-> "Labeled"},SaveDefinitions-> True]

History

Sparse rulers worked on by Paul Erdős, Marcel J. E. Golay, Alfréd Rényi, László Rédei and Solomon W. Golomb, among many others.

In 1956, John Leech wrote “On the Representation of 1, 2, …, n by Differences,” which proved the bounds (Sqrt[2.434n])≤(Subscript[M, n])≤(Sqrt[3.348n]).

In 1963, B. Wichmann wrote “A Note on Restricted Difference Bases,” in which he (or she?) constructed many sparse rulers.

In 1967, Robinson and Bernstein predicted the best 24-mark Golomb ruler.

In 1984, Atkinson and Hassenklover made predictions of the best Golomb rulers with under 100 marks.

In 2014, distributed.net proved that the predicted Golomb rulers were indeed correct using thousands of years of computer time.

In 2014, Arch D. Robison  verified sparse rulers up to 25 marks.

In 2016, Rokicki and Dogon made predictions of the best Golomb rulers with under 40000 marks.

Sparse Ruler 13

For length 13, greatest number of differences with 5 marks is (({{5}, {2}}))=10, not enough to measure all values 1 to 13. But 6 marks, (({{6}, {2}}))=15 differences.

Column[SplitBy[SortBy[Subsets[{0,1,6,9,11,13},{2}], Differences], Differences]]

{1,13,9,13,6,6,13,9,9,11,11,13,13}-{0,11,6,9,1,0,6,1,0,1,0,1,0}

ruler={0, 1, 6, 9, 11, 13};Union@Abs@Flatten@Outer[Subtract, ruler, ruler]

Sparse Ruler 50

Here is an optimal length-50 sparse ruler with 12 marks (i.e. (Subscript[M, 50])=12). The list of positions of the marks is the ruler form:

ruler50={0,1,3,6,13,20,27,34,41,45,49,50};

Graphics[{Thickness[.005],
Line[{{#,1},{#,1.5}}]&/@Range@50,
Line[{{#,1},{#,5}}]&/@ruler50
},Axes->{True,False},Ticks->{ruler50,None},ImageSize->1000]

The differences form

Differences[ruler50]

The split form, splitting apart diffs and reps.

Transpose[{{1,1},{2,1},{3,1},{7,5},{4,2},{1,1}}]

Recipes

In 1963, B. Wichmann wrote “A Note on Restricted Difference Bases,” in which he(?) constructed many sparse rulers. The following code has his(?) original recipe and a function to read the recipe:

originalwichmannrecipe={
{1,1+r,1+2 r,3+4 r,2+2 r,1},{r,1,r,s,1+r,r}};

WichmannRuler[recipe_,{x_,y_}]:=Transpose[Select[Transpose[recipe/.Thread[{r,s}->{x,y}]],Min[#]>0&]]

With that, we can set up function (Subscript[W, 1]) for Wichmann recipe #1:

(Subscript[W, 1])[r_,s_]:=WichmannRuler[originalwichmannrecipe,{r,s}];

Here, r and s in the recipes are replaced by 1 and 5, respectively. These representations are examples of the split form of a sparse ruler:

Column[{(Subscript[W, 1])[1,5], (Subscript[W, 2])[1,5]}]

There are thousands of Wichmann-like recipes. Here’s the second:

WichmannRecipes[[2]]

(Subscript[W, 2])[r_,s_]:=WichmannRuler[WichmannRecipes[[2]],{r,s}];

Conversion routines

We can use these functions to convert among the three forms of sparse ruler:

DiffToRuler[diff_]:=FoldList[Plus,0,diff]

DiffToSplit[diff_]:= {First/@Split[diff], Length/@Split[diff]}

SplitToDiff[split_] := Flatten[Table[#[[1]],{#[[2]]}]&/@Transpose[split]]

SplitToRuler[split_]:=DiffToRuler[SplitToDiff[split]]

RulerToSplit[ruler_]:=DiffToSplit[Differences[ruler]]

Here are the diff forms for both (Subscript[W, 1]) and ruler50 from  above; we can see from their identical outputs that they are in fact the same ruler:

SplitToDiff[(Subscript[W, 1])[1,5]]

Differences[ruler50]

The diff form can be used to remake the ruler:

DiffToRuler[%]

Here is the split form again:

(Subscript[W, 1])[1,5]

The split form can be written compactly and compared to Wichmann’s recipe with r=1, s=5:

TraditionalForm@Grid[{HoldForm[((#1)^(#2))]&@@@First@*Tally/@Split@Differences[ruler50],
HoldForm[((#1)^(#2))]&@@@Transpose[originalwichmannrecipe]}, Frame-> All]

Small Wichmann Constructions

Wichmann rulers beyond length 50.

Text@Grid[{{"length","marks","recipe",Style["r", Italic],Style["s", Italic]},
 {50,12,"(1^1) (2^1) (3^1) (7^5) (4^2) (1^1)",1,5},{57,13,"(1^1) (2^1) (3^1) (7^6) (4^2) (1^1)",1,6},{57,13,"(1^2) (3^1) (5^2) (11^2) (6^3) (1^2)",2,2},{90,16,"(1^2) (3^1) (5^2) (11^5) (6^3) (1^2)",2,5},{93,17,"(1^3) (4^1) (7^3) (15^2) (8^4) (1^3)",3,2},{101,17,"(1^2) (3^1) (5^2) (11^6) (6^3) (1^2)",2,6},{108,18,"(1^3) (4^1) (7^3) (15^3) (8^4) (1^3)",3,3},{112,18,"(1^2) (3^1) (5^2) (11^7) (6^3) (1^2)",2,7},{123,19,"(1^2) (3^1) (5^2) (11^8) (6^3) (1^2)",2,8},{123,19,"(1^3) (4^1) (7^3) (15^4) (8^4) (1^3)",3,4},{138,20,"(1^3) (4^1) (7^3) (15^5) (8^4) (1^3)",3,5},{153,21,"(1^3) (4^1) (7^3) (15^6) (8^4) (1^3)",3,6},{168,22,"(1^3) (4^1) (7^3) (15^7) (8^4) (1^3)",3,7},{183,23,"(1^3) (4^1) (7^3) (15^8) (8^4) (1^3)",3,8},{198,24,"(1^3) (4^1) (7^3) (15^9) (8^4) (1^3)",3,9},{213,25,"(1^4) (5^1) (9^4) (19^6) (10^5) (1^4)",4,6}}]

The Last non-Wichmann Optimal Ruler?

(Subscript[M, 58])= 13. In 2011, Peter Luschny conjectured that the (Subscript[M, 58])=13 optimal ruler is the largest optimal ruler that does not use Wichmann’s recipe.

Text@Grid[Transpose[{{"split", "diff","ruler", "(Subscript[M, n])"},{#,SplitToDiff[#],
SplitToRuler[#],Length[SplitToRuler[#]]}&@sparsedata[[58]]}],Frame-> All]

rulerpic[ruler_, color_]:= Module[{size,diff},
size=Last[ruler]-First[ruler];
diff=Select[{#[[2]]-#[[1]],Mean[#]}&/@Partition[ruler,2,1],#[[1]]>2&];
Graphics[{Black,Rectangle[{First[ruler]-1/2,0},{Last[ruler]+1/2,4}],
color,Thick,Line[{{#,.3},{#,3.7}}]&/@ruler, Black,
White,Style[Text[#[[1]],{#[[2]]+.2,1.8}],30, Bold]&/@diff}, ImageSize->{3 2 2.9size,2 70}]];
rulerpic[{0,1,2,3,27,32,36,40,44,48,52,55,58}, Yellow]

⌈(Sqrt[3 n +9/4])⌋ -- I get involved

I just wanted a list of the results 2014 Robison results

Robison informs me that his results from running a large supercluster at Intel for months ... accidentally got deleted.

Number of marks, A046693, is still an unsolved sequence

ListPlot[Total[Last[#]]+1&/@Take[sparsedata,213], Joined-> True, AspectRatio-> 1/7]

I find ⌈(Sqrt[3 n +9/4])⌋from Wichmann rulers. Subtracting that from the optimal marks leads to a sequence of 0’s and 1’s.

(Total[Last[#]]+1&/@Take[sparsedata,213])-Table[Round[Sqrt[3 n+9/4]],{n,1,213}]

What is the pattern?

ArrayPlot[Transpose[Partition[(Total[Last[#]]+1&/@Take[sparsedata,800])-Table[Round[Sqrt[3 n+9/4]],{n,1,800}] ,20]],PixelConstrained->20]

Dark Mills on a Cloudy Day

Lets try the optimal Wichmann rulers as a floor.

Define excess (Subscript[E, n])=(Subscript[M, n])-⌈(Sqrt[3 n +9/4])⌋

E=0 values are gray.
E=1 values are bold black.

Grid[Append[Transpose[Table[PadLeft[Take[Style[If[rulerexcess[[#]]==1, 
Style[#,Black, Bold,30], Style[#,Gray,24]]]&/@Range[213],
{WichmannValues[[n]] + 1, WichmannValues[[n + 1]]}], 15, ""], {n, 24 - 1}]],Range[3,25]], Spacings->{.2, .2},Dividers->{False,-2-> Blue}]

Extending to 10501

Here is the excess pattern of the best-known excess values for lengths up to 10501. E=0 is gray, E=1 is black.

ArrayPlot[Transpose[Table[
PadLeft[First/@Take[Transpose[{Take[rulerexcess,10501],Range[10501]}],{WichmannValues[[n]]+1,WichmannValues[[n+1]]}],119,2],{n,1,175}]],ColorRules->{0->LightGray,1->Black,2->White},PixelConstrained->5,Frame->False]

Unique Solutions

Some solutions are hard to find. Here are a few lengths with unique solutions, so far as it is known. Results >213 are likely wrong.

unique = ;
hard = Select[unique, Length[#[[1]]]>6&];
Style[Grid[{Dot@@#,rulerexcess[[Dot@@#]],#}&/@hard],24]

Many E=1 solutions were very hard to find, particularly 1792.

difficult=;
Style[Grid[{Dot@@#,rulerexcess[[Dot@@#]],#}&/@difficult],24]

OEIS

Various sequences from OEIS:
A004137: maximal number of edges in a graceful graph on n nodes
A046693: minimal marks for a sparse ruler of length n
A103300: number of perfect rulers with length n
A289761: maximum length of an optimal Wichmann ruler with n marks.
A308766: lengths n of sparse rulers with excess 1
A309407: round(sqrt(3*n + 9/4))
A326499: excess E of a length-n sparse ruler

Wichmann-like Rulers

Manipulate[Module[{rule, rulelength, rulemarks,predictedsparse, valgrid, ruler,length, marks,ran,arrange,markslengths, excess, bestknown},
rule=WichmannRecipes[[index]];
rulemarks=WichmannMarks[rule];
rulelength=WichmannLength[rule];
markslengths={rulemarks, rulelength};
predictedsparse=Table[If[{j,k}=={r,s},3,Sign[(rulemarks-Round[ (Sqrt[3(rulelength)+9/4])])-1]+1],{r,0,18},{s,0,50}];
split=WichmannRuler[WichmannRecipes[[index]],{j,k}];
ruler=SplitToRuler[split];
excess=Sparseness[ruler];
length=Last[ruler];
bestknown=minimalSparse[[length]];
marks=Length[ruler];
ran=Flatten[(RandomSample[#,1]&/@GatherBy[Subsets[ruler,{2}],#[[2]]-#[[1]]&]),1];

Text@Column[{Style["rule",18],Style[TraditionalForm[Grid[rule, Frame-> All]],18],
Style[TraditionalForm@Grid[Transpose[{{"marks","length"},markslengths}],Frame-> All],18],
Style[Row[{Grid[Transpose[{{"excess","best known","marks","length"},{excess, bestknown, marks, length}}],Frame-> All],Spacer[10],ArrayPlot[predictedsparse,ColorRules->{0->White,1-> Black, 2->Cyan, 3-> Red}, PixelConstrained->True, ImageSize-> 220]}],18],
Spacer[{390,5}],
Graphics[{Tooltip[Line[{{#,1},{#,length/3} }],#]&/@ruler,
Style[Text[#,{#,1.02 length/3}],11]&/@RandomSample[ruler,Min[{15,marks}]]},ImageSize->{360,100}, AspectRatio-> 1/4],
Style["differences form",18],
Style[Differences[ruler],10],
Style["\nruler marks form",18],
Style[ruler,10]}, Alignment-> {Center}]],
{{markslengths,{3+4 r+s,3+8 r+4 (r^2)+3 s+4 r s}}, ControlType-> None},
{{split, {{1,2,3,7,4,1},{1,1,1,3,2,1}}}, ControlType-> None},
Row[{"pick recipe (",Dynamic[index] ,")"}],
{{index, 1, ""},1,383,1, ImageSize->Tiny},
Delimiter,
Row[{"variables (",Dynamic[j] ,",",Dynamic[k],")"}],
{{j,1,Style["r", Italic]},0,22,1, ImageSize->Tiny} ,
{{k,1,Style["s", Italic]},0,99,1, ImageSize->Tiny},
"split form",
Dynamic[Style[TraditionalForm@Grid[split,Frame-> All],9]],
Delimiter,
 TrackedSymbols:> {index,j,k}, ControlPlacement-> Left, ContentSize->{700, 500}, Alignment-> Top,SaveDefinitions->True]

Sparse Rulers Demonstration

coordinated=Table[Module[{xy},
xy=ExcessCoordinates[n];
{{,}[[rulerexcess[[n]]+1]],xy[[1]],{xy[[1,1]]/120, 1-xy[[2]]},xy[[3]]}],{n,1,2103}];
Manipulate[Module[{ruler,length, marks,ran,arrange, column},
SeedRandom[seed];
ruler=SplitToRuler[sparsedata[[pick]]];
length=Last[ruler];
marks=Length[ruler];
ran=Flatten[(RandomSample[#,1]&/@GatherBy[Subsets[ruler,{2}],#[[2]]-#[[1]]&]),1];
arrange=MapIndexed[Transpose[{#1, {#2[[1]],#2[[1]]}}]&,
Switch[method,"length",SortBy[ran,#[[2]]-#[[1]]&],"start",Sort[ran] ]];
column=Style[Text@Column[{"length",Last[ruler], "marks",Length[ruler], "excess",Length[ruler]-Round[ (Sqrt[3Last[ruler]+9/4])],"short\nform",Grid[Transpose[sparsedata[[pick]]],Frame->All],
"excess\nfraction", ExcessCoordinates[pick][[2]]}, Alignment-> Center],16];
If[grid===Framed["show grid"],
Column[{Graphics[{{#[[1]], Rectangle[#[[2]]]}&/@coordinated, Red,Thick, Circle[ExcessCoordinates[pick][[1]]+1/2,1]}, ImageSize->{580,400},Epilog->Inset[column,{5,30}]],
Text@Row[{," excess 0" ,Spacer[30],," excess 1"}]},Alignment-> Center],
Row[{Graphics[{{Thickness[.007],Hue[{#[[2,1]]-#[[1,1]]}/length],Line[#]}&/@arrange,
Tooltip[Line[{{#,1},{#,length} }],#]&/@ruler,
Style[Text[#,{#,1.02 length}],11]&/@RandomSample[ruler,Min[{15,marks}]]},ImageSize->{450,450}],column }]]],
Row[{Control@{{pick,58,"pick length"},3,2103,1,Appearance-> "Labeled", ImageSize-> Tiny},Spacer[10],
Control@{{method,"length","sort by"},{"length","start"}},Spacer[20],
Control@{{seed,28,"random seed"},1,999999,1,ImageSize-> Tiny},Spacer[20],
Control@{{grid,Framed["show ruler"],""},{Framed["show ruler"],Framed["show grid"]},ImageSize-> Tiny, ControlType->Toggler}}],
SaveDefinitions-> True, ContentSize->{820, 480}, Alignment-> Center, SynchronousInitialization->False, SynchronousUpdating->False,
TrackedSymbols:>{pick,method,seed, grid}]

Wichmann Columns -- just add a mark

({{1, r+1, 2 r+1, 4 r+3, 2 r+2, 1}, {r, 1, r, s, r+1, r}}) is the split form of Wichmann recipe 1, or (Subscript[W, 1]).

({{1, 3, 5, 11, 6, 1}, {2, 1, 2, 3, 3, 2}}) is (Subscript[W, 1]), r=2, s=3:

({{1, 3, 5, 11, 6, 1, 3}, {2, 1, 2, 3, 3, 2, 1}}) is an extension.

The “Wichmann Columns” Demonstration generates a column in the excess pattern by using only sparse rulers made by the first two Wichmann recipes, (Subscript[W, 1]) and (Subscript[W, 2]), and extensions of these rulers.
 indicates that a sparse ruler cannot be generated by (Subscript[W, 1]), (Subscript[W, 2]) or by extending them.
 indicates a generated sparse ruler with excess 0.
 indicates a generated sparse ruler with excess 1.

sixsev=Drop[Flatten[Table[Table[{Table[6,{n}],7},{6}],{n,0,cutoff}]],1];
sixfiv=Drop[Flatten[Table[Table[{Table[6,{n}],5},{6}],{n,0,cutoff}]],2];
sixsevfold=FoldList[Plus,9,sixsev];
sixfivfold=FoldList[Plus,5,sixfiv];
range=Join[{0,0,0,0,0,0},#]&/@{
FoldList[Plus,1,ReplacePart[Table[0,{Last[sixsevfold]}],Thread[sixsevfold-> 1]]],
FoldList[Plus,1,ReplacePart[Table[0,{Last[sixfivfold]}],Thread[sixfivfold-> 1]]],
FoldList[Plus,0,ReplacePart[Table[1,{Last[sixsevfold]}],Thread[sixsevfold-> -3]]],
FoldList[Plus,0,ReplacePart[Table[1,{Last[sixfivfold]}],Thread[sixfivfold-> -3]]]};
WRCZ[index_]:=Transpose[{Range[range[[1,index]],range[[2,index]]],Range[range[[3,index]],range[[4,index]],-4]}];

WichmannColumn[marks_]:= Module[{prep, wcr, incolumn, missing,optimal, covered, column},
prep=Prepend[(Subscript[W, 1])@@#&/@WRCZ[marks],Last[SortBy[(Subscript[W, 1])@@#&/@WRCZ[marks-1],Dot@@#&]]];wcr=WichmannColumnRange[marks-1];incolumn=SortBy[Union[Select[Join[Flatten[SplitExtensions/@prep,1],prep, (Subscript[W, 2])@@#&/@WRCZ[marks]],wcr[[1]]≤ Dot@@#≤ wcr[[2]]&]],Dot@@#&];missing={#,{"missing"}}&/@Complement[Range@@wcr,Dot@@#&/@incolumn];
optimal=First[SplitBy[SortBy[#, Total[#[[2]]]&], Total[#[[2]]]&]]&/@SplitBy[incolumn,Dot@@#&];
covered={Dot@@#[[1]],#}&/@optimal;
column=Sort[Join[missing,covered]];
Text@Column[{Row[{"rulers of length ",wcr[[1]]," + ", Style["x", Italic]}],
Row[Join[{Style["x", Italic], " = "}, Riffle[
Tooltip[Style[#[[1]]-wcr[[1]],If[#[[2]]==={"missing"},Red,If[Total[#[[2,1,2]]]+1==marks,Blue, Darker@Green]], 14],
 Column[Prepend[#[[2]],#[[1]]]]]&/@column,Style[" ",10]]]]}]];Manipulate[WichmannColumn[marks],{{marks, 99},7, 900,1, Appearance-> "Labeled"}, SaveDefinitions-> True, ContentSize->{900, 460}]

Proof Outline for (Subscript[E, n])=(Subscript[M, n])-⌈(Sqrt[3 n +9/4])⌋, (Subscript[E, n])≤1

Big values are easy.

Solve small values.

Done!

(Subscript[E, n])=(Subscript[M, n])-⌈(Sqrt[3 n +9/4])⌋. Can (Subscript[E, n])=-1?

Haven’t proved it impossible.

Seems unlikely. All sparse rulers can be modified to make new rulers of greater or smaller length.

If such a ruler exists, the smallest has length>213

2966038 Sparse Rulers

{{1,24,5,4,3},{3,1,1,5,2}} -- Last known non-Wichmann optimal

Row[{Dot@@{{1,24,5,4,3},{3,1,1,5,2}},Spacer[10],rulerpic[SplitToRuler[{{1,24,5,4,3},{3,1,1,5,2}}], Green]}]

{{1,9,8},{7,6,1}}-- last known 3-diff sparse ruler

Row[{Dot@@{{1,9,8},{7,6,1}},Spacer[10],rulerpic[SplitToRuler[{{1,9,8},{7,6,1}}], Green]}]

Last with greatest difference 12:

Row[{Dot@@{{1,3,1,5,12,7,1,6,2,7,2},{1,1,1,1,12,1,1,1,1,1,2}},Spacer[10],rulerpic[SplitToRuler[{{1,3,1,5,12,7,1,6,2,7,2},{1,1,1,1,12,1,1,1,1,1,2}}], Green]}]

{{1,62,4,62,4,5,1,5},{4,1,4,1,2,10,2,1}} -- last known with just 4 differences

Row[{Dot@@{{1,62,4,62,4,5,1,5},{4,1,4,1,2,10,2,1}},Spacer[10],rulerpic[SplitToRuler[{{1,62,4,62,4,5,1,5},{4,1,4,1,2,10,2,1}}], Green]}]

{{1,124,5,8,3},{7,1,3,13,4}} -- last known 5-diff setup

Row[{Dot@@{{1,124,5,8,3},{7,1,3,13,4}},Spacer[10],rulerpic[SplitToRuler[{{1,124,5,8,3},{7,1,3,13,4}}], Green]}]

{{1,6,7,4,12,4,12,4,12,4,12,4,12,4,12,4,5,10,7,2,113,2,1,2,3,2,1,2},
{1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1}}-- last known without adjacent repeats

Row[{Dot@@{{1,6,7,4,12,4,12,4,12,4,12,4,12,4,12,4,5,10,7,2,113,2,1,2,3,2,1,2},{1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1}},Spacer[10],rulerpic[SplitToRuler[{{1,6,7,4,12,4,12,4,12,4,12,4,12,4,12,4,5,10,7,2,113,2,1,2,3,2,1,2},{1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1}}], Green]}]

{{1,7,1,246,6,16,1,6,1,7,13,6,24,6},{5,2,5,1,2,1,1,1,1,1,17,2,1,2}} -- last known large gap sparse ruler

(RowDefault[582, (Spacer1), ])

Thank You

Initialization

rulerexcess=(*To 17553*) ;
oldrulerexcess=(*To 17553*);
counts=;
sparsedata=Uncompress[Normal[]];
WichmannRecipes=;
WichmannRecipesextra=;
perfectcounts={1,1,1,2,2,1,6,4,2,19,15,7,3,65,40,16,6,250,163,75,33,9,2,472,230,83,28,6,3,1018,445,152,60,10,5,1,1339,487,181,50,18,2,1,2446,1057,342,119,34,11,2,8159,3175,1143,418,165,54,12,6,15990,6126,2480,903,334,119,43,3,6,2,7779,2953,1279,425,194,60,19,2,3,2,1,2486,1117,399,166,53,24,2,3,1,1,1,1696,631,313,106,38,20,8,1,1,1,1,1713,753,341,180,69,35,14,4,1,1,1,3289,1492,729,293,187,96,49,19,7,2,2,8679,4236,2090,1074,490,255,130,90,46,16,4,0,0,1,1,2451,1209,724,327,189,96,55,14,5,3,0,0,0,1,1,1341,663,397,197,80,36,11,4,3,1,0,0,0,1,1,1047,494,258,123,72,23,11,4,1,1,0,0,0,1,1,1084,448,231,115,64,40,34,13,2,2,1,0,0,1,1,0,0,0,0,0,0,0,0,0,11,0,0,0,2,2};
minimalSparse=Table[Round[ (Sqrt[3n+9/4])]+rulerexcess[[n]],{n,1,17553}];
zeroperfect=Flatten[Position[perfectcounts,0]];
completestatus=Table[If[MemberQ[zeroperfect,n],Sequence@@{},{n,perfectcounts[[n]]-counts[[n]], perfectcounts[[n]]}],{n,1,213}];
complete=First/@Select[completestatus,#[[2]]==0&];

DiffToRuler[diff_]:=FoldList[Plus,0,diff];
DiffToSplit[diff_]:= {First/@Split[diff], Length/@Split[diff]};
SplitToDiff[split_] := Flatten[Table[#[[1]],{#[[2]]}]&/@Transpose[split]];
SplitToRuler[split_]:=  DiffToRuler[SplitToDiff[split]];
RulerToSplit[ruler_]:= DiffToSplit[Differences[ruler]];
WichmannRuler[recipe_,{x_,y_}]:=Transpose[Select[Transpose[recipe/.Thread[{r,s}->{x,y}]],Min[#]>0&]];WichmannRulerExtended[recipe_,{x_,y_}]:=Module[{split},
split=Transpose[Select[Transpose[recipe/.Thread[{r,s}->{x,y}]],Min[#]>0&]];
{split, {Sparseness[SplitToRuler[split]],Total[Last[split]]+1, Dot@@split}}];
WichmannValues=Table[(n^2-(Mod[n,6]-3)^2)/3+n,{n,1,228}];
WichmannMarks[recipe_]:=Total[Last/@Transpose[recipe]]+1;
WichmannLength[recipe_]:= Expand[Simplify[Total[Times@@#&/@Transpose[recipe]]]];
polywich={WichmannLength[#],WichmannMarks[#]}&/@WichmannRecipes;
FindWichmann[length_] := Take[SplitBy[
SortBy[Flatten[With[{sols=#[[1]], ruleindex=#[[2]]}, 
Table[{ruleindex,(polywich[[ruleindex,2]]/.Thread[{r,s}->
sols[[n]]])-Round[Sqrt[3 length+9/4]], sols[[n]]},{n,1,Length[sols]}]]&/@({{r,s}/.#[[1]], #[[2]]}&/@
Select[Table[{Solve[polywich[[k,1]]==length&&r≥0&&s≥0,{r,s},Integers], k},{k,1,382}],Length[#[[1]]]>0&]),1],#[[2]]&],#[[2]]&], UpTo[2]];
LeechBound[length_]:= Floor[Sqrt[3.348 length]- Round[Sqrt[3 length +9/4]]];
drop[diff_]:= Complement[Union[SparseCheck[DiffToRuler[#]]&/@
Union[Table[Drop[diff,{k}],{k,2,Length[diff]}]]],{False}];
tweak[diff_]:= Complement[Union[Flatten[
Table[Union[SparseCheck[DiffToRuler[#]]&/@Table[ReplacePart[diff,k-> diff[[k]]+n],{k,2,Length[diff]}]],{n,1,25}],1]],{False}];add[diff_]:= Complement[Union[Flatten[
Table[Union[SparseCheck[DiffToRuler[#]]&/@Table[Flatten[ReplacePart[diff,k-> {diff[[k]],n}]],{k,2,Length[diff]}]],{n,1,25}],1]],{False}];
rulerFlop[ruler_] := Module[{dif,len},
dif= Append[Differences[ruler],0];
len=Length[dif];
Complement[SparseCheck[DiffToRuler[Drop[Join[Take[dif,#[[1]]-1],Reverse[Take[dif,#]],Take[dif,{#[[2]]+1,len}]],-1]]]&/@Subsets[Range[2,len-1],{2}],{ruler, False}]];
SparseCheck[ruler_]:=(Min[ruler]==0&&17553≥ Last[ruler]≥1&&Length[ruler]-Round[ (Sqrt[3Last[ruler]+9/4])]≤ rulerexcess[[Max[ruler]]]&&(Complement[Range[Last[ruler]],#[[2]]-#[[1]]&/@Subsets[ruler,{2}]]=={}))&&First[Sort[{Sort[ruler], Sort[Max[ruler]-ruler]}]];
Sparseness[ruler_]:=Module[{sort,length,marks, missing},
sort=Union[ruler]-Min[ruler];
length=Max[sort];
marks=Length[sort];
missing=Complement[Range[length],#[[2]]-#[[1]]&/@Subsets[sort,{2}]];
If[Length[missing]>0,missing,marks-Round[ (Sqrt[3length+9/4])]]];
rulersurgeryequal[ruler_] := Module[{removable,base,rad, int,keep},
removable=Select[First/@Take[SortBy[Tally[Sort[Flatten[{Select[
GatherBy[Subsets[ruler,{2}],Differences],Length[#]==1&],ruler}]]],Last],7],Not[MemberQ[{0,Last[ruler]},#]]&];
base=Complement[ruler,{#}]&/@removable;
rad=Sparseness/@base;
keep={};
Do[If[IntegerQ[rad[[p]]],
keep=Join[keep,{ base[[p]]}],
int=Complement[Select[Intersection@@(Join[base[[p]]+#,base[[p]]-#]&/@rad[[p]]), 0<#<Last[ruler]&],ruler];
keep=Join[keep,Sort[Append[base[[p]],#]]&/@int]
],{p,1,Length[rad]}];
keep];
cleanSplit[split_]:=RulerToSplit[First[Sort[{Sort[#], Sort[Max[#]-#]}]]&@SplitToRuler[split]];
gracefulCount[list_]:=Times@@(Length/@GatherBy[Subsets[list,{2}],#[[2]]-#[[1]]&]);
WichmannDisplay[recipe_,{x_,y_}]:=Module[{split,length, marks, sparseness},
split=Transpose[Select[Transpose[recipe/.Thread[{r,s}-> {x,y}]],Min[#]>0&]];
length=WichmannLength[recipe]/.Thread[{r,s}-> {x,y}];
marks=WichmannMarks[recipe]/.Thread[{r,s}-> {x,y}];
sparseness=marks-Round[ (Sqrt[3length+9/4])];
Column[{Grid[split, Frame-> All], Grid[{{"excess", "marks", "length"},{sparseness,marks, length}}, Frame-> All]}, Alignment->Center]];
evalruler[{one_,two_},length_]:=Complement[Range[length],Union[Abs[Subtract@@@Subsets[Join[one,length-two],{2}]]]];
scrunch[{avail_,missing_, width_,{one_,two_},longestmiss_, length_}]:=
 Module[{wide,r2,e2,r3,e3,r4,e4,pass, marks, cases},
wide=width+1;
marks=minimalSparse[[length]];
r2={Append[one, width+1],two};
 e2=evalruler[r2,length];
r3={one,Prepend[two, width+1]}; e3=evalruler[r3,length];
r4={Append[one, width+1],Prepend[two, width+1]}; e4=evalruler[r4,length];
cases={
{avail,missing, wide,{one,two},longestmiss, length},
{avail-1,Length[e2], wide,r2,If[Length[e2]>0,Last[e2],0], length},
{avail-1,Length[e3], wide,r3,If[Length[e3]>0,Last[e3],0],length},
{avail-2,Length[e4], wide,r4,If[Length[e4]>0,Last[e4],0], length}};
pass=Select[cases,Take[#,2]=={0,0}||(With[{av=#[[1]], u=#[[2]]},u<=av*(av-1)/2+av*(marks-av)]&&wide+#[[5]]<length)&];
pass];
predictrule[rule_] := Module[{rulemarks, rulelength},
rulemarks=WichmannMarks[rule];
rulelength=WichmannLength[rule];
Sort[Select[Flatten[Table[{rulemarks-Round[ (Sqrt[3(rulelength)+9/4])],rulelength,{r,s}},{r,1,35},{s,1,180}],1],(0≤ #[[1]]≤ 10)&& (#[[2]]≤17553)&&rulerexcess[[#[[2]]]]≥ #[[1]]&]]];
GracefulGraphFromPermutation[perm_List] := Module[{edges, verts}, edges = MapIndexed[{#1, #1 + #2[[1]]} & , Flatten[Table[Position[Sort[Drop[perm, n - 1]], perm[[n]]] - 1, {n, 1, Length[perm]}]]]; verts = Union[Flatten[edges]]; Graph[(UndirectedEdge[#1[[1]], #1[[2]]] & ) /@ edges, EdgeLabels -> (UndirectedEdge[#1[[1]], #1[[2]]] -> Style[ToString[#1[[2]] - #1[[1]]], 16] & ) /@ edges, 
EdgeStyle -> (UndirectedEdge[#1[[1]], #1[[2]]] -> {Thick,Hue[(#1[[2]] - #1[[1]])/Max[perm]]} & ) /@ edges,
VertexSize -> 0.4, VertexStyle -> Lighter[LightCyan], VertexLabels -> (#1 -> Placed[Style[#1, 14, Red], Center] & ) /@ verts, ImagePadding -> 10, ImageSize -> {500, 400}]];
ExcessCoordinates[length_]:=Module[{column,wichmannvalues,wichdiffs, height, rise},
column= Round[(Sqrt[3 length+9/4])];
wichmannvalues= Table[(n^2-(Mod[n,6]-3)^2)/3+n,{n,column-2, column+1}];
wichdiffs=Differences[wichmannvalues];
If[wichmannvalues[[2]]≥length,
height=wichmannvalues[[2]]-length;
rise= wichdiffs[[1]],
height=wichmannvalues[[3]]-length;
column=column+1;
rise= wichdiffs[[2]]];
{{column,height},1-(height+1)/(rise+1), rise}];

cutoff=15;  (*raise the cutoff to go farther*)
sixsev=Drop[Flatten[Table[Table[{Table[6,{n}],7},{6}],{n,0,cutoff}]],1];
sixfiv=Drop[Flatten[Table[Table[{Table[6,{n}],5},{6}],{n,0,cutoff}]],2];
sixsevfold=FoldList[Plus,9,sixsev];
sixfivfold=FoldList[Plus,5,sixfiv];
range=Join[{0,0,0,0,0,0},#]&/@{
FoldList[Plus,1,ReplacePart[Table[0,{Last[sixsevfold]}],Thread[sixsevfold-> 1]]],
FoldList[Plus,1,ReplacePart[Table[0,{Last[sixfivfold]}],Thread[sixfivfold-> 1]]],
FoldList[Plus,0,ReplacePart[Table[1,{Last[sixsevfold]}],Thread[sixsevfold-> -3]]],
FoldList[Plus,0,ReplacePart[Table[1,{Last[sixfivfold]}],Thread[sixfivfold-> -3]]]};
WRCZ[index_]:=Transpose[{Range[range[[1,index]],range[[2,index]]],Range[range[[3,index]],range[[4,index]],-4]}];

(Subscript[W, 1])[r_,s_]:={{1,1+r,1+2 r,3+4 r,2+2 r,1},{r,1,r,s,1+r,r}};
(Subscript[W, 2])[r_,s_]:={{1,1+r,1+2 r,3+4 r,2+2 r,1},{r,1,1+r,s,r,r}};
WichmannColumnRange[n_]={((n-1)^2-(Mod[(n-1),6]-3)^2)/3+(n-1)+1, (n^2-(Mod[n,6]-3)^2)/3+n};
SplitExtensions[split_]:=Table[Transpose[Append[Transpose[split],{k,1}]],{k,1,split[[2,1]]+1}];
WichmannColumn[marks_]:= Module[{prep, wcr, incolumn, missing,optimal, covered, column},
prep=Prepend[(Subscript[W, 1])@@#&/@WRCZ[marks],Last[SortBy[(Subscript[W, 1])@@#&/@WRCZ[marks-1],Dot@@#&]]];wcr=WichmannColumnRange[marks-1];incolumn=SortBy[Union[Select[Join[Flatten[SplitExtensions/@prep,1],prep, (Subscript[W, 2])@@#&/@WRCZ[marks]],wcr[[1]]≤ Dot@@#≤ wcr[[2]]&]],Dot@@#&];missing={#,{"missing"}}&/@Complement[Range@@wcr,Dot@@#&/@incolumn];
optimal=First[SplitBy[SortBy[#, Total[#[[2]]]&], Total[#[[2]]]&]]&/@SplitBy[incolumn,Dot@@#&];
covered={Dot@@#[[1]],#}&/@optimal;
column=Sort[Join[missing,covered]];
Text@Column[{Tooltip[Style[wcr[[2]]-#[[1]],
If[#[[2]]==={"missing"},Red,If[Total[#[[2,1,2]]]+1==marks,Blue, Darker@Green]], 14],
 Column[Prepend[#[[2]],#[[1]]]]]&/@column,Row[{"rulers of length ",wcr[[2]]," - ", Style["x", Italic]}]}]];