Message Boards Message Boards

[GiF] Fourier matrix product expander for recursive Koch polygons

GROUPS:

Jim Propp once asked: "Is there a way to relax an approximation to a space-filling curve in continuous time so that it works out its kinks and regresses to simpler approximations? No interim self-intersections please!" Julian Ziegler Hunts developed a Fourier matrix product that can produce the analogous animation.

enter image description here

Julian wrote a nifty Fourier expander for recursive Koch polygons. E.g.,

ptsgnlst2Fouriermat[{0, 1, I^(2/3), 1 + I^(2/3), 2}, {1, -1, 1, -1}]

spacefills the triangle joining 0 to 2 via 1+i√3. Actually, it makes an infinite 3x3 matrix product for the coefficients a(k). Then Sum a(k+1/m) exp(2 i π (k+1/m)) repeats the fractal on the sides of an m-gon. The GIF just accumulates consecutive harmonics. These are the definitions of functions:

ClearAll[ptsgnlst2Fouriermat]; 
ptsgnlst2Fouriermat[points_List, signs_List] := 
 Block[{Amat, Bmat, M, 
   klists = {(3 - signs)/2, Reverse[(signs + 3)/2]}, 
   pt0 = points[[1]], pt1 = points[[-1]], n = Length[signs], m = 2, c,x}, 
Amat = {#, Reverse[#]} &[
    signs*(Rest[points] - Most[points])/(pt1 - pt0)]; 
  Bmat = {#, Reverse[#]} &[-signs*pt0/(pt1 - pt0) + 
     points[[Range[n] + (1 - signs)/2]]]; 
  Function[x, c] /. c -> Append[Table[Append[
       Table[Exp[-I*x*(i - 1)/n]*Amat[[j, i]], {i, 1, n}].IdentityMatrix[m][[klists[[j]]]]/n, 
       Sum[Exp[-I*x*(i - 1)/n]*Bmat[[j, i]], {i, 1, n}]*I*(Exp[-I*x/n] - 1)/x], {j, 1, m}], 
     Table[Boole[i == m], {i, 0, m}]]];

    ClearAll[mat2series]; 
    mat2series[var_, mat_, n_, m_: 1, terms_, prodterms_, prec_: 60] := 
     Block[{A, x}, A[0] = Limit[mat[x], x -> 0]; A[x_] = mat[x]; 
      Exp[2*I*\[Pi]*Range[-terms + 1/m, terms + 1/m]*
         var].Table[(Dot @@ 
           Table[A[N[2*\[Pi]*(k + 1/m)/n^r, prec]], {r, 0, prodterms}])[[1 ;; -2, -1]], {k, -terms, terms}]]

Here is an example of 3-fold rotational symmetry:

Block[{start = 0, end = 1, m = -3., 
  f = mat2series[t, %, 7, -3., 33, MachinePrecision][[1]]}, 
 ParametricPlot[ReIm[f + Sum[
     E^(2 \[Pi] (k + 1/m) I t) I*(start - Exp[-2*I*\[Pi]/m]*end)/
         2/\[Pi]/(k + 1/m), {k, -33, 33}]], {t, 0, m}, Axes -> False]]

enter image description here

And here it is with higher details:

Block[{start = 0, end = 1, m = -3., 
  f = mat2series[t, %%, 7, -3., 69, MachinePrecision][[1]]}, 
 ParametricPlot[ReIm[f + Sum[
     E^(2 \[Pi] (k + 1/m) I t) I*(start - Exp[-2*I*\[Pi]/m]*end)/
         2/\[Pi]/(k + 1/m), {k, -69, 69}]], {t, 0, m}, Axes -> False]]

enter image description here

And given enough time the code below will produce the animation at the top of this post:

Table[Block[{start = 0, end = 2, m = 6., 
    f = mat2series[t, ptsgnlst2Fouriermat[{0, 1, I^(2/3), 1 + I^(2/3), 2}, 
    {1, -1, 1, -1}], 4, m, n, MachinePrecision][[1]]}, 
   ParametricPlot[ReIm[f + 
      Sum[E^(2 \[Pi] (k + 1/m) I t) I*(start - Exp[-2*I*\[Pi]/m]*end)/
           2/\[Pi]/(k + 1/m), {k, -n, n}]], {t, 0, 6}, Axes -> False]], {n, 99}];

Export["/Users/billgosper/Movies/hellodoily.gif", 
 Join[ConstantArray[%[[1]], 6], %, ConstantArray[%[[-1]], 9]]]
POSTED BY: Bill Gosper
Answer
7 months ago

Amazing work Julian.

POSTED BY: Zim Burns
Answer
3 months ago

Some code is missing -- please provide the actual expressions for % and %% used in your code.

For example, following your post and using these commands:

ptsgnlst2Fouriermat[{0, 1, I^(2/3), 1 + I^(2/3), 2}, {1, -1, 1, -1}]

Block[{start = 0, end = 1, m = -3., 
  f = mat2series[t, %, 7, -3., 33, MachinePrecision][[1]]}, 
 ParametricPlot[ReIm[f + Sum[E^(2 \[Pi] (k + 1/m) I t) I*(start - Exp[-2*I*\[Pi]/m]*end)/2/\[Pi]/(k + 1/m), {k, -33, 33}]], {t, 0, m}, Axes -> False]]

produces this image:

enter image description here

(Close but not quite...)

Update

After reading the last commands of OP's post, this works nicely:

Block[{start = 0, end = 2, m = 6., n = 32},
 f = mat2series[t, ptsgnlst2Fouriermat[{0, 1, I^(2/3), 1 + I^(2/3), 2}, {1, -1, 1, -1}], 4, m, n, MachinePrecision][[1]];
 ParametricPlot[ReIm[f + Sum[E^(2 \[Pi] (k + 1/m) I t) I*(start - Exp[-2*I*\[Pi]/m]*end)/2/\[Pi]/(k + 1/m), {k, -n, n}]], {t, 0, 6}, Axes -> False]]

enter image description here

POSTED BY: Anton Antonov
Answer
3 months ago

Group Abstract Group Abstract