Wolfram Research

Function Repository Resource:

SqrtSpace

Source Notebook

Move back and forth from the squared space or square root space of an algebraic number field

Contributed by: Ed Pegg Jr

ResourceFunction["SqrtSpace"][root,pts]

while tracking signs, converts Cartesian pts2 to algebraic values in (root) or converts those values back to Cartesian.

Examples

Basic Examples

Using ϕ, the golden ratio or Fibonacci’s rabbit constant, convert points to the algebraic number field (ϕ) and build the Fermat triangle:

In[1]:=
\[Phi] = GoldenRatio;
points = {{0, 0}, {0, 1}, {-Sqrt[\[Phi]], 0}};
Column[{ResourceFunction["SqrtSpace"][\[Phi], points], Graphics[{EdgeForm[Black], Yellow, Polygon[points]}]}]
Out[3]=

Using ψ, the supergolden ratio or Narayana’s cow constant, convert points to the algebraic number field (ψ) and build the supergolden triangle:

In[4]:=
\[Psi] = Root[-1 - #1^2 + #1^3 &, 1];
points = {{0, 0}, {1/2, Sqrt[3]/2}, {-\[Psi], 0}};
Column[{ResourceFunction["SqrtSpace"][\[Psi], points], Graphics[{EdgeForm[Black], Yellow, Polygon[points]}]}]
Out[6]=

Convert back to the original points:

In[7]:=
ResourceFunction[
 "SqrtSpace"][\[Psi], {{{0, 0, 0}, {0, 0, 0}}, {{1/4, 0, 0}, {3/4, 0, 0}}, {{0, 0, -1}, {0, 0, 0}}}]
Out[7]=

Properties and Relations

Under “Neat Examples” in GeometricScene, there is a mysterious output after “Decompose a triangle into similar triangles”:

In[8]:=
RandomInstance[GeometricScene[{a, b, c, d, g, e, f}, {
   p0 == Polygon[{e, g, f}],
   p1 == Style[Polygon[{a, b, c}], Cyan],
   p2 == Style[Polygon[{b, c, d}], Purple],
   p3 == Style[Polygon[{d, c, g}], Red],
   p4 == Style[Polygon[{g, c, a}], Green],
   p5 == Style[Polygon[{e, d, b}], Blue],
   p6 == Style[Polygon[{g, a, f}], Magenta],
   GeometricAssertion[{p0, p1, p2, p3, p4, p5, p6}, "Similar"],
   a == {-1/2, 0}, b == {1/2, 0}}], RandomSeeding -> 5]
Out[8]=

This triangle is in the algebraic number field / geometric space of (ρ) where ρ is the plastic constant:

In[9]:=
\[Rho] = Root[-1 - #1 + #1^3 &, 1]; vals = {{{-(1/4), 0, 0}, {0, 0, 0}}, {{1/4, 0, 0}, {0, 0, 0}}, {{0, 1/4, 1/4}, {-(1/4), 3/4, 1/4}}, {{1, 5/4, 5/4}, {-(1/4),
     3/4, 1/4}}, {{9/4, 4, 3}, {0, 0, 0}}, {{-(9/4), -4, -3}, {0, 0, 0}}, {{1/4, 1/4, -(1/4)}, {1, 7/4, 7/4}}}; triangles = {{1, 2, 3}, {2, 3, 4}, {4, 3, 7}, {7, 3, 1}, {5, 4, 2}, {7, 1, 6}};
points = ResourceFunction["SqrtSpace"][\[Rho], vals];
Graphics[{EdgeForm[
   Black], {Hue[Area[#]], #} & /@ (Polygon[points[[#]]] & /@ triangles)}]
Out[11]=

Convert the points back to original values:

In[12]:=
ResourceFunction["SqrtSpace"][\[Rho], points]
Out[12]=

A simple application of ToNumberField does not recognize the points as being in either (ρ) or , but does recognize the values when they get squared:

In[13]:=
\[Rho] = Root[-1 - #1 + #1^3 &, 1];
Column[{
  Quiet@ToNumberField[points[[3]], \[Rho]],
  Quiet@ToNumberField[points[[3]], Sqrt[\[Rho]]],
  ToNumberField[points[[3]]^2, \[Rho]]}]
Out[14]=

These values are algebraic numbers:

In[15]:=
AlgebraicNumber[\[Rho], #] & /@ {{0, 1/4, 1/4}, {-(1/4), 3/4, 1/4}}
Out[15]=

The actual point is also a pair of algebraic numbers:

In[16]:=
points[[3]]
Out[16]=

The signs here happen to be positive, so taking the square root of the algebraic version does not require extra steps:

In[17]:=
RootReduce[Sqrt[AlgebraicNumber[\[Rho], #]]] & /@ {{0, 1/4, 1/
   4}, {-(1/4), 3/4, 1/4}}
Out[17]=

Neat Examples

Convert 19 points from the algebraic number field (ρ) of the plastic constant ρ into 3D coordinates:

In[18]:=
\[Rho] = Root[-1 - #1 + #1^3 &, 1];
points = ResourceFunction[
  "SqrtSpace"][\[Rho], {{{-19, 0, 19}, {19, 76, 57}, {0, 0, 0}}, {{-76, -57, 57}, {0, 19, 57}, {0, 0, 0}}, {{0, -19, 0}, {76, 133, 76},
     {0, 0, 0}}, {{76, 76, 0}, {0, 0, 0}, {0, 0, 0}}, {{76, 95, 76}, {76, 133, 76}, {0, 0, 0}}, {{-38, 0, 19}, {38, 0, 19}, {0, 0, 0}}, {{95, 19, -57}, {-19, 57, -19}, {0, 0, 0}}, {{0, -19, 19}, {0, 19, 57}, {0, 0, 0}}, {{-38, 0, 19}, {42, 68, 43}, {-4, 8, 52}}, {{19, 38, -38}, {17, 42, 26}, {40, -4, 12}}, {{19, 38, -38}, {9, -18, 54}, {-28, 56, -16}}, {{0, -19, 19}, {36, 99,
       45}, {40, -4, 12}}, {{-152, -171, -76}, {76, 133, 76}, {0, 0, 0}}, {{76, 95, -76}, {76, 133, 76}, {0, 0, 0}}, {{76, -57, 0}, {76, 133, 76}, {0, 0, 0}}, {{76, 76, 0}, {16, 44, 20}, {60, 108, 56}}, {{95, 19, -57}, {49, 73, 9}, {8, 60, 48}}, {{-76, -57, 57}, {36, 99, 45}, {40, -4, 12}}, {{-19, 0, 19}, {47, 96, 73}, {-28, 56, -16}}}/76]
Out[19]=

Find the distances between these points in terms of powers of :

In[20]:=
Grid[Table[
  Quiet@Chop[
    N[Log[Sqrt[\[Rho]], EuclideanDistance[points[[a]], points[[b]]]]]], {a, 1, 19}, {b, 1, 19}]]
Out[20]=

Plot out the points:

In[21]:=
Graphics3D[{Map[Function[x, Tube[points[[x]], .02]], Subsets[Range[19], {2}]], Table[Sphere[points[[n]], .07], {n, 1, 19}]}, Boxed -> False,
  ImageSize -> Large, ViewPoint -> {0, 1, 40}]
Out[21]=

Requirements

Wolfram Language 11.3 (March 2018) or above

Resource History

License Information