Narayama’s Cow and Other Algebraic Numbers

Ed Pegg Jr, Wolfram Research
edp@wolfram.com

Join the Conversation #WolframTechConf

ABSTRACT

Algebraic roots can build fractals, self-similar tilings, optimal Heilbronn placements, 3-in-a-row records and graphs with interesting properties. 

1. Consider an object with geometric constraints.
2. Two points are at (0,0) and (1,0).  
3. Where are the other points?

The Exoo-Ismailescu unit-distance graph is a difficult example.

With[{vveecc=Normal[]},With[{vv=vveecc[[1]], ee=vveecc[[2]],cc=vveecc[[3]]},
Graphics[{Thick,Table[{cc[[n]],Table[Line[vv[[ee[[n,k]]]]],{k,1,Length[ee[[n]]]}] },{n,1,8}], EdgeForm[Black],White,Table[{Disk[vv[[n]],.05],Black,Text[n,vv[[n]]]}, {n,1,Length[vv]}]}, ImageSize-> Large]]]

Number Field? What’s that?

Consider the vertices of the Golomb graph, where all edges have a length of exactly one (unit-distance graph); the graph has chromatic number 4.

golombvertices =GraphData["GolombGraph","VertexCoordinates"];Row[{Graph[GraphData["GolombGraph"],VertexLabels->"Name",ImageSize-> Medium], Style[Text[Grid[Transpose[{Range[10],N[golombvertices],golombvertices}],Frame->All]],16]}]

The Root object can be expressed as an algebraic number if (Sqrt[33])is used via ToNumberField[].

