Group Abstract Group Abstract

Message Boards Message Boards

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

Posted 9 years ago
POSTED BY: Brad Klee
8 Replies
Posted 2 years ago
POSTED BY: Ashkan Rezaee

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

POSTED BY: EDITORIAL BOARD
Posted 9 years 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
Posted 9 years 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

Thanks for sharing, very elaborate and nicely visualised!

POSTED BY: Sander Huisman
Posted 9 years ago
POSTED BY: Brad Klee
Posted 9 years ago
POSTED BY: Brad Klee
Posted 9 years 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