Message Boards Message Boards

[GIF] Elaborating on Arrival's Alien Language, Part I., II. & III.

GROUPS:

I recently watched "Arrival", and thought that some of the dialogue sounded Wolfram-esque. Later, I saw the following blog post:

Quick, How Might the Alien Spacecraft Work?

Along with many others, I enjoyed the movie. The underlying artistic concept for the alien language reminded me of decade old memories, a book by Stephen Addiss, Art of Zen. Asian-influenced symbolism is an interesting place to start building a sci-fi concept, even for western audiences.

I also found Cristopher Wolfram's broadcast and the associated files:

Youtube Broadcast

Github Files ( with image files )

Thanks for sharing! More science fiction, yes!

I think the constraint of circular logograms could be loosened. This leads to interesting connections with theory of functions, which I think the Aliens would probably know about.

The following code takes an alien logogram as input and outputs a deformation according to do-it-yourself formulation of the Pendulum Elliptic Functions:

Human Animation

$m=2$ Inversion Coefficients

MultiFactorial[n_, nDim_] := Times[n, If[n - nDim > 1, MultiFactorial[n - nDim, nDim], 1]]
GeneralT[n_, m_] :=  Table[(-m)^(-j) MultiFactorial[i + m (j - 1) + 1, m]/ MultiFactorial[i + 1, m], {i, 1, n}, {j, 1, i}]
a[n_] := With[{gt = GeneralT[2 n, 2]}, gt[[2 #, Range[#]]] & /@ Range[n] ]

Pendulum Values : $2(1-\cos(x))$ Expansion Coefficients

c[n_ /; OddQ[n]] := c[n] = 0;
c[n_ /; EvenQ[n]] := c[n] = 2 (n!) (-2)^(n/2)/(n + 2)!;

Partial Bell Polynomials

Note: These polynomials are essentially the same as the "BellY" ( hilarious naming convention), but recursion optimized. See timing tests below.

B2[0, 0] = 1;
B2[n_ /; n > 0, 0] := 0;
B2[0, k_ /; k > 0] := 0;
B2[n_ /; n > 0, k_ /; k > 0] := B2[n, k] = Total[
    Binomial[n - 1, # - 1] c[#] B2[n - #, k - 1] & /@ 
     Range[1, n - k + 1] ];

Function Construction

BasisT[n_] :=  Table[B2[i, j]/(i!) Q^(i + 2 j), {i, 2, 2 n, 2}, {j, 1, i/2}]
PhaseSpaceExpansion[n_] :=   Times[Sqrt[2 \[Alpha]], 1 + Dot[MapThread[Dot, {BasisT[n], a[n]}], (2 \[Alpha])^Range[n]]];
AbsoluteTiming[CES50 = PhaseSpaceExpansion[50];] (* faster than 2(s) *)
Fast50 = Compile[{{\[Alpha], _Real}, {Q, _Real}}, Evaluate@CES50];

Image Processing

note: This method is a hack from ".jpg" to sort-of vector drawing. I haven't tested V11.1 vectorization functionality, but it seems like this could be a means to process all jpg's and output a file of vector polygons. Anyone ?

LogogramData = Import["Human1.jpg"];
Logogram01 = ImageData[ColorNegate@Binarize[LogogramData, .9]];
ArrayPlot@Logogram01;

Positions1 = 
  Position[Logogram01[[5 Range[3300/5], 5 Range[3300/5]]], 1];
Graphics[{Disk[#, 1.5] & /@ Positions1, Red, 
   Disk[{3300/5/2, 3300/5/2}, 10]}];
onePosCentered = 
  N[With[{cent = {3300/5/2, 3300/5/2} }, # - cent & /@ Positions1]];
radii = Norm /@ onePosCentered;
maxR = Max@radii;
normRadii = radii/maxR;
angles = ArcTan[#[[2]], #[[1]]] & /@ onePosCentered;
Qs = Cos /@ angles;

Constructing and Printing Image Frames

AlienWavefunction[R_, pixel_, normRad_, Qs_, angles_] := Module[{
   deformedRadii = MapThread[Fast50, {R normRad, Qs}],
   deformedVectors = Map[N[{Cos[#], Sin[#]}] &, angles],
   deformedCoords
   },
  deformedCoords = 
   MapThread[Times, {deformedRadii, deformedVectors}];
  Show[ PolarPlot[ Evaluate[
     CES50 /. {Q -> Cos[\[Phi]], \[Alpha] -> #/10} & /@ 
      Range[9]], {\[Phi], 0, 2 Pi}, Axes -> False, 
    PlotStyle -> Gray],
   Graphics[Disk[#, pixel] & /@ deformedCoords], ImageSize -> 500]]

AbsoluteTiming[  OneFrame = 
   AlienWavefunction[1, (1 + 1)* 1.5/maxR, normRadii, Qs, angles]
 ](* about 2.5 (s)*)

Alien Pendulum

Validation and Timing

In this code, we're using the magic algorithm to get up to about $100$ orders of magnitude in the half energy, $50$ in the energy. I did prove $m=1$ is equivalent to other published forms, but haven't found anything in the literature about $m=2$, and think that the proving will take more time, effort, and insight (?). For applications, we just race ahead without worrying too much, but do check with standard, known expansions:

EK50 = Normal@ Series[D[ Expand[CES50^2/2] /.  Q^n_ :> (1/2)^n Binomial[n, n/2], \[Alpha]], {\[Alpha], 0, 50}];
SameQ[Normal@  Series[(2/Pi) EllipticK[\[Alpha]], {\[Alpha], 0, 50}], EK50]
Plot[{(2/Pi) EllipticK[\[Alpha]], EK50}, {\[Alpha], .9, 1}, ImageSize -> 500]
Out[]:= True

Approximation Validity

This plot gives an idea of approximation validity via the time integral over $2\pi$ radians in phase space. Essentially, even the time converges up to, say, $\alpha = 0.92$. Most of the divergence is tied up in the critical point, which is difficult to notice in the phase space drawings above.

Also compare the time of function evaluation:

tDIY = Mean[ AbsoluteTiming[Fast50[.9, RandomReal[{0, 1}]] ][[1]] & /@ Range[10000]];
tMma = Mean[AbsoluteTiming[JacobiSN[.9, RandomReal[{0, 1}]] ][[1]] & /@ Range[10000]];
tMma/tDIY

In the region of sufficient convergence, Mathematica function JacobiSN is almost 20 times slower. The CES radius also requires a function call to JacobiCN, so an output-equivalent AlienWavefunction algorithm using built-in Mathematica functions would probably take at least 20 times as long to produce. When computing hundreds of images this is a noticeable slow down, something to avoid ! !

Also compare time to evaluate the functional basis via the Bell Polynomials:

 BasisT2[n_] := Table[BellY[i, j, c /@ Range[2 n]]/(i!) Q^(i + 2 j), {i, 2, 2 n,  2}, {j, 1, i/2}];
SameQ[BasisT2[20], BasisT[20]]
t1 = AbsoluteTiming[BasisT[#];][[1]] & /@ Range[100];
t2 = AbsoluteTiming[BasisT2[#];][[1]] & /@ Range[25];
ListLinePlot[{t1, t2}, ImageSize -> 500]

Series Inverse

The graph shows quite clearly that careful evaluation via the recursion relations changes the complexity of the inversion algorithm to polynomial time, $(n^2)$, in one special example where the forward series expansions coefficients have known, numeric values.

Conclusion

We show proof-of-concept that alien logograms admit deformations that preserve the cycle topology. Furthermore we provide an example calculation where the "human" logogram couples to a surface. Deformation corresponds to scale transformation of the logogram along the surface. Each deformation associates with an energy.

Invoking the pendulum analogy gives the energy a physical meaning in terms of gravity, but we are not limited to classical examples alone. The idea extends to arbitrary surfaces in two, three or four dimensions, as long as the surfaces have local extrema. Around the extrema, there will exist cycle contours, which we can inscript with the Alien logograms. This procedure leads readily to large form compositions, especially if the surface has many extrema. Beyond Fourier methods, we might also apply spherical harmonics, and hyperspherical harmonics to get around the limitation of planarity.

The missing proof... Maybe later. LOL! ~ ~ ~ ~ Brad

And in the Fanfiction Voice:

Physicist : "It should be no surprise that heptapod speech mechanism involves an arbitrary deformation of the spacetime manifold."

Linguist : "Space-traveling aliens, yes, of course they know math and physics, but Buddhist symbology, where'd they learn that?"

POSTED BY: Brad Klee
Answer
7 months ago

Part 2 : Overlap & Fourier Analysis

Code available at: Github Branch .

Time-Independent Calculations

Taking each logogram as a two-dimensional wavefunction $$ | \Psi_n \rangle : \langle i,j | \Psi_n \rangle = \text{pixel data (normalized) }, $$ calculate overlap for each pair $M_{n,m} =M_{m,n} = \langle \Psi_n | \Psi_m \rangle $ :

overlaps

By row take the largest value other than $M_{n,n}=1$, and plot the superposition

superposition

Create wavefunctions

$$| \cos( n \phi ) \rangle: \langle i,j | \cos( n \phi ) \rangle = \cos(n \arctan(i,j)),$$ $$| \sin( n \phi ) \rangle: \langle i,j | \cos( n \phi ) \rangle = \sin(n \arctan(i,j)),$$

and use these to calculate the Fourier Amplitudes

$$FC_{n,m}=\langle \cos( n \phi ) | \Psi_m \rangle^2, $$ $$FS_{n,m}=\langle \sin( n \phi ) | \Psi_m \rangle^2, $$

Sum to obtain the total squared amplitude

$F_{m,n} = FC_{m,n}+FS_{m,n} $

For each wavefunction index by $m$, list plot the $n$ sequence. Also plot the most symmetric graphs.

Fourier Analysis I

more fanfiction:

Scientist: One plus one plus one, equals three. Three spatial dimensions, represented by approximate cyclic symmetry.

Linguist: Time goes around the circle. Clockwise or counterclockwise, endlessly repeating.

Scientist: Minus $d\tau^2$ equals $ds^2$. Surely the Aliens have some conception of special relativity. Logogram number 22, I'm starting to think that "spacetime" is a better translation than "time".

Linguist: The three lobes bear some resemblance to the partials for "suffering", "liberation". This third one, I don't know, looks like "stillness", possibly "death".

POSTED BY: Brad Klee
Answer
7 months ago

Part 3: Time Dependent Fourier Analysis

Again, notebook available at: Time Dependence .

Building on the Part 1 code above, we also expand the phase-space angular velocity $\dot{\phi}$ to $50$ powers of $\alpha$, the dimensionless energy. This is possible in relatively short time because $\dot{\phi}$ expands in powers of the phase space radius, which compute quickly enough, say, less than $5(s)$ to $r^{100}$. A good-enough function for $\dot{\phi}$ allows iteration of time evolution, drawing of animations, and time-dependent Fourier analysis.

H[n_, rep_] :=  ReplaceRepeated[(1/2) q^2 + (1/2) p^2 +   
 Total[(1/2) c[2 #]/((2 #)!) (q)^(2 + 2 #) & /@ Range[n]], rep]

\[Phi]Dot[n_, rep_] :=  ReplaceRepeated[  Divide[-Expand[D[H[n, {}], p] p + D[H[n, {}], q] q], p^2 + q^2], rep]

CES50Squared = Expand[Normal@Series[CES50^2, {\[Alpha], 0, 50}]];
Clear@Pow\[CapitalPsi];
Pow\[CapitalPsi][0] = 1;
Pow\[CapitalPsi][n_] := 
 Pow\[CapitalPsi][n] = 
  Expand[Normal@
    Series[Pow\[CapitalPsi][n - 2]*CES50Squared, {\[Alpha], 0, 50}]]

AbsoluteTiming[Pow\[CapitalPsi][100];]

Expand[
 H[50, {p^2 -> \[CapitalPsi]^2 - q^2, 
    q -> \[CapitalPsi] Q}] /. {Power[\[CapitalPsi], n_] :> 
    Pow\[CapitalPsi][n]}]

 \[Alpha]

AbsoluteTiming[  \[Phi]Dot50 =    Expand[Expand[\[Phi]Dot[  50, {p^2 -> \[CapitalPsi]^2 - q^2, 
        q -> \[CapitalPsi] Q}]] /. {Power[\[CapitalPsi], n_] :>  Pow\[CapitalPsi][n]}]; ]

FastCES50 = Compile[{{\[Alpha], _Real}, {Q, _Real}}, Evaluate@CES50];
Fast\[Phi]Dot50 = Compile[{{\[Alpha], _Real}, {Q, _Real}}, Evaluate@\[Phi]Dot50];

 AbsoluteTiming[Fast\[Phi]Dot50[.1, .5]]
 AbsoluteTiming[FastCES50[.9, 0]]

TestPeriod = Show[  ListLinePlot@
   NestList[# + Fast\[Phi]Dot50[.9, Cos[#]] (.1) &, 0, 
    Floor[2 Pi 2/Pi EllipticK[.9] 10]],
  Plot[N[-Pi], {x, 0, 2000}]
  ];

Also notice, evaluating this code, there exists a function $H(\Psi)$, the pendulum Hamiltonian, such that the CES, $\Psi(\alpha)$ here, satisfies the composition constraint $H(\Psi(\alpha))=\alpha$.

The Animations

Starting at time $t_0$, evolve each point in the ensemble according to $\phi_{n+1} = \phi_{n} + dt\;\dot{\phi}$, with $dt$ a small time step.

Time Evolution

Recall that the period of motion depends on the CES or equivalently on energy parameter $\alpha$. At a later time the ensemble smears out, as with "Arnold's cat" .

Time evolution

After a long enough time, the alien "logograms" look even more suspiciously like the older "Enso" diagrams. As in M.S. Child's Semiclassical Mechanics, Fig. 8.4 , we project the ensemble onto the $q$ axis to obtain $|\Psi(q)\rangle$. For $t_0$:

QWave1

After some time

QWave2

After $5000$ time steps, plot the autocorrelation function $\langle \Psi(q,t=0) | \Psi(q,t) \rangle $

Autocorrelation

which gives a useful metric for the smearing behavior seen above. Furthermore the autocorrelation signal shows periodicity as expected. This leads to a Fourier analysis for time-frequency. We partition the autocorrelation function into parts of length $T=\frac{2\pi}{\omega}$, and compute the amplitudes by taking all possible dot products

FourierMetric[data_, n_] :=  With[{dat = Normalize /@ Partition[data - Mean[data], n]},
  Mean@Flatten[ Table[Dot[dat[[i]], dat[[j]]], {i, 1, Length[dat]}, {j, 1, i}]]]

Time Fourier

What a cool hacker graph! Beneath the Fourier spectrum, we show overlap between the parts of the autocorrelation function. In the spectrum above, the solid lines are odd multiples of $\frac{\omega}{2}$, the quantum harmonic oscillator expectations. There's an overtone at $\frac{3}{2} \omega$, as expected considering the symmetry of the "Time" logogram. The best part of this code is how messy the spectrum looks. It's not necessarily better or worse than a lab measurement of Iodine. The lab data could be considerably worse if you don't have a feel for how the diffraction slit works.

POSTED BY: Brad Klee
Answer
7 months ago

Part 4: Constructing a Heptapod Sentence

In the following code we construct the Heptapod sentence for:

Painted Surface

"Teach all humans to solve time."

For complete code see: Plaintext, Notebook .

We assume the Gyroid surface appropriate for the sentence grammar, and approximate the geometric structure via the usual implicit equation

$$\sin(x + \pi/2) \cos(y + \pi/2) + \sin(y + \pi/2) \cos(z + \pi/2) + \sin(z + \pi/2) \cos(x + \pi/2)=0.$$

At the so-called monkey-saddle points, the surface expands naturally in cylindrical coordinates, with the $z$-axis along the surface normal. Applying series inversion to solve for $z(r,\theta)$ obtains a trigonometric function that coordinatizes a local patch of the surface. Even under modest series truncation, the patch combined with global, periodic structure provides an adequate cover of the entire surface. These equations allow construction of arbitrarily large alien texts, simply by mapping the logograms onto the surface contours.

ApproxGyroid =   Sin[x + Pi/2] Cos[y + Pi/2] + Sin[y + Pi/2] Cos[z + Pi/2] + Sin[z + Pi/2] Cos[x + Pi/2];
normal[mno_] := {
  If[OddQ[mno[[3]]], -1, 1],
  If[OddQ[mno[[1]]], -1, 1],
  If[OddQ[mno[[2]]], -1, 1]
  }

dualNormal[mno_] := {
  If[OddQ[mno[[2]]], -1, 1],
  If[OddQ[mno[[3]]], -1, 1],
  If[OddQ[mno[[1]]], -1, 1]
  }

xyz[mno_] :=  Plus[Times[mno, {Pi, Pi, Pi}], {Pi/2, Pi/2, Pi/2}]

Contour[mno_] :=  Plus[RotationMatrix[{{0, 0, 1}, normal[mno]}].{r Cos[\[Phi]], r Sin[\[Phi]],
    Normal[      InverseSeries[ Series[ApproxGyroid /. {x -> x + xyz[mno][[1]], 
            y -> y + xyz[mno][[2]], z -> z + xyz[mno][[3]]} /. 
          MapThread[Rule,  {{x, y, z}, 
            RotationMatrix[{{0, 0, 1}, normal[mno]}].{x, y, 
              z}}] /. {x -> r Cos[\[Phi]], y -> r Sin[\[Phi]]}, {z, 0,
          4}], y]] /. y -> 0}, xyz[mno] ]

DualContour[mno_] :=  Plus[RotationMatrix[{{0, 0, 1}, dualNormal[mno]}].{r Cos[\[Phi]], 
    r Sin[\[Phi]], Normal[InverseSeries[Series[
        ApproxGyroid /. {x -> x + Pi/2 + xyz[mno][[1]], 
            y -> y + Pi/2 + xyz[mno][[2]], 
            z -> z + Pi/2 + xyz[mno][[3]]} /. MapThread[Rule,
           {{x, y, z}, 
            RotationMatrix[{{0, 0, 1}, dualNormal[mno]}].{x, y, 
              z}}] /. {x -> r Cos[\[Phi]], y -> r Sin[\[Phi]]}, {z, 0,
          4}], y]] /. y -> 0},  xyz[mno] + {Pi/2, Pi/2, Pi/2}]

 AbsoluteTiming[ ContoursF = TrigReduce[  Normal@Series[ Contour /@ Tuples[{0, 1}, 3], {r, 0, 7}]];
 DualContoursF =   TrigReduce[   Normal@Series[      DualContour /@ Join[IdentityMatrix[3], -IdentityMatrix[3]],
 {r,  0, 7}]]; (* About 80(s) for me *)

 CentralDualContour = TrigReduce[Normal@Series[DualContour[{0, 0, 0}], {r, 0, 7}]];]

equation

Notice that the powers $r^n$ higher than $n=1$, the perturbative terms, all attach to $2\pi/3$ periodic functions. Compare this with earlier Fourier analysis, which characterizes the obvious symmetry of the Time symbol itself. Compare with the standard Mathematica Drawing

g0 = ContourPlot3D[
   ApproxGyroid == 0, {x, 0, 2 Pi}, {y, 0, 2 Pi}, {z, 0, 2 Pi}, 
   Mesh -> 3, ContourStyle -> Directive[Blue, Opacity[0.5]], 
   Boxed -> False, Axes -> False];

ContourDrawing = Show[g0,
  ParametricPlot3D[  Evaluate[(ContoursF /. r -> #/4)], {\[Phi], 0, 2 Pi}, 
     PlotStyle -> Directive[Thick, Blend[{Yellow, Green}, 2/3]]] & /@ 
   Range[7],  ParametricPlot3D[
     Evaluate[(DualContoursF /. r -> #/4)], {\[Phi], 0, 2 Pi}, 
     PlotStyle -> Directive[Thick, Darker@Blue]] & /@ Range[7],
  ParametricPlot3D[
     Evaluate[(CentralDualContour /. r -> #/4)], {\[Phi], 0, 2 Pi}, 
     PlotStyle -> Directive[Thick, Darker@Cyan]] & /@ Range[7], 
PlotRange -> All, Boxed -> False, Axes -> False, ImageSize -> 800  ]

surface

With a little more effort, we produce the following DIY drawing:

Contour Rotation

which shows the various patches overlapping sufficiently along all boundaries. This contour graph is essentially hand-writing paper that helps to align the alien logograms. In this particular sentence, Earth occupies a central position, and is surrounded by "time" repeated on 8 locations. While the symbols for "human", "humanity", "solve", "solve on you now", "use marker write", "there is no linear time" occupy the remaining six locations on the dual lattice.

More Fanfiction ( The Fight )

Linguist: Is this impermanence between us nothing more than a time ratio to you?

Scientist: A time ratio, yes. One person's lifetime, to the duration of a spoken lie, to all your social time. Unless blame outlasts, say, the galactic lifetime, I don't care !

Linguist: What about family time? You're willing to loose a wife because you need perfect ordering to work? A marriage isn't a monastery, get over it!

POSTED BY: Brad Klee
Answer
7 months ago

Thanks for sharing, very elaborate and nicely visualised!

POSTED BY: Sander Huisman
Answer
7 months ago

Hi Sander,

Thanks for the compliment. You're also doing well with the recent Chaos game. Could be interesting to see a variation of your code for a mapping between the coherent logogram ring structure and diffuse pixel-dust.

But I am still worried that maybe the aliens have some extra-sensory perception for geometric powers of $r$, so I did some more surface calculation starting with the condition for minimal surfaces:

$$(1+h_x^2)h_{yy} - 2 h_x h_y h_{xy} + (1+h_y^2)h_{xx}=0,$$

another one of Lagrange's equations. I have never seen an expansion solution of this equation, but can produce one easily. Here we include only odd powers of $r$ and angular dependence $2\pi/3$ periodic. Since the constraint is in cartesian coordinates, we define the following variables:

r = Sqrt[x^2 + y^2]; P = y/r; Q = x/r;
Q3 = 4 Q^3 - 3 Q; P3 = 3 P - 4 P^3;

And construct the surface as a ring over these variables

indList[n_ /; OddQ[n]] := Flatten[Table[{n, i - j, j}, {i, 1, Floor[n/3], 2}, {j, 0, i}], 1]
indList[n_ /; EvenQ[n]] :=  Flatten[Table[{n, i - j, j}, {i, 0, Floor[n/3], 2}, {j, 0, i}], 1]
params = Flatten[indList[2 # + 1] & /@ Range[7], 1];
(*params = Flatten[indList[#]&/@Range[2,15],1];*)
AbsoluteTiming[ \[CapitalPsi] =  Expand[Simplify[     Expand[Total[
       Times[c @@ #, r^#[[1]], Q3^#[[2]], P3^#[[3]] ] & /@   params]]]]; ]


d\[CapitalPsi]dx = D[\[CapitalPsi], x];
d\[CapitalPsi]dy = D[\[CapitalPsi], y];
d2\[CapitalPsi]dx2 = D[\[CapitalPsi], {x, 2}];
d2\[CapitalPsi]dy2 = D[\[CapitalPsi], {y, 2}];
d2\[CapitalPsi]dxdy = D[D[\[CapitalPsi], x], y];

AbsoluteTiming[ testExp = Expand[((1 + d\[CapitalPsi]dx^2)*d2\[CapitalPsi]dy2 - 
      2 d\[CapitalPsi]dx d\[CapitalPsi]dy d2\[CapitalPsi]dxdy + (1 + 
         d\[CapitalPsi]dy^2)*d2\[CapitalPsi]dx2)]; ]

And solve,

Sols[n_] := Fold[Join[#1, Expand@Solve[#2 /. #1 ][[1]]] &, {}, Function[{a}, # == 
         0 & /@ (Coefficient[Coefficient[testExp, x, #], y, a - #] & /@
          Range[0, a])][#] & /@ (2 Range[n] + 1)]

AbsoluteTiming[ With[{Sol6 = Sols[6]}, SolList =    Cases[Sol6, 
HoldPattern@Rule[c[n_ /; n < Evaluate[2 #], _, _], _]] & /@ 
     Range[3, 8]; ]]

These values cause cancellation of the first few coefficients in the expansion of the mean curvature numerator

Expand[Function[{a}, ((Coefficient[Coefficient[testExp, x, #], y, 
            a - #] //. SolList[[-1]]) & /@ Range[0, a])][#] & /@ Range[0, 13]] // TableForm

zero triangle

The solution is a formal power series, not gauranteed to converge. However, if the coefficients decrease quickly as powers of $r$ increase, convergence should occur. We choose coefficients $1/n!$ for terms with $r^n$. A test of the error is given by change in amplitude with change in iteration parameter, relative to the total amplitude at radius $r=1$.

ErrorFunctions =   Evaluate[Partition[ \[CapitalPsi] /. 
        SolList /. {c[x_, _, 0] :> 1/x!, c[_, _, _] -> 0}, 2, 1] /.
     {x_, y_} :> 100 Subtract[y, x]/Mean[{y, x}] /. {x -> 
      Cos[\[Theta]], y -> Sin[\[Theta]]}];

LogPlot[ErrorFunctions[[{1, 3, 5}]], {\[Theta], 0, 2 Pi},
 AxesLabel -> {"Angle", "Percent
   Error"}, ImageSize -> 500, PlotRange -> Full]

Surface Convergence

As iteration of the recursive solution algorithm increases, the difference oscillates more rapidly and with a decreasing amplitude. By a sixth approximation, already converges to $0.05\%$. Good enough.

It's also possible to measure convergence of the mean curvature to zero as a function of the iteration parameter

MeanCurvatureConvergence =   N[(testExp //. SolList[[#]] /. {c[x_, _, 0] :> 1/x!, 
c[_, _, _] -> 0} /. x -> Cos[Pi] /. y -> Sin[Pi]) & /@ Range[6]];

ListLogPlot[MeanCurvatureConvergence, PlotRange -> All, 
AxesLabel -> {"Iteration", "Curvature
Numerator"}, Joined -> True, ImageSize -> 500]

Curvature Convergence

So yes, the surface as written appears to converge toward minimal form,

\[CapitalPsi]6 =  Expand[\[CapitalPsi] /. SolList[[-1]] /. {c[x_, _, 0] :> 1/x!,  c[_, _, _] -> 0}]
Expand[TrigReduce[\[CapitalPsi]6 /. {x -> \[Rho] Cos[\[Phi]],     y -> \[Rho] Sin[\[Phi]]}]]

Surface Eq Surface Eq2

Finally, the logogram plot, "earth" + "walk",

Minimal Surface

This deformed logogram looks quite similar to those above. However the equations underlying this surface have no $r^5$ term. It seems that a $2\pi/3$ periodic minimal surface, which expands in whole powers of $r$, cannot have an $r^5$ term. Compare with previous expansions, which are not minimal and do have a term like $r^5$.

We have yet to find parameter values that lead to periodic surfaces, but already have obtained a surface geometry that could be tested in nature. The famous soap film experiment should yield surfaces as seen at math.hmc.edu and daviddarling.info .

POSTED BY: Brad Klee
Answer
7 months ago

Okay S.B. is officially over, so what am I even doing still theorizing about Alien writing systems? No one knows for sure. Maybe in an obtuse way, it's another dissertation topic in the making. One more discovery to write out, then hopefully I will get back to more mundane, professionally acceptable activities.

Part N. Approximating and Inscribing the Schwarz P Surface

The Schwarz Minimal Surface, P for Primitive, is simple and symmetrical, perhaps a better starting place than the Gyroid. A common approximation is given by:

$$\cos(x)+\cos(y)+\cos(z)=0,$$

but this is wrong, and goes against the definition provided by Lagrange's equation above. Discrepancies, including another $r^5$ problem, become apparent when subjecting the trial function to due scrutiny. As above, start by rotating coordinates and solving for height along the surface normal,

ApproxP = Sin[x] + Cos[y - Pi/2] + Sin[w];
ApproxP2 =   ApproxP /.   MapThread[
Rule, {{x, y, w},  RotationMatrix[{{0, 0, 1}, {1, 1, 1}}].{x, y, w}}];

ContourF =   Normal[Series[
Normal[InverseSeries[Series[ApproxP2, {w, 0, 5}], k]] /. {k -> 0, 
x -> \[Rho] Cos[\[Phi]], y -> \[Rho] Sin[\[Phi]]}, {\[Rho], 0, 5}]];
Expand[TrigReduce[ContourF]]
ContourFxy  =  Expand[ContourF /. {Cos[\[Phi]] -> x/\[Rho], 
Sin[\[Phi]] -> y/\[Rho]}]

EqOut

This expansion provides a baseline for comparison. Again define expansion variables, this time a pair with dihedral-3 symmetry,

r = Sqrt[x^2 + y^2]; P = y/r; Q = x/r;
Q3 = 4 Q^3 - 3 Q; P3 = 3 P - 4 P^3;
g3 = Expand[r^3 Q3 ];
g2 = x^2 + y^2.

Then generate expansion primitives up to a large order, say $21$,

indList[n_] :=  Select[IntegerPartitions[n], 
  MemberQ[{{2, 3}, {2}, {3}}, Union[#]] &]
coeff[ind_] :=  c @@ Flatten[{Cases[Tally[ind], {2, x_} :> x], 
     Cases[Tally[ind], {3, x_} :> x]} /. {} -> 0]
params = Flatten[indList[#] & /@ Range[2, 21], 1]; 

Expand and cancel terms order-by-order

\[CapitalPsi] =   Expand[Total[(coeff[#] Times @@ (# /. {2 -> g2, 3 -> g3})) & /@   params]];
MeanCurvatureNumerator[F_] := Expand[((1 + D[F, x]^2)*D[F, {y, 2}] - 
2 D[F, x] *D[F, y] *D[D[F, y], x] + (1 + D[F, y]^2)*D[F, {x, 2}])]

AbsoluteTiming[ CurvExp = Expand[MeanCurvatureNumerator[\[CapitalPsi]]]; ] (*10(s)*)

Sols[n_] :=  Fold[Join[#1, Expand@Solve[#2[[2]] /. #1 , #2[[1]]][[1]]] &, {},
Transpose[{(coeff /@ indList[2 + #]) & /@ Range[0, n],
Function[{a}, # == 0 & /@ (Coefficient[Coefficient[CurvExp, x, #], y, 
a - #] & /@ Range[0, a])][#] & /@ (Range[0, n])}] ] // Quiet

AbsoluteTiming[ S19 = Sols[19];]

The first thing to check is:

In[]:= S19[[3]]
Out[]= c[1, 1] -> 0

According to the convention for coefficients, $c_{1,1}$ attaches to the only $r^5$ term, so again, a dihedral-3 surface patch cannot have an $r^5$ term and also satisfy the zero curvature condition. The next check is for degrees of freedom

Length@indList[#] & /@ Range[21]
Subtract[%,  Range[21] /. Append[Rule @@ # & /@ 
Tally[S19[[All, 1]] /. c[x_, y_] :> 2 x + 3 y], x_Integer :> 0]]
Out[] = {0, 1, 1, 1, 1, 2, 1, 2, 2, 2, 2, 3, 2, 3, 3, 3, 3, 4, 3, 4, 4}
Out[] = {0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1}

This is an intriguing reduction, that seems to imply the degrees of freedom are enough for any boundary that expands in terms $\cos(3nx)$, even implying that this method could lead to an exact solution. But our solution today is only "fast richtig", and rather than suffering over the boundary conditions too much, we simply set $c_{n,m}=1/(2n+3m)!$, to force convergence in a small region around the expansion point, quickly!

\[CapitalPsi]19 = \[CapitalPsi] //. S19 /.   c[x_, y_] :> 1/(2 x + 3 y)!
TrigReduce[\[CapitalPsi]19 /. {x -> \[Rho] Cos[\[Phi]],  y -> \[Rho] Sin[\[Phi]]}]

More Equations

Next, compare the curvature

MeanCurvature[F_] := Divide[
Expand[((1 + D[F, x]^2)*D[F, {y, 2}] - 
2 D[F, x] *D[F, y] *D[D[F, y], x] + (1 + D[F, y]^2)*
D[F, {x, 2}])],  (1 + D[F, x]^2 + D[F, y]^2)^(3/2)]

curv1 = MeanCurvature[ContourFxy];
curv2 = MeanCurvature[\[CapitalPsi] //. S19 /. c[x_, y_] :> 1/(2 x + 3 y)!];

Row[{Plot3D[{curv1, curv2}, {y, -7/5, 7/5}, {x, -7/5, 7/5}, 
PlotRange -> All,    RegionFunction -> Function[{x, y, z}, x^2 + y^2 <= (6/5)^2], 
ImageSize -> 400],
Plot3D[{curv1, curv2}, {y, -7/5, 7/5}, {x, -7/5, 7/5},    PlotRange -> All, 
RegionFunction -> Function[{x, y, z}, x^2 + y^2 <= (7/5)^2], 
ImageSize -> 400]}]

Curvature The left image, up to $r=6/5$ shows approximately zero curvature for the $\Psi$ expansion, along the flat blue disk, compared with values about $0.1$ for the common expansion, depicted as a warped orange disk. In the right image, breakdown of the approximation begins to show at $r = 7/5$, which sets an outermost boundary. Yet the approximation $\Psi$ still seems considerably better than the simple approximation.

This is all the groundwork we need, the rest is simply extension of the code above. The results,

P Surface

When I have more time and peace of mind, I will see if I can figure out the boundary conditions. As for now they look good enough by guesswork. I don't know the thing about Weierstrass parameters, I probably never will ! More code here .

POSTED BY: Brad Klee
Answer
7 months ago

enter image description here - Congratulations! This post is now a Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

POSTED BY: Moderation Team
Answer
7 months ago

Group Abstract Group Abstract