Hexadecagon bracing using just over four rational strips per constraint. The 13 edges of length
7
are to be replaced with rational triangles (which by a suitable choice of side lengths and measurement points can brace the square root of any rational number):
In[]:=
cSignAbs[z_]:=If[Denominator[Rationalize[Abs[z],10^-6]]>30∧RootReduce[Abs[z]]!=Sqrt[7],{π,π},With[{Rz=RootReduce[Re[z]],Iz=RootReduce[Im[z]]},RootReduce[{Sign[z],Abs[z]}If[Rz>0∨(Rz==0∧Iz>0),1,-1]]]]
In[]:=
ratgraph[verts_]:=Module[{n=Length[verts],G,vrange,vects,nedge,rods={}},​​G=Graph[Range[n],{},VertexCoordinates->ReIm/@verts];​​Do[​​vrange=Select[Range[i+1,n],Function[j,NoneTrue[rods,SubsetQ[#,{i,j}]&]]];​​vects=Table[Append[cSignAbs[verts[[j]]-verts[[i]]],j],{j,vrange}];​​vects=Select[vects,#[[2]]^2∈Rationals&];​​vects=SortBy[Append[#[[All,2;;]],{0,i}],First]&/@GatherBy[vects,First];​​Do[​​Do[​​nedge=UndirectedEdge@@pair[[All,2]];​​G=EdgeAdd[G,nedge];​​AnnotationValue[{G,nedge},EdgeLabels]=Abs[Subtract@@pair[[All,1]]];​​AnnotationValue[{G,nedge},EdgeWeight]=Length[rods],​​{pair,Partition[rod,2,1]}];​​AppendTo[rods,rod[[All,2]]],​​{rod,vects}],​​{i,n-1}];​​G]
In[]:=
circlepoints[n_]:=FoldList[Plus,0,Exp[2IRange[0,n-2]Pi/n]]
In[]:=
linterp[a_,b_,t_]:=a(1-t)+bt
In[]:=
outer=circlepoints[16];
In[]:=
extra=-
2
3
,
5
3
,
1
2
+
7
8
,-1+2,2+2;
In[]:=
B16a=ratgraph[Most[Join[outer,Flatten[Table[extraExp[IkPi/4]+outer[[Mod[2k,16]+1]],{k,-3,3}]]]]];
In[]:=
B16=EdgeDelete[B16a,Cases[AnnotationValue[B16a,EdgeLabels],(x_->3)->x]]
Out[]=
In[]:=
CountDistinct[AnnotationValue[B16,EdgeWeight]]-16+2×13
Out[]=
53
However, if “rational” means lying in
Q(
2
)
, the simple butterfly bracing works again:
In[]:=
cSignAbs2[z_]:=With[{Az=RootReduce[Abs[z]],Rz=RootReduce[Re[z]],Iz=RootReduce[Im[z]]},If[FreeQ[Az,Root],RootReduce[{Sign[z],Az}If[Rz>0∨(Rz==0∧Iz>0),1,-1]],{0,Root}]]
In[]:=
ratgraph2[verts_]:=Module[{n=Length[verts],G,vrange,vects,nedge,rods={}},​​G=Graph[Range[n],{},VertexCoordinates->ReIm/@verts];​​Do[​​vrange=Select[Range[i+1,n],Function[j,NoneTrue[rods,SubsetQ[#,{i,j}]&]]];​​vects=Table[Append[cSignAbs2[verts[[j]]-verts[[i]]],j],{j,vrange}];​​vects=Select[vects,FreeQ[#[[2]],Root]&];​​vects=SortBy[Append[#[[All,2;;]],{0,i}],First]&/@GatherBy[vects,First];​​Do[​​Do[​​nedge=UndirectedEdge@@pair[[All,2]];​​G=EdgeAdd[G,nedge];​​AnnotationValue[{G,nedge},EdgeLabels]=Abs[Subtract@@pair[[All,1]]];​​AnnotationValue[{G,nedge},EdgeWeight]=Length[rods],​​{pair,Partition[rod,2,1]}];​​AppendTo[rods,rod[[All,2]]],​​{rod,vects}],​​{i,n-1}];​​G]
In[]:=
butterfly[{p1_,p2_,p3_,p4_},a_,b_]:={linterp[p2,p1,a],linterp[p3,p4,b],linterp[p2,p1,b],linterp[p3,p4,a]}
In[]:=
ratgraph2[Join[outer,Flatten[Table[butterfly[outer[[1+2k;;4+2k]],-2,2],{k,0,6}]]][[;;-3]]]
Out[]=