ToNumberField[Root[1-63 ((#1)^2)+324 ((#1)^4)&,1], (Sqrt[33])]

… if you square the root object.

ToNumberField[Root[1-63 ((#1)^2)+324 ((#1)^4)&,1]^2, (Sqrt[33])]

The pair {(7/72),(1/72)} can represent the value in the number field F[(Sqrt[33])], if you take the square root.

RootReduce[Sqrt[({(7/72),(1/72)}.(Sqrt[33])^{0,1})]]

I first noticed the utility of squaring geometric values when trying to simplify the coordinates of Zak’s triangle, which I’ll mention again later. All of the vertices of the triangle were simple triples based on the plastic constant… if I squared everything. The pairs of triples were coordinates in an number field… if I took the square root. The leftover numbers were 0 and 1, and it was easy to make triples for those: {0,0,0} and {1,0,0}.

zak={{Root[1-3 #1+2 ((#1)^2)+((#1)^3)&,1],0},{Root[-1+4 #1-5 ((#1)^2)+((#1)^3)&,1],0},{Root[-1+2 #1-8 ((#1)^2)+8 ((#1)^3)&,1],Root[-43+52 ((#1)^2)-416 ((#1)^4)+64 ((#1)^6)&,2]},{0,0},{Root[-5+16 #1-20 ((#1)^2)+8 ((#1)^3)&,1],Root[-43-72 ((#1)^2)+16 ((#1)^4)+64 ((#1)^6)&,2]},{1,0},{Root[-1-4 #1-20 ((#1)^2)+8 ((#1)^3)&,1],Root[-43-72 ((#1)^2)+16 ((#1)^4)+64 ((#1)^6)&,2]}};
Partition[ToNumberField[#^2, Root[-1-#1+((#1)^3)&,1]]&/@Flatten[zak],2]

So I developed these two functions to handle explorations of (Sqrt[number fields]).

ToSqrtSpace[root_,coord_] := Module[{ρ, dim, order,algebraic, converted},
dim=Dimensions[coord];
order={1,2}.NumberFieldSignature[root];
algebraic= Map[Function[x,ToNumberField[Sign[x]RootReduce[x^2], root]],coord,{Length[dim]-1} ];
Map[Function[x,If[Head[x]===AlgebraicNumber,Last[x],PadRight[{x},order]]],algebraic,{Length[dim]} ]];

FromSqrtSpace[root_,coord_]:= Module[{ dim, degree, vector},
dim=Dimensions[coord];
degree={1,2}.NumberFieldSignature[root];
vector =(root^Range[0,degree-1]);
Map[With[{k=(#).vector},RootReduce[Sign[k](Sqrt[Abs[k]])]]&,coord,{Length[dim]-1}]]

For many diagrams, coordinates can be chosen to be in a number field.

golombalgebraic=ToSqrtSpace[(Sqrt[33]),golombvertices]

FromSqrtSpace[(Sqrt[33]),golombalgebraic]

Hovering shows the algebraic coordinates.

unitlines=Select[Subsets[golombvertices,{2}],Function[x,Chop[N[1-Apply[EuclideanDistance,x]]]==0]];
Graphics[{EdgeForm[{Black}],Line[unitlines],White,
Table[Tooltip[ Disk[golombvertices[[n]],.06],golombalgebraic[[n]]],{n,1,Length[golombvertices]}]}, ImageSize-> Large]

Fibonacci’s Rabbit Problem (1202)
Δ=5: (ϕ^2)-ϕ-1=0 (ϕ≈1.61803…)

Fibonacci proposed a problem with rabbits.

His Liber Abaci also proposed Arabic numerals.

The rabbit problem leads to the Fibonacci sequence.

The convergents of the continued fraction for the golden ratio ϕ are successive ratios of the Fibonacci sequence.

Fibonacci[Range[14]]
LinearRecurrence[{1,1},{1,1},14]
Convergents[GoldenRatio,14]

Many polyhedra use a ϕ number field.

Manipulate[Graphics3D[Table[{Polygon[polygolden[[polyhere]].icosahedralgroup[[n]]]},{n,1,60}], Boxed-> False, ImageSize-> Medium, SphericalRegion-> True],{{polyhere,5,"polyhedron"},Thread[ Range[8]-> {"Icosahedron", "PentakisDodecahedron", "TriakisIcosahedron", "CumulatedDodecahedron", "RhombicHexecontahedron",
"TetrahedronFiveCompound","Dodecahedron","DeltoidalHexecontahedron"}]},
Initialization:>(ϕ=(1/2) (1+(Sqrt[5]));fromSqrtSpace[vals_, level_]:=Map[Function[x,RootReduce[Sign[x.{1,ϕ}](Sqrt[Abs[(x).{1,ϕ}]])]],vals, {level}];
polygolden=fromSqrtSpace[{{{{1,1},{-1,0},{0,0}},{{1,0},{0,0},{1,1}},{{0,0},{-1,-1},{1,0}}},
{{{0,0},{9,9},{9,0}},{{-61,35},{17,8},{0,0}},{{61,-35},{17,8},{0,0}}},
{{{0,0},{121,121},{121,0}},{{0,0},{121,121},{-121,0}},{{-65,15},{85,120},{0,0}}},
{{{25,0},{50,75},{0,0}},{{-25,0},{50,75},{0,0}},{{0,0},{65,80},{-50,-15}}},
{{{0,0},{1,1},{-1,0}},{{0,0},{4,4},{0,0}},{{-1,-1},{5,8},{0,0}},{{-1,-1},{2,3},{-1,0}}},{{{2,-1},{-1,-1},{0,0}},{{5,-3},{-20,12},{-2,1}},{{0,0},{-2,1},{-5,3}},{{13,-8},{-1,0},{-13,8}},{{-13,8},{-1,0},{13,-8}}},{{{0,0},{17,-7},{13,16}},{{10,3},{10,3},{10,3}},{{13,16},{0,0},{17,-7}},{{10,3},{-10,-3},{10,3}},{{0,0},{-17,7},{13,16}}},{{{0,0},{0,0},{1,0}},{{0,0},{(10/121),(3/121)},{(29/121),(45/121)}},{{(1/2),-(1/4)},{(1/4),0},{(1/4),(1/4)}},{{(1/9),(1/9)},{0,0},{(2/9),(1/3)}}}}, 2];
icosahedralgroup =2fromSqrtSpace[Normal[], 2];)]

The Ammann chair, a polygon that can be divided into similar copies of itself, is in ϕ-space. Sides of the Ammann chair are consecutive powers of (Sqrt[ϕ]). It is a rep-tile fractal.

vals={{{0,1},{2,3}},{{0,1},{1,1}},{{0,0},{1,1}},{{0,0},{0,0}},{{3,5},{0,0}},{{3,5},{2,3}},{{0,0},{5,8}},{{1,2},{5,8}},{{1,2},{2,3}}};
 points=Map[Function[x,RootReduce[Sign[x.{1,ϕ}](Sqrt[Abs[(x).{1,ϕ}]])]],vals, {2}];
powerlines={{-1,{1,9}},{0,{1,2}},{1,{2,3}},{1,{2,9}},{2,{1,3}},{2,{3,4}},{2,{8,9}},{3,{1,6}},{3,{1,7}},{3,{2,4}},{3,{7,8}},{4,{2,5}},{4,{3,7}},{4,{5,6}},{4,{7,9}},{5,{1,5}},{5,{3,8}},{5,{4,5}},{6,{4,6}}};
Graphics[{EdgeForm[{Blue, Thick}],White, Polygon[Take[points,6]],Polygon[Drop[points,{4,6}]],Darker[Cyan],Table[{Line[points[[powerlines[[n,2]]]]],
 Style[Text[powerlines[[n,1]],Mean[points[[powerlines[[n,2]]]]]],24, Black]},{n,1,Length[powerlines]}], White,Table[Tooltip[Disk[points[[n]],.1], vals[[n]]],{n,1,Length[points]}]}, ImageSize-> Medium]

For 16 lines of 4-in-a-row on 15 points, use ϕ-space.

vals={{{0,0},{4,0}},{{3,-1},{-1,-1}},{{-3,1},{-1,-1}},{{-2,-1},{2,-1}},{{2,1},{2,-1}},{{-18,11},{2,-1}},{{18,-11},{2,-1}},{{7,-4},{-13,8}},{{-7,4},{-13,8}},{{0,0},{-20,12}},{{-47,29},{89,-55}},{{47,-29},{89,-55}},{{123,-76},{-13,8}},{{-123,76},{-13,8}},{{0,0},{136,-84}},{{0,0},{0,0}}}/4;lines={{1,2,7,8},{1,3,6,9},{1,10,15,16},{2,4,9,10},{2,6,13,16},{3,5,8,10},{3,7,14,16},{4,5,6,7},{4,8,11,16},{5,9,12,16},{6,8,12,15},{6,10,11,14},{7,9,11,15},{7,10,12,13},{8,9,13,14}};
points=Map[Function[x,RootReduce[Sign[x.{1,ϕ}](Sqrt[Abs[(x).{1,ϕ}]])]],vals, {2}]; 
Graphics[{Cyan,Line[Subsets[Table[{Sin[n Pi/5],Cos[n Pi/5]},{n,0,9}],{2}]],Black,Thick,
Table[Line[points[[lines[[n]]]]],{n,1,Length[lines]}],White,EdgeForm[Black],
Table[{Tooltip[Disk[points[[n]],.03], vals[[n]]]},{n,1,Length[points]}],Black}, ImageSize-> Medium]

Of the maximizing solutions for the 3-in-a-row problem, solutions for p = 7, 11, 16, and 19 points are sporadic, with more lines than the lower bound (Floor[(1/6) (p-3) p])+1. Half use ϕ-space.

This is the middle sporadic solution.

base={{(ϕ^3),-1},{(ϕ^3),3 (ϕ^3)},{(ϕ^3),-1-2 (ϕ^3)},{(ϕ^6),-(ϕ^6)},{(ϕ^6),(ϕ^6)},{(ϕ^6),1+2 (ϕ^3)},{1+2 (ϕ^3),1}};points=Join[{{0,0}},base,-base];p=points/.ϕ->GoldenRatio; 
pa=Table[Append[p[[n]],1],{n,1,15}]; lines3=Map[First,First[SplitBy[SortBy[Map[Function[x,{x,RootReduce[Det[pa[[x]]]]^2}],Subsets[Range[15],{3}]],Last],Last]]];
lines2=Position[Table[p[[a,2]]==p[[b,2]]&&a<b,{a,1,15},{b,1,15}],True]; xy=Map[Union,Transpose[points]];
Graphics[{EdgeForm[Black],Table[Line[p[[lines3[[n]]]]],{n,1,31}],Table[{Cyan,InfiniteLine[p[[lines2[[n]]]]]},{n,1,6}],
Table[{White,Disk[p[[n]],1]},{n,1,15}],Table[Table[Style[Text[xy[[k,n]],RotateRight[{-20-k,xy[[k,n]]/.ϕ->GoldenRatio},k]],10],{n,1,Length[xy[[k]]]}],{k,1,2}]},PlotRange->{{-25,23},{-22,20}}, ImageSize-> Large]

The golden rectangle can be dissected into an infinite fractal series.
Sadly, a perfect tiling is impossible.

With[{ϕ=GoldenRatio},With[{o=Flatten[Table[{{0,(ϕ^(-k))},{(ϕ^(-k)),0}},{k,2,20,2}],1]},Graphics[{EdgeForm[Black],Opacity[.1],Cyan, Rectangle[{0,0},{ϕ,1}],Opacity[1],White,Table[Rectangle[o[[n]],o[[n]]+{ϕ,1}/ϕ^(n)],{n,1,12}],Table[Rectangle[{1,.214}+o[[n]]/(Sqrt[ϕ]),{1,.214}+(o[[n]]+{ϕ,1}/ϕ^(n))/(Sqrt[ϕ])],{n,1,12}],Cyan,Line[{{ϕ,.214}, {ϕ,1}}], Black, Inset[Style[Row[{"ϕ =",Underoverscript["∑","n=1", "∞"],Superscript["ϕ","-n"]}],14],{1.32,.105}]},ImageSize-> Large]]]

The golden rectangle is also seen in Penrose tiles. But it is actually Wieringa’s Roof.

Manipulate[Module[{p={{-1,1,0,-1},{0,0,1,-1},{-1,1,0,0},{-1,0,1,-1}} (* Matrix form of Phi^-1 *),q (* Matrix form of Phi^-2 *),
rl={{0,0,0,-1},{1,0,0,-1},{0,1,0,-1},{0,0,1,-1}} (* Matrix form of rotation left by 2/5 Pi *),
conj={{0,0,0,1},{0,0,1,0},{0,1,0,0},{1,0,0,0}} (* Matrix form of reflection in the horizontal axis *),
cm=Table[Exp[0.4 Pi I i],{i,1,4}] (* Four-dimensional vector -> complex number *),invphi=0.618034,r=If[raised,0.5,0],robtri},
q=p.p;

robtri=Nest[Flatten[Map[If[#[[1]]==1,
{{1,(p.#[[3]]+q.#[[4]]),#[[2]],#[[3]],#[[5]]},
{2,(p.#[[3]]+q.#[[4]]),#[[2]],(p.#[[2]]+q.#[[4]]),#[[5]]},
{1,(p.#[[2]]+q.#[[4]]),#[[4]],(p.#[[3]]+q.#[[4]]),3-#[[5]]}},
{{1,(p.#[[4]]+q.#[[2]]),#[[2]],#[[3]],#[[5]]},
{2,#[[3]],#[[4]],(p.#[[4]]+q.#[[2]]),3-#[[5]]}}]&,#],1]&,Map[{2,{0,0,0,0},#.{-1,-1,-1,-1},#.{0,-1,0,0},1}&,{rl,rl.rl,rl.rl.rl,rl.rl.rl.rl,rl.rl.rl.rl.rl,conj.rl,conj.rl.rl,conj.rl.rl.rl,conj.rl.rl.rl.rl,conj}],depth];(* Create the Penrose tiling via deflation *)

robtri=Select[robtri,(Im[(cm.#[[3]]-cm.#[[2]])/(cm.#[[4]]-cm.#[[2]])]<0)&];(* Remove half of the triangles *)

robtri=Map[{#[[1]],#[[2]],#[[3]],#[[3]]+#[[4]]-#[[2]],#[[4]],#[[5]]}&,robtri];(* Turn triangles into rhombi *)

Pane[Graphics3D[{Yellow,If[transparent,Opacity[0.4]],If[Not[edges],EdgeForm[]],Map[{If[coloured,{Blue,Green}[[#[[1]]]]],Polygon[Table[{Re[cm.#[[j]]],Im[cm.#[[j]]],({{2,3},{1,4},{2,3},{3,2}}[[j-1]][[#[[6]]]]-2.5)invphi^depth r},{j,2,5}]]}&,robtri]},ViewPoint->{0,0,Infinity},PlotRange->{All,All,{-invphi^depth,invphi^depth}},ImageSize->1.05{400,400},ImagePadding->1],1.05{400,400}]],{{depth,4,"recursion depth"},1,5,1,Setter},
Grid[{
{
Control@{{edges,True,"display edges"},{True,False}},Control@{{transparent,False,"transparent tiles"},{True,False}}
},
{
Control@{{raised,True,"raised tiles"},{True,False}},Control@{{coloured,True,"color rhombi differently"},{True,False}}
}}]
]

The Clebsch surface contains 27 lines.

Module[{lines27,clebschpoints},lines27=Transpose/@Flatten[Join[Table[RotateRight[#,n],{n,0,2}]&/@{{{-(1/3),-(1/3)},{1,-1},{-1,1}},{{0,0},{1,-(2/3)},{-(2/3),1}},{{1/3,1/3},{1,-(1/3)},{-(1/3),1}},{{0,0},{4/9,-(2/9)},{1,-1}},{{0,0},{1,-1},{4/9,-(2/9)}}},Permutations[#]&/@{{{30,-30},{35-19 Sqrt[5],-25+17 Sqrt[5]},{5+3 Sqrt[5],5-9 Sqrt[5]}}/30,{{6,-6},{-3+2 Sqrt[5],6-Sqrt[5]},{-7+4 Sqrt[5],8-5 Sqrt[5]}}/6}],1];
clebschpoints=Union[RootReduce[Flatten[With[{sol=Solve[e #[[1,1]]+(1-e) #[[1,2]]==f #[[2,1]]+(1-f) #[[2,2]]]},If[Length[sol]>0,(e #[[1,1]]+(1-e) #[[1,2]])/.sol,Sequence@@{}]]&/@Subsets[lines27,{2}],1]]];
Graphics3D[{{Sphere[#,.04]&/@Select[clebschpoints,Norm[#]<1&]},Tube[#,.02]&/@lines27,Opacity[.4],ContourPlot3D[81 (x^3+y^3+z^3)-189 (x^2 y+x^2 z+x y^2+x z^2+y^2 z+y z^2)+54 x y z+126 (x y+x z+y z)-9 (x^2+y^2+z^2)-9 (x+y+z)+1==0,{x,-1,1},{y,-1,1},{z,-1,1},Boxed->False][[1]]},Boxed->False,SphericalRegion->True,ImageSize->Large,ViewAngle->Pi/8]]

The rabbits are very popular. But I found the cow to be even more powerful.

Narayama’s Cow Problem (1356)
Δ=-31: (Cow^3)-(Cow^2)-1=0

“A cow gives birth to a calf every year. In turn, the calf gives birth to another calf when it is three years old. What is the number of progeny produced during twenty years by one cow?” (Ganita Kaumudi)

sols=Solve[x^3-x^2-1==0];
cows={Cow, CowComplex,CowConjugate}=x/.RootReduce[sols];
Style[Text[Grid[Transpose[{cows,N[cows,15], ToRadicals[cows]}]]],14]

How now Round Cow?

LinearRecurrence[{1,0,1},{2,3,4},16]
NestList[Function[x,Round[x Cow]],2,15]

Use CowComplex for a fractal using the chaos game. Iteration produces two similar fractal triangles.

points=RandomChoice[{Abs[CowComplex]^2, 1-Abs[CowComplex]^2}->{{(x CowComplex),1},{(-x CowComplex^3+1),2}},1000];
Graphics[Map[Function[y,{{Red,Blue}[[Last[y]]], Point[ReIm[-CowConjugate^2 First[y]]]}],FoldList[#2/.x->#1[[1]]&,{(1+I)/3.,1},points]]]

CowComplex generates the wriggly edge to any desired fractal depth. This is a self-similar dissection, irreptile, or Rauzy fractal.

r=CowComplex;big={-r^4,-1,r,-r^6};
small = {r^3,- r^4,-r^6,r^7}; iterate=3;
cow[comp_]:=Map[First,Split[Flatten[RootReduce[Map[
Function[x,x[[1]]+(x[[2]]-x[[1]]){0,-r^5,r^5+1,1}],Partition[comp,2,1,1]]]]]];
poly=Table[{{Red,Blue}[[n]],Polygon[ReIm[Nest[cow,{big,small}[[n]],iterate]]]},{n,1,2}];Graphics[{EdgeForm[Black],poly}]

Area ratios of fractal triangles equal the powers of Cow.

areabig=Area[N[poly[[1,2]]]]; areasmall=Area[N[poly[[2,2]]]]; areaAll=areabig+areasmall;
Column[{{areaAll/areabig, areabig/areasmall, areaAll/areasmall}, N[Cow^{1,2,3}]}]

Behold the Fractal Cow Nautilus!

base={{r^10,r^7,-r^9,r^11},{-r^12,-r^9,r^11,-r^13},{r^8,r^5,-r^7,r^9},{-r^7,-r^4,r^6,-r^8}}+{-r^10,r^11,-r^6,r^4+r^8};
naut=RootReduce[Join[Table[base[[1]] (-r)^n,{n,0,-4,-1}],Flatten[Table[Drop[base,1](-r)^n,{n,-8,0}],1]]];
poly=Table[ReIm[Nest[cow,N[naut[[k]],50],iterate]],{k,1,Length[naut]}];
Graphics[{EdgeForm[{Black}],Map[Function[x,{ColorData["BrightBands"][N[Norm[Mean[x]]/2]],Polygon[x]}],poly]},ImageSize->Large]

Cow is the sum of infinitely many scaled copies of itself, similar to how the golden rectangle can be dissected into a series of smaller copies of itself.

Solve[{x==(∑_(n=Q)^∞)(x^(-n)),Im[x]==0}]

roots=Table[{Q,x/.RootReduce[Last[Solve[{x==(∑_(n=Q)^∞)(x^(-n)),Im[x]==0}]]]},{Q,1,7}];Style[TextGrid[Prepend[Map[Function[y,{First[y],
 MinimalPolynomial[Last[y],x]==0,NumberFieldDiscriminant[Last[y]], N[Last[y],8]}],roots],{"Q", "root","discriminant","value"}],Frame-> All],24]

The cow series can exactly cover itself. Better than ϕ!

cow[comp_]:=Map[First,Split[Flatten[RootReduce[Map[Function[x,x[[1]]+(x[[2]]-x[[1]]){0,-r^5,r^5+1,1}],Partition[comp,2,1,1]]]]]];
 poly2=Table[ReIm[Nest[cow,N[RootReduce[r^({4,1,3,5}+n){1,1,-1,1}],50],3]],{n,1,30}];Graphics[{EdgeForm[{Black}],Gray,Disk[{0,0},.1],Map[Function[x,{ColorData["BrightBands"][N[Norm[Mean[x]]3]],Polygon[x]}],poly2],Black, Inset[Style[Row[{"cow =",Underoverscript["∑","n=2", "∞"],Superscript["cow","-n"]}],30],{-1/3,1/3}]}, ImageSize-> Large]

The product of the squares of the differences of the roots is -31. That’s the discriminant (Δ in the section headers). Roots with small determinants tend to be the most useful.

RootReduce[Times@@Flatten[(((Differences/@Subsets[cows,{2}]))^2)]]

NumberFieldDiscriminant/@cows

For any algebraic number field, many different polynomials that can be used. The discriminant is the same for all of them, so it is handy to identify a field by the discriminant. My general method for multiple points was to get two of them on (0,0) and (1,0). Then I looked at the discriminants of other points. If all the points had the same discriminant, then I not only knew it was a number field, but also which root to use!

{NumberFieldDiscriminant/@(x/.Solve[x^3-x^2-1==0]),
NumberFieldDiscriminant/@(x/.Solve[x^3+x-1==0])}

Silver Ratio: 1+(Sqrt[2]) (Hippasus 5th BC)
Δ=8: (S^2)-2S-1=0 (S≈2.414213562373095`…)

The Silver ratio has constant continued fraction terms, like the Golden ratio.

ContinuedFraction[GoldenRatio,10]
ContinuedFraction[1+(Sqrt[2]),10]

Vertices of the octagon and A4 paper have coordinates in this number field. A4 paper folds in half to make a similar rectangle.

vals=Normal[]; 
points=Map[Function[x,RootReduce[Sign[x.{1,1+(Sqrt[2])}](Sqrt[Abs[(x).{1,1+(Sqrt[2])}]])]],vals, {2}];
points2={{0,0},{1,0},{1,(Sqrt[2])},{0,(Sqrt[2])},{0,0},{0,1/(Sqrt[2])},{1,1/(Sqrt[2])},{1,0}};
Row[{Graphics[{EdgeForm[{Thin, Black}],Map[Line,Subsets[Take[points,8],{2}]],White,
 Table[Tooltip[Disk[points[[n]],.04],vals[[n]]],{n,1,Length[vals]}]}, ImageSize-> 256],
Graphics[{EdgeForm[Black],Line[points2],White,Map[Function[x,Tooltip[Disk[x,.03], x^2 Sign[x]]],points2]},
 ImageSize-> 180]}]

An area 200 A4 sheet can subdivide in a nontrivial way.

rects=Normal[]; areas={1,2,4,8,9,16,18,25,32,36,49};
Graphics[{EdgeForm[Black],White,Table[{Rectangle@@rects[[n]],Black,Style[Text[areas[[n]],Mean[rects[[n]]]],36]},{n,1,11}]},ImageSize->Large]

A4 scales into 3D with the Delian constant (2^(1/3)) = 1.2599…

With[{r=2^(1/3)},Graphics3D[{Opacity[.5],Cuboid[{0,0,0},{ r^0,r^1,r^2}], 
Cuboid[{1 ,0,0},{2,r^1,r^2}]},SphericalRegion-> True, Boxed-> False]]

Dale Walton’s The Fifth Chair was seemingly published first as a toy.

With[{r=2^(1/3)},Graphics3D[{Opacity[.5],
{Red,Cuboid[{0 r^0,0 r^1,0r^2},{2 r^0,r^1,r^2}], Cuboid[{1 r^0,1 r^1,0r^2},{2 r^0,2 r^1,1r^2}]},
{Blue,Cuboid[{0 r^0,1 r^1,0r^2},{1 r^0,3r^1,1r^2}], Cuboid[{1 r^0,2 r^1,0r^2},{2 r^0,3 r^1,1r^2}]},
{Green,Cuboid[{0 r^0,3 r^1,0r^2},{2 r^0,4r^1,2r^2}], Cuboid[{0 r^0,2 r^1,1r^2},{2 r^0,3 r^1,2r^2}]},
{Yellow,Cuboid[{2 r^0,0 r^1,0r^2},{4 r^0,2r^1,2r^2}],Cuboid[{0 r^0,0 r^1,1r^2},{2 r^0,2 r^1,2r^2}]}},
SphericalRegion-> True, Boxed-> False]]

What is next in the continued fraction series?

RootApproximant[N[FromContinuedFraction[Table[3,{100}]],20]]

ContinuedFraction[(1/2) (3+(Sqrt[13])),10]

Bronze Ratio:  (((3+(Sqrt[13])))/2)
Δ=13: (B^2)-3B-1=0 (B≈3.302775637731995`…)

The bronze ratio B gives the best-known algebraic solution for the ABC conjecture.

With[{w =(1/2) (1+(Sqrt[13]))},RootReduce[w+(((w+1))^10)(w-1)-(2^9)(((w+1))^5)]]

The Heilbronn problem arranges points in a unit square to make the largest possible smallest triangle. The thickened red lines have a ratio that is exactly the bronze ratio. Vertices are all in B-space.

Module[{name,root,vals,points,triangles},name= "Heilbronn Square 8 (in bronze)";root=((3+(Sqrt[13]))/2);
vals={{{0,0},{0,0}},{{18,9},{0,0}},{{81,0},{26,-7}},{{153,-45},{104,-28}},{{18,9},{5,8}},{{0,0},{17,11}},{{153,-45},{81,0}},{{81,0},{81,0}}}/81;
points=Map[Function[x,RootReduce[Sign[x.{1,root}](Sqrt[Abs[(x).{1,root}]])]],vals, {2}];triangles=Transpose[First[SplitBy[SortBy[Table[{Subsets[points,{3}][[n]], RootReduce[Abs[Area[Polygon[Subsets[points,{3}][[n]]]]]]},
{n,1,Binomial[Length[points],3]}],Function[x,N[Last[x]]]],Function[x,N[Last[x]]]]]];
Text[Column[{name,Row[{"triangles have area ",RootReduce[triangles[[2,1]]], " or ", N[triangles[[2,1]]] }],
 Graphics[{EdgeForm[Thick],Lighter[LightGray],Rectangle[{0,0},{1,1}],Table[{Opacity[.5],Hue[RandomReal[{0,1}]],Polygon[triangles[[1,n]]]},{n,1,Length[triangles[[1]]]}], Red, Thickness[.02],Line[points[[{2,3}]]], Line[points[[{4,8}]]],Black,Table[Tooltip[ Disk[points[[n]],.02], vals[[n]]],{n,1,Length[points]}]}, ImageSize-> Large]}, Alignment-> Center]]]

Plastic Constant
Δ=-23: (ρ^3)-ρ-1=0 (ρ≈1.32472…)

The plastic constant is the smallest of the Pisot numbers. 
The Greek letter ρ (rho) represents the plastic constant. 
ρ allows a square to be divided into three similar rectangles.

ρ=Root[-1-#1+((#1)^3)&,1];rects={{{0,0},{1+ρ-ρ^2,1}},{{1+ρ-ρ^2,0},{1,2-ρ^2}},{{1+ρ-ρ^2,2-ρ^2},{1,1}}};
Graphics[{EdgeForm[Black],Hue[ρ],Apply[Rectangle,rects,{1}]}]

Neighboring term ratios for both the Padovan sequence and Perrin sequence tend to ρ.

LinearRecurrence[{0,1,1},{1,1,1},18]
LinearRecurrence[{0,1,1},{3,0,2},18]

The Padovan spiral.

Manipulate[If[dimensions=="2D",Graphics[{Map[squareFigure[#,op,th]&,NestList[nextSquare,{bigRect[{{0,0},{1,1}}],1,newSquare[{{0,0},{1,1}}]},n]]},ImageSize->{400,400}],Graphics3D[{Map[blockFigure[#,op,th]&,NestList[nextBlock,{wholeBlock[{{0,0,0},{1,1,1}}],1,newBlock[{{0,0,0},{1,1,1}}]},n]]},Boxed->False,Lighting->{White},ImageSize->{420,420}]],
{{dimensions,"3D", ""},{"2D","3D"}},
"iterations",
{{n,10,""},0,50,1,Appearance->"Labeled", ImageSize-> Tiny},
"box opacity",
{{op,0.2,""},0.1,1.0,Appearance->"Labeled",ImageSize-> Tiny},
"spiral line thickness",
{{th,0.01,""},0.0001,0.02,Appearance->"Labeled", ImageSize-> Tiny},
ControlPlacement->Left,
Initialization-> ((* 2D version *)
(* down *)
nextSquare[{bigRect[{{bx0_,by0_},{bx1_,by1_}}],1,newSquare[{{x0_,y0_},{x1_,y1_}}]}]:=
With[{side=bx1-bx0},
{bigRect[{{bx0,by0-side},{bx1,by1}}],2,newSquare[{{bx0,y0-side},{bx1,by0}}]}];
(* left *)
nextSquare[{bigRect[{{bx0_,by0_},{bx1_,by1_}}],2,newSquare[{{x0_,y0_},{x1_,y1_}}]}]:=
With[{side=by1-by0},{bigRect[{{bx0-side,by0},{bx1,by1}}],3,newSquare[{{x0-side,by0},{x0,by1}}]}];
(* up *)
nextSquare[{bigRect[{{bx0_,by0_},{bx1_,by1_}}],3,newSquare[{{x0_,y0_},{x1_,y1_}}]}]:=
With[{side=bx1-bx0},{bigRect[{{bx0,by0},{bx1,by1+side}}],4,newSquare[{{bx0,y1},{bx1,y1+side}}]}];
(* right *)
nextSquare[{bigRect[{{bx0_,by0_},{bx1_,by1_}}],4,newSquare[{{x0_,y0_},{x1_,y1_}}]}]:=
With[{side=by1-by0},
{bigRect[{{bx0,by0},{bx1+side,by1}}],1,newSquare[{{x1,by0},{x1+side,by1}}]}];
squareFigure[{_,n_,newSquare[{{x0_,y0_},{x1_,y1_}}]},op_,th_]:={{EdgeForm[{Thin,Gray}],Opacity[op],ColorData["Rainbow"][n/4.0],Rectangle[{x0,y0},{x1,y1}]},{Black,Thickness[th],
Switch[n,
1,Line[{{x0,y1},{x1,y0}}],
2,Line[{{x1,y1},{x0,y0}}],
3,Line[{{x1,y0},{x0,y1}}],
4,Line[{{x0,y0},{x1,y1}}]]}};
(* 3D version *)
(* down *)
nextBlock[{wholeBlock[{{bx0_,by0_,bz0_},{bx1_,by1_,bz1_}}],1,newBlock[{{x0_,y0_,z0_},{x1_,y1_,z1_}}]}]:=
Module[{side=Min[{by1-by0,bx1-bx0}]},
{wholeBlock[{{bx0,by0,bz0-side},{bx1,by1,bz1}}],2,newBlock[{{bx0,by0,z0-side},{bx1,by1,z0}}]}];
(* left *)
nextBlock[{wholeBlock[{{bx0_,by0_,bz0_},{bx1_,by1_,bz1_}}],2,newBlock[{{x0_,y0_,z0_},{x1_,y1_,z1_}}]}]:=
Module[{side=Min[{by1-by0,bz1-bz0}]},{wholeBlock[{{bx0-side,by0,bz0},{bx1,by1,bz1}}],3,newBlock[{{x0-side,by0,bz0},{x0,by1,bz1}}]}];
(* back *)
nextBlock[{wholeBlock[{{bx0_,by0_,bz0_},{bx1_,by1_,bz1_}}],3,newBlock[{{x0_,y0_,z0_},{x1_,y1_,z1_}}]}]:=
Module[{side=Min[{bx1-bx0,bz1-bz0}]},{wholeBlock[{{bx0,by0,bz0},{bx1,by1+side,bz1}}],4,newBlock[{{bx0,y1,bz0},{bx1,y1+side,bz1}}]}];
(* up *)
nextBlock[{wholeBlock[{{bx0_,by0_,bz0_},{bx1_,by1_,bz1_}}],4,newBlock[{{x0_,y0_,z0_},{x1_,y1_,z1_}}]}]:=
Module[{side=Min[{by1-by0,bx1-bx0}]},
{wholeBlock[{{bx0,by0,bz0},{bx1,by1,bz1+side}}],5,newBlock[{{bx0,by0,z1},{bx1,by1,z1+side}}]}];
(* right *)
nextBlock[{wholeBlock[{{bx0_,by0_,bz0_},{bx1_,by1_,bz1_}}],5,newBlock[{{x0_,y0_,z0_},{x1_,y1_,z1_}}]}]:=
Module[{side=Min[{by1-by0,bz1-bz0}]},{wholeBlock[{{bx0,by0,bz0},{bx1+side,by1,bz1}}],6,newBlock[{{x1,by0,bz0},{x1+side,by1,bz1}}]}];
(* front *)
nextBlock[{wholeBlock[{{bx0_,by0_,bz0_},{bx1_,by1_,bz1_}}],6,newBlock[{{x0_,y0_,z0_},{x1_,y1_,z1_}}]}]:=
Module[{side=Min[{bx1-bx0,bz1-bz0}]},{wholeBlock[{{bx0,by0-side,bz0},{bx1,by1,bz1}}],1,newBlock[{{bx0,y0-side,bz0},{bx1,y0,bz1}}]}];
blockFigure[{_,n_,newBlock[{{x0_,y0_,z0_},{x1_,y1_,z1_}}]},op_,th_]:={{Black,Thickness[th],
Switch[n,
1,Line[{{x1,y1,z1},{x1,y0,z0}}],
2,Line[{{x1,y0,z1},{x0,y0,z0}}],
3,Line[{{x1,y0,z0},{x0,y1,z0}}],
4,Line[{{x0,y0,z0},{x0,y1,z1}}],
5,Line[{{x0,y1,z0},{x1,y1,z1}}],
6,Line[{{x0,y1,z1},{x1,y0,z1}}]]},{Opacity[op],ColorData["Rainbow"][n/6.0],Cuboid[{x0,y0,z0},{x1,y1,z1}]}};
wholeBlockDims[wholeBlock[{B0_List,B1_List}]]:=With[{dims=Sort[B1-B0]},StringForm["large box dimensions are ``×``×``",dims[[1]],dims[[2]],dims[[3]]]])]

Andrzej Zak found that a triangle with sides based on integer powers of (Sqrt[ρ]) could be subdivided into differently sized similar triangles. The numbers shown are the integer powers.

vals={{{{-8,-12,-8},{0,0,0}},{{12,20,16},{0,0,0}},{{0,1,1},{4,7,7}},{{0,0,0},{0,0,0}},{{1,1,3},{-1,3,1}},{{4,0,0},{0,0,0}},{{5,9,7},{-1,3,1}}},
{{{0,0,0},{0,0,0}},{{12,20,16},{0,0,0}},{{4,8,4},{0,0,0}},{{-8,-12,-8},{0,0,0}},{{7,5,-4},{-3,-1,4}},{{6,15,10},{2,-3,2}},{{0,1,1},{4,7,7}},{{-1,-1,-3},{-1,3,1}}}}/4;
ρ=Root[-1-#1+((#1)^3)&,1];
pts= Table[Map[Function[x,RootReduce[Sign[x.(ρ^{0,1,2})](Sqrt[Abs[x.(ρ^{0,1,2})]])]],vals[[k]], {2}],{k,1,2}]; 
powerlines={{{0,{4,6}},{1,{5,6}},{2,{5,7}},{3,{3,5}},{4,{2,7}},{4,{4,5}},{5,{6,7}},{6,{3,7}},{7,{3,4}},{8,{1,4}},{8,{2,6}},{11,{1,3}}},
{{0,{2,6}},{1,{3,6}},{2,{3,5}},{3,{1,5}},{4,{1,8}},{4,{2,3}},{5,{4,8}},{5,{5,6}},{6,{1,3}},{7,{5,8}},{7,{7,8}},{8,{1,4}},{8,{6,7}},{11,{6,8}}}};
Column[Table[Graphics[{EdgeForm[Black],Table[{Line[pts[[k,powerlines[[k,n,2]]]]],Style[Text[powerlines[[k,n,1]],Mean[pts[[k,powerlines[[k,n,2]]]]]],18]},{n,1,Length[powerlines[[k]]]}],Cyan,
Table[Tooltip[Disk[pts[[k,n]],.07],vals[[k,n]]],{n,1,Length[pts[[k]]]}]}, ImageSize-> Large],{k,1,2}]]

A self-similar fractal exists for ρ. The numbers on green lines indicate a particular power of a complex root of ρ.

ρ=Root[-1-#1+#1^3&,3]; iterate=6;big=ρ^{5,8,6,9,4,7};par=ρ^{6,9,7,10,5,8};
wee=ρ^4{ρ^3,ρ^8,ρ^5,ρ^6(2ρ^2 -1),1,ρ^2 (2ρ^3 -1)};
plastic[comp_]:=Map[First,Split[Flatten[RootReduce[Map[Function[x,{x[[1,1]]+(x[[1,2]]-x[[1,1]]) {0,ρ^5,1},
x[[2,1]]+(x[[2,2]]-x[[2,1]]) {0,1-ρ^5,1}}],Partition[Partition[comp,2,1,1],2]]]]]];
poly=Table[{{Red,Blue}[[n]],Polygon[ReIm[Nest[plastic,{par,wee}[[n]],iterate]]]},{n,1,2}];Graphics[{EdgeForm[Black],poly,Table[{Style[Text[n,.12ReIm[ρ^n]/Norm[ρ^n]],20], Green,Line[ReIm[ρ^n]#&/@{1,0}]},{n,4,12}]}, ImageSize-> Large]

The plastic fractal triangle corresponds to an infinite series.

ρ=Root[-1-#1+#1^3&,3]; iterations=4;big=ρ^{5,8,6,9,4,7};par=ρ^{6,9,7,10,5,8};
wee=ρ^4{ρ^3,ρ^8,ρ^5,ρ^6(2ρ^2 -1),1,ρ^2 (2ρ^3 -1)};
plastic[comp_]:=Map[First,Split[Flatten[RootReduce[Map[Function[x,{x[[1,1]]+(x[[1,2]]-x[[1,1]]) {0,ρ^5,1},
x[[2,1]]+(x[[2,2]]-x[[2,1]]) {0,1-ρ^5,1}}],Partition[Partition[comp,2,1,1],2]]]]]];poly=Table[{Hue[Pi n],Polygon[ReIm[Nest[plastic,wee ρ^(n-1),iterations]]]},{n,1,20}];Graphics[{EdgeForm[Black],poly, Inset[Style[Row[{"ρ =",Underoverscript["∑","n=4", "∞"],Superscript["ρ","-n"]}],24],{-5/12,1/3}] }, ImageSize-> Large]

The set of points portrayed below have the curious property that all distances are integer powers of (Sqrt[ρ]). The integer powers are shown at the midpoint of each segment.

vals={{{4,3,-3},{0,0,0}},{{4,7,5},{0,0,0}},{{5,1,0},{1,4,3}},{{2,0,-1},{4,7,4}},{{0,0,0},{0,1,3}}}/4;
ρ=Root[-1-#1+((#1)^3)&,1]; pts=Map[Function[x,RootReduce[Sign[x.(ρ^{0,1,2})](Sqrt[Abs[x.(ρ^{0,1,2})]])]],vals, {2}];
powerlines={{3,{1,2}},{4,{1,3}},{5,{2,3}},{6,{1,4}},{8,{2,4}},{1,{3,4}},{3,{1,5}},{7,{2,5}},{2,{3,5}},{0,{4,5}}};
Graphics[{EdgeForm[Black],Table[{Line[pts[[powerlines[[n,2]]]]],Style[Text[powerlines[[n,1]],Mean[pts[[powerlines[[n,2]]]]]],20]},{n,1,Length[powerlines]}],
Cyan,Table[Tooltip[Disk[pts[[n]],.05],vals[[n]]],{n,1,Length[pts]}]},ImageSize-> Large]

A polynomial where coefficients are roots.

poly = (x^4)+ (x^3)+(-(ρ^2)) (x^2) + ((ρ^2)-ρ-1) x + (ρ-1);
RootReduce[poly/.x->#]&/@CoefficientList[poly,x]

Theodorus Constant: (Sqrt[3]) (5th century BC)
Δ=12: (x^2)-3=0 (ϕ≈1.73205…)

What are the possibilities for pentagons tiling the plane? On July 29, 2015, a 15th type of tiling pentagon was announced by Casey Mann, Jennifer McLoud, and David Von Derau.

Module[{name,root,vals,vals2, motif, offset},name= Row[{"Mann-McLoud-Derau Pentagon Tiling 15 (in ",Sqrt[3],")"}];root=(Sqrt[3]);
vals=Normal[];vals2={{{18,9},{0,0}},{{0,0},{2,0}}}/2;
motif=Map[Function[x,RootReduce[Sign[x.{1,root}](Sqrt[Abs[(x).{1,root}]])]],vals, {2}];
offset=Map[Function[x,RootReduce[Sign[x.{1,root}](Sqrt[Abs[(x).{1,root}]])]],vals2, {2}];
Text[Column[{name, With[{pents = Flatten[Table[motif +Table[x offset[[1]] +y offset[[2]], {Length[motif]},{5}],{x,-3,3},{y,-7,7}],2]},
Graphics[{EdgeForm[Thick],Hue[.4],Polygon[pents]},PlotRange-> {{-4,4},{-4,4}}, ImageSize-> Large]]}, Alignment-> Center]]]

Divide a square into similar acute triangles. In 1990, Laczkovich proved that only 45°–60°–75° could solve the problem. A solution by Lew Baxter and Franz Pichler shows 46 triangles suffice.

Module[{name,root,vals,points,triangles},name= Row[{"Laczkovich-Baxter-Pichler Similar Acute Triangle Square Dissection (in ",Sqrt[3],")"}];
root=(Sqrt[3]);vals=Normal[];
triangles= {{6,5,2},{3,2,6},{8,7,3},{4,3,8},{9,10,5},{5,6,10},{10,11,7},{7,8,11},{12,15,13},{13,15,16},{14,13,16},{17,15,16},{1,19,17},{19,17,20},{21,20,19},{11,18,9},{18,9,16},{20,16,18},{1,22,12},{2,23,22},{22,24,23},{23,14,24},{24,12,14},{4,27,8},{8,30,27},{30,8,11},{32,11,30},{11,18,31},{27,26,29},{28,29,32},{29,28,26},{31,32,28},{26,41,40},{40,42,41},{18,31,37},{20,37,18},{41,35,42},{35,34,37},{38,36,37},{34,36,37},{33,36,34},{42,33,35},{25,40,33},{25,39,38},{39,38,20},{21,20,39}};
points=Map[Function[x,RootReduce[Sign[x.{1,root}](Sqrt[Abs[(x).{1,root}]])]],vals, {2}];
Text[Column[{name, Graphics[{EdgeForm[Black], White,Table[Polygon[points[[triangles[[n]]]]],{n,1,Length[triangles]}]}, ImageSize->Large]}, Alignment-> Center]]]

Twelver
Δ=-76: (α^3)-2α-2=0 (α≈1.76929…)

The number field of (α^3)-2α-2=0 provides the best solution for 12 disks covering a unit disk.

Module[{name,root,vals,valrad,points,rad,triangles},name= "Melissen 12 Disk Covering";root=Root[-2-2 #1+((#1)^3)&,1];
vals={{{-28,16,0},{0,0,0}},{{7,-4,0},{21,-12,0}},{{7,-4,0},{-21,12,0}},{{-4,8,-4},{0,0,0}},{{1,-2,1},{3,-6,3}},{{1,-2,1},{-3,6,-3}},{{4,2,-3},{0,6,-3}},{{5,4,-3},{-9,0,3}},{{7,-4,0},{-3,0,0}},{{4,2,-3},{0,-6,3}},{{7,-4,0},{3,0,0}},{{5,4,-3},{9,0,-3}}}/4;
points= Map[Function[x,RootReduce[Sign[x.(root^{0,1,2})](Sqrt[Abs[x.(root^{0,1,2})]])]],vals, {2}];
Text[Column[{Row[{name, " (in ", MinimalPolynomial[root,α],"=0)"}], Graphics[{Red,EdgeForm[Black],Opacity[.5],Disk[{0,0},1],White,
Table[{Disk[points[[n]],Root[-1+3 #1-((#1)^2)+((#1)^3)&,1]]},{n,1,12}]},ImageSize-> Medium]}, Alignment-> Center]]]

Twelver also provides a solution for the 12 point Heilbronn problem that maximizes the area of the smallest triangle in a unit square.

Module[{name,root,vals,points,triangles},name= "Heilbronn Square 12";root=Root[-2-2 #1+((#1)^3)&,1];
vals={{{4,-4,1},{0,0,0}},{{0,0,1},{0,0,0}},{{0,0,0},{4,-4,1}},{{4,0,0},{4,-4,1}},{{1,0,0},{-3,0,1}},{{-3,0,1},{1,0,0}},{{5,4,-3},{1,0,0}},{{1,0,0},{5,4,-3}},{{0,0,0},{0,0,1}},{{4,0,0},{0,0,1}},{{4,-4,1},{4,0,0}},{{0,0,1},{4,0,0}}}/4;
points= Map[Function[x,RootReduce[Sign[x.(root^{0,1,2})](Sqrt[Abs[x.(root^{0,1,2})]])]],vals, {2}];
triangles=Transpose[First[SplitBy[SortBy[Table[{Subsets[points,{3}][[n]], RootReduce[Abs[Area[Polygon[Subsets[points,{3}][[n]]]]]]},
{n,1,Binomial[Length[points],3]}],Function[x,N[Last[x]]]],Function[x,N[Last[x]]]]]];
Text@Column[{Row[{name, " (in ", MinimalPolynomial[root,α],"=0)"}],Row[{"triangles have area ", N[triangles[[2,1]],10]}],
 Graphics[{EdgeForm[Thick],Lighter[LightGray],Rectangle[{0,0},{1,1}],Table[{Opacity[.5],Hue[RandomReal[{0,1}]],Polygon[triangles[[1,n]]]},{n,1,Length[triangles[[1]]]}],Black,Table[Tooltip[Disk[points[[n]],.02], vals[[n]]],{n,1,Length[points]}]}, ImageSize-> Medium]}, Alignment-> Center]]

Tribonacci Constant
Δ=-44: (t^3)-(t^2)-t-1=0 (t≈1.83929…)

The Tribonacci constant is limiting ratio of adjacent terms in the tribonacci sequence.

t=Root[-1-#1-((#1)^2)+((#1)^3)&,1];
Column[{LinearRecurrence[{1,1,1},{0,0,1},14], N[t,40]}]

The snub cube and its enantiomorph use t-space.

vals=Flatten[Outer[Times,Permutations[{{0,1,1},{0,1,-1},{2,1,-1}}/4],Tuples[{-1,1},3],1],1];
t=Root[-1-#1-((#1)^2)+((#1)^3)&,1]; points= Map[Function[x,RootReduce[Sign[x.(t^{0,1,2})](Sqrt[Abs[x.(t^{0,1,2})]])]],vals, {2}];
edge=Select[Subsets[points,{2}],Function[x,Chop[N[1-Apply[EuclideanDistance,x]]]==0]];
split=GatherBy[edge,Function[x,Position[ConnectedComponents[Graph[Apply[UndirectedEdge,edge,{1}]]],First[x]][[1,1]]]];
Graphics3D[{ConvexHullMesh[Union[Flatten[split[[1]],1]]]["GraphicsComplex"],Cyan,Tube[split[[2]]]}, Boxed-> False, SphericalRegion->True, ViewAngle-> Pi/9]

Using (t^3)-(t^2)-t-ϕ=0 gives the snub dodecahedron instead.

root=Root[-1+#1+2 ((#1)^2)+((#1)^3)-((#1)^4)-2 ((#1)^5)+((#1)^6)&,4]; {vals,faces}=Normal[];
points= Map[Function[x,RootReduce[Sign[x.(root^Range[0,5])](Sqrt[Abs[x.(root^Range[0,5])]])]],vals, {2}]; 
Graphics3D[{EdgeForm[Thick],Opacity[.9],Table[{{Yellow,Blue}[[k]], Polygon[points[[faces[[k,face]]]]]},{k,1,2},{face,1,Length[faces[[k]]]}]}, Boxed-> False, SphericalRegion-> True, ImageSize->Large, ViewAngle-> Pi/9]

Second Pisot Number
-283: (α^4)-α-1=0 (α≈1.22074…)

The degree-4 Pisot number is usually defined as (α^4)-(α^3)-1=0 (α≈1.380278…). Here it is as a Pisot number, with one root outside of the unit circle and the rest on the inside.

Graphics[{Circle[{0,0},1],PointSize[.015],Table[Point[ReIm[-1/Root[-1-#1+((#1)^4)&,n]]],{n,1,4}]}]

Powers of this root give seven different similar triangles that subdivide an isosceles triangle in an unusual way.

root=Root[-1-#1+((#1)^4)&,2];
vals={{{0,0,0,0},{0,0,0,0}},{{4,0,0,0},{0,0,0,0}},{{8,12,12,8},{0,0,0,0}},{{16,28,24,20},{0,0,0,0}},{{4,7,6,5},{4,9,6,7}},{{1,2,1,0},{-1,2,3,0}},{{5,6,5,4},{-1,2,3,0}},{{13,21,16,16},{-1,3,0,0}},{{6,11,11,10},{-2,5,1,6}},{{12,20,17,13},{0,0,-1,3}},{{7,12,10,7},{5,8,2,1}},{{6,11,9,7},{6,13,11,9}}}/4;pts= Take[Map[Function[x,RootReduce[Sign[x.(root^{0,1,2,3})](Sqrt[Abs[x.(root^{0,1,2,3})]])]],vals, {2}],8]; 
powerlines={{0,{1,2}},{5,{1,6}},{10,{2,3}},{2,{2,6}},{7,{2,7}},{6,{3,4}},{5,{3,7}},{3,{3,8}},{1,{4,8}},{9,{5,6}},{6,{5,7}},{11,{5,8}},{4,{6,7}},{8,{7,8}}};
Graphics[{EdgeForm[Black],Table[{Line[pts[[powerlines[[n,2]]]]],Style[Text[powerlines[[n,1]],Mean[pts[[powerlines[[n,2]]]]]],18]},{n,1,Length[powerlines]}],Cyan,
Table[Tooltip[Disk[pts[[n]],.07],vals[[n]]],{n,1,Length[pts]}]}, ImageSize-> Large]

Five points in 3D space (the projection of a 4D simplex) can be positioned so that the distances between the points are distinct integer powers of the root.

p4=Normal[];Row[Table[Graphics3D[{Table[Sphere[p4[[k,1,a]],.05],{a,1,5}], With[{sub=Subsets[p4[[k,1]],{2}]},
Table[{Tube[sub[[n]]], Style[Text[p4[[k,2]][[n]],Mean[sub[[n]]]], 20]},{n,1,10}]]}, Boxed-> False, SphericalRegion->True, ImageSize->{250,200}, ViewAngle-> Pi/12],{k,1,2}]]

This number field has degree 4. This is the last of the algebraic roots that has a wide range of geometric usefulness, so far as I can tell. Higher-degree roots get more specialized.

{small, pisot,salem,wheel,simplex, inf,polygon,graph,polyhedra}=Normal[];interesting=Normal[]; header=Normal[];
Text@Grid[Prepend[Map[Function[y,
{NumberFieldSignature[y].{1,2},NumberFieldSignature[y],NumberFieldDiscriminant[y],AlgebraicNumberNorm[y],AlgebraicNumberTrace[y],N[y],MinimalPolynomial[y,x],If[MemberQ[Flatten[small],NumberFieldDiscriminant[y]],Position[small,NumberFieldDiscriminant[y]][[1,2]],""],
If[MemberQ[pisot,NumberFieldDiscriminant[y]],"✓",""],If[MemberQ[salem,NumberFieldDiscriminant[y]],"✓",""],If[MemberQ[wheel,NumberFieldDiscriminant[y]],"✓",""],If[MemberQ[simplex,NumberFieldDiscriminant[y]],"✓",""],
If[MemberQ[inf,NumberFieldDiscriminant[y]],"✓",""],If[MemberQ[polygon,NumberFieldDiscriminant[y]],"✓",""],If[MemberQ[graph,NumberFieldDiscriminant[y]],"✓",""],If[MemberQ[polyhedra,NumberFieldDiscriminant[y]],"✓",""]
}],interesting],header],Frame->All]

Brillhart’s cubic (({{0, 2, 2}, {1, 0, 2}, {2, 1, 0}}))
Δ=-652: (α^3)-8α-10=0 (α≈3.31863…)

The matrix (({{0, 2, 2}, {1, 0, 2}, {2, 1, 0}})) has eigenvalues that are the solutions of (α^3)-8α-10=0. In 1965, Brillhart noticed the continued fraction had numerous large terms.

Eigenvalues[{{0,2,2},{1,0,2},{2,1,0}}]

ContinuedFraction[N[Root[-10-8 #1+((#1)^3)&,1],240]]

The polynomial (α^3)-6(α^2)+4α-2=0 is from the same algebraic field and has a root associated with (e^((Sqrt[163]) π)).

NumberFieldDiscriminant[Root[-2+4 #1-6 ((#1)^2)+((#1)^3)&,1]]

Column[{
AccountingForm[N[Root[-2+4 #1-6 ((#1)^2)+((#1)^3)&,1]^24 -24,34]],
AccountingForm[N[E^(Pi Sqrt[163]),34]],
 640320^3+744}]

The values are close because the first can give the Leech lattice and the second leads to the j-function. This connects to Monstrous Moonshine, a conjecture about the Monster group later proven by Bocherds, which earned him a Fields medal. The connection comes from modular forms.

The utility of using squares and square roots on an algebraic number field is likely due to modular forms.

Silver Constant (not the Silver Ratio)
Δ=+49: (S^3)-5(S^2)+6S-1=0 (S≈3.24698…)

Roots of chromatic polynomials of planar triangulations cluster around Beraha values. The first is ϕ (green), the second is S (red).
Also, the number field of the silver constant gives the space of the heptagon.

GetChromaticRoots[number_]:=Take[ReIm[Flatten[N[x/.Map[Function[y,Solve[y==0]],
Drop[Union[Map[First,Flatten[Map[FactorList,Drop[Union[Map[Function[y,GraphData[y, "ChromaticPolynomial"][x]],GraphData["Triangulated"]]],-1]],1]]],1]]]]],number];
chromatic=Normal[];S=Root[-1+6 #1-5((#1)^2)+((#1)^3)&,3]; ϕ=GoldenRatio;
Row[{Graphics[{Black,Point[chromatic],Green, Line[{{ϕ^2,-.4}, {ϕ^2,.4}}],Red, Line[{{S,-.4}, {S,.4}}]},ImageSize->Medium],
Graphics[{EdgeForm[{Thin, Black}],Map[Line,Subsets[CirclePoints[7],{2}]],White,
 Table[Tooltip[Disk[CirclePoints[7][[n]],.06],Map[Function[x,ToNumberField[x^2,S]],CirclePoints[7][[n]]]],{n,1,7}]}, ImageSize->Medium]}]

For almost all values of p, the maximal number of lines of 3 is given by the lower bound (Floor[(1/6) (p-3) p])+1. For 19 points, that would be 51 lines. But a 52-line solution is known, and that is the last known sporadic example that beats the lower bound.

{vals, lines3,lines2}=Normal[];S=Root[-1+6 #1-5((#1)^2)+((#1)^3)&,3];points=Map[Function[x,RootReduce[Sign[x.(S^{0,1,2})](Sqrt[Abs[x.(S^{0,1,2})]])]],vals, {2}];
Text[Column[{"19 Trees in 52 Rows of Three (in S)",Row[{"Points ", Style["●", Green,18],Style["●", Red,18],Style["●", Blue,18], " at infinity"}],
 Graphics[{Table[Line[points[[lines3[[n]]]]],{n,1,Length[lines3]}],Table[{{Blue,Green,Red}[[c]],InfiniteLine[points[[lines2[[c,n]]]]]},{n,1,7},{c,1,3}],
EdgeForm[Black],White,Table[Tooltip[Disk[points[[n]],.06],vals[[n]]],{n,1,Length[points]}]},PlotRange->{{-1.4,1.4},{-1.1,1.1}}, ImageSize-> Large]}, Alignment-> Center]]

Combine the silver constant with (Sqrt[3]).The number field for the 21-gon offers a 4-chromatic unit-distance graph with no 4-cycles. I call it the Nested 7 graph.

root=Root[1-8 #1+8 ((#1)^2)+6 ((#1)^3)-6 ((#1)^4)-((#1)^5)+((#1)^6)&,5];
vals={{{7,0,0,0,0,0},{-41,72,12,-64,0,12}},{{49,-91,-14,77,0,-14},{1,-19,-2,13,0,-2}},{{28,-35,-7,35,0,-7},{20,-37,-5,29,0,-5}},{{0,0,0,0,0,0},{48,-72,-12,64,0,-12}},{{-28,35,7,-35,0,7},{20,-37,-5,29,0,-5}},{{-49,91,14,-77,0,14},{1,-19,-2,13,0,-2}},{{-7,0,0,0,0,0},{-41,72,12,-64,0,12}},{{13,-11,1,3,-1,0},{1,-7,-3,15,-1,-4}},{{5,-9,-2,7,1,-1},{-7,-5,-6,19,1,-5}},{{-3,28,-5,-24,3,5},{15,-32,9,12,-3,-1}},{{-10,-2,15,13,-5,-4},{2,-6,19,1,-5,0}},{{-9,3,-3,9,0,-3},{3,-1,1,-3,0,1}},{{-1,8,-21,5,5,-2},{-11,-4,17,7,-5,-2}},{{-7,13,-11,1,3,-1},{-5,-9,7,11,-3,-3}},{{0,23,1,-16,1,2},{4,-53,-7,36,1,-6}},{{-5,33,14,-24,-3,4},{-1,-43,6,28,-3,-4}},{{-3,57,6,-39,0,6},{-1,19,2,-13,0,2}},{{6,4,-9,-5,3,1},{-10,72,17,-47,-3,7}},{{13,-91,-11,62,1,-10},{9,-15,-3,10,1,-2}},{{-3,4,4,-7,-2,2},{7,-80,-12,59,2,-10}},{{2,-62,-9,43,2,-7},{2,-14,1,9,-2,-1}}}/4;
unitlines = {{1,2},{1,7},{1,9},{1,21},{2,3},{2,10},{2,15},{3,4},{3,11},{3,16},{4,5},{4,12},{4,17},{5,6},{5,13},{5,18},{6,7},{6,14},{6,19},{7,8},{7,20},{8,10},{8,13},{8,20},{9,11},{9,14},{9,21},{10,12},{10,15},{11,13},{11,16},{12,14},{12,17},{13,18},{14,19},{15,18},{15,19},{16,19},{16,20},{17,20},{17,21},{18,21}};
pts=Map[Function[x,RootReduce[Sign[x.(root^Range[0,5])](Sqrt[Abs[x.(root^Range[0,5])]])]],vals, {2}];
Graphics[{EdgeForm[{Black}],Table[Line[pts[[unitlines[[n]]]]],{n,1,42}],White,Table[Tooltip[{Disk[pts[[n]],.16],Black, Style[Text[n,pts[[n]]],8]},vals[[n]]],{n,1,Length[pts]}]}, ImageSize-> Large]

Moser–Golomb Space: (Sqrt[33])
Δ=33: (M^2)-M-8=0 (M≈3.24698…)

The simplest 4-chromatic unit-distance graph is the Moser spindle, shown in black, which is in the space of (Sqrt[33]). The next famous 4-chromatic unit-distance graph is the Golomb graph, as shown in the Introduction. Between these two graphs up to five vertices can overlap.

vals={{{2,0},{22,0}},{{17,-1},{-7,-1}},{{-17,-1},{-7,1}},{{72,0},{0,0}},{{18,0},{-54,0}},{{-18,0},{-54,0}},{{-72,0},{0,0}},{{-18,0},{54,0}},{{18,0},{54,0}},{{0,0},{0,0}},{{-84,-12},{-24,0}},{{-77,-11},{7,1}}}/72; root=(Sqrt[33]);
points=Map[Function[x,RootReduce[Sign[x.{1,root}](Sqrt[Abs[(x).{1,root}]])]],vals, {2}];
unitlines=Select[Subsets[Range[12],{2}],Function[x,Chop[N[1-Apply[EuclideanDistance,N[points[[x]]]]]]==0]];
moseredge=Intersection[Subsets[{3,6,7,8,10,11,12},{2}],unitlines]; golombedge=Complement[unitlines,moseredge];
Graphics[{EdgeForm[{Black}],Table[Line[points[[moseredge[[n]]]]],{n,1,Length[moseredge]}],Cyan,Table[Line[points[[golombedge[[n]]]]],{n,1,Length[golombedge]}],Table[Tooltip[{If[MemberQ[{3,6,7,8,10,11,12},n],White,Cyan],Disk[points[[n]],.06]},vals[[n]]],{n,1,Length[points]}]}]

For a graph with hundreds of overlaps, see Moser Spindles, Golomb Graphs and Root 33.

Aubrey de Grey liked this Demonstration and corresponded with me to extend it.

de Grey Space: (Sqrt[3])+(Sqrt[5])+(Sqrt[7])+(Sqrt[11])
Δ=(4^8)(3^8)(5^8)(7^8)(11^8)

The first 5-chromatic unit-distance graph was the de Grey graph. All 1581 vertices are in the number field produced by square roots of (3, 5, 7, 11).

Rationals
Δ=1

For the 4-in-a-row problem, the best known solutions for 22, 23, 24, and 25 points all have simple rational coordinates. 
It seems to be very inefficient for the last few points.

Module[{name,root,vals,points,lines},
name= "4-in-a-Row Best Known Solutions for 25, 24, 23, 22 Points (rational)";
root=1;
points={{0,(1/4)},{0,(3/4)},{-1,(1/2)},{1,(1/2)},{-1,1},{1,1},{0,0},{0,(3/8)},{-(1/3),(1/3)},{(1/3),(1/3)},{-(1/3),(1/6)},{(1/3),(1/6)},{-(1/5),(2/5)},{(1/5),(2/5)},{-(1/5),(1/2)},{(1/5),(1/2)},{-1,-(1/2)},{1,-(1/2)},{-1,-1},{1,-1},{-(1/3),(2/3)},{(1/3),(2/3)},{-(1/3),-(2/3)},{(1/3),-(2/3)},{(9/5),-(6/5)}};
lines={{1,2,7,8},{1,3,9,12},{1,4,10,11},{1,5,13,18},{1,6,14,17},{1,15,20,21},{1,16,19,22},{2,3,6,21},{2,4,5,22},{2,9,15,17},{2,10,16,18},{2,11,13,19},{2,12,14,20},{3,4,15,16},{3,5,17,19},{3,7,11,18},{3,8,10,13},{4,6,18,20},{4,7,12,17},{4,8,9,14},{5,7,9,20},{5,8,12,15},{5,10,14,21},{6,7,10,19},{6,8,11,16},{6,9,13,22},{7,13,21,24},{7,14,22,23},{8,18,21,25},{9,11,21,23},{10,12,22,24},{17,20,23,25}};
Text[Column[{name, Graphics[{Table[InfiniteLine[Take[points[[lines[[n]]]],2]],{n,1,Length[lines]}],White,EdgeForm[Black],
Table[{Tooltip[Disk[points[[n]],.05], points[[n]]], Black,Style[Text[n,points[[n]]],8]},{n,1,Length[points]}],Black}, ImageSize-> {520}]}, Alignment-> Center]]]

On July 27, 2010, Chen, Engel, and Glotzer announced a packing of tetrahedra with density 4000/4671.

Manipulate[
Graphics3D[{Opacity[opacity],Table[Polygon[tetvertnew[[n]][[#]]]&/@dimerpolygons,{n,1,shown/2}]},
Boxed-> False, SphericalRegion-> True,ImageSize->{450,400}],
{{shown,72,"tetrahedra shown"},2,72,2,Appearance-> "Labeled"},
{{opacity,1,"opacity"},0,1,Appearance-> "Labeled"},
 Initialization:>(
dimer = {{2,2,2},{2,-1,-1},{-1,2,-1},{-1,-1,2},{-2,-2,-2}};
dimerpolygons = {{1,2,3},{1,2,4},{1,3,4},{2,3,4},{2,3,5},{2,4,5},{3,4,5}};
{a,b,c,d} = {{870,321,-21},{-102,831,405},{282,-249,741},{38,5,-25}}/320;
dimerpoints[{m_Integer,n_Integer,o_Integer}] := 
If[EvenQ[m+n+o],dimer + Table[{m a + n b + o c}[[1]],{5}],
-dimer + Table[{m a + n b + o c}[[1]] +d,{5}]];tetvertnew = dimerpoints[#]&/@Take[SortBy[Tuples[Range[0,3],{3}],{Max[#],Total[#]}&],36];
)]

And much more.

Graham space and Conclusion
Δ=2847113125901107200

Graham’s Biggest Little Hexagon is the hexagon of largest area where the maximum distance between vertices is 1. All vertices are in an degree-10 space.
The algebraic values are more unwieldy than the root objects.

Module[{name,root,vals,points,unitlines},
name= "Graham's Biggest Little Hexagon";
root=Root[210-690 #1+425 ((#1)^2)-88 ((#1)^3)+208 ((#1)^4)+100 ((#1)^5)-18 ((#1)^6)+8 ((#1)^7)-10 ((#1)^8)-2 ((#1)^9)+((#1)^10)&,4];
vals={{{0,0,0,0,0,0,0,0,0,0},{0,0,0,0,0,0,0,0,0,0}},{{(1/4),0,0,0,0,0,0,0,0,0},{0,0,-(1/4),0,0,0,0,0,0,0}},{{(121/256),(15/128),-(507/512),(139/512),(49/512),(3/512),(27/512),-(11/512),-(3/512),(1/512)},{-(135/256),(15/128),-(507/512),(139/512),(49/512),(3/512),(27/512),-(11/512),-(3/512),(1/512)}},{{0,0,0,0,0,0,0,0,0,0},{-1,0,0,0,0,0,0,0,0,0}},{{-(121/256),-(15/128),(507/512),-(139/512),-(49/512),-(3/512),-(27/512),(11/512),(3/512),-(1/512)},{-(135/256),(15/128),-(507/512),(139/512),(49/512),(3/512),(27/512),-(11/512),-(3/512),(1/512)}},{{-(1/4),0,0,0,0,0,0,0,0,0},{0,0,-(1/4),0,0,0,0,0,0,0}}};
points=FromSqrtSpace[root,vals];
unitlines=Select[Subsets[points,{2}],Chop[Quiet@N[1-Quiet@EuclideanDistance@@#]]==0&];
Text@Column[{name,"", Graphics[{EdgeForm[Black],White,Polygon[points],Red,Line/@ unitlines, White,
Table[{Disk[points[[n]],.03]},{n,1,Length[points]}], }, ImageSize-> 400]}, Alignment-> Center]]

And nothing more. This algebraic number seems to be good for one thing only.

If you have an number field of low degree, using algebraic roots might be helpful. 
For high-degree roots, they probably will not help.

Thank you

A larger exploration of this topic will soon be available as a series of notebooks.

Ed Pegg Jr
edp@wolfram.com