       4th subharmoic functions

• To: mathgroup at smc.vnet.net
• Subject: [mg52541] 4th subharmoic functions
• From: Roger Bagula <tftn at earthlink.net>
• Date: Wed, 1 Dec 2004 05:58:14 -0500 (EST)
• Sender: owner-wri-mathgroup at wolfram.com

```These actually give a spiral and not a circle when added together.
They are my best bet so far at the next level of complexity in
a subharmonic reduction of a circle.  Groups of this type are different
than
traditional rotation and point groups and determinant groups as they are
based on substitution groups
that have associated fractal effects. I found this IFS space fill this year
in my trifraction expertiments. If you take away the (x/2+1/2,y/2+1/2)
it becomes a nonlinear equivalent to a Sierpinski gasket which I called
I've included a short IFS demonstration program at the end.

(*using a set of functions that give a space filling curve in True Basic
as as an  IFS to get a set of 4th level subharmonic functions*)
(* based on for parts of the functional inversion group of the
anharmonic group with x->x/2 and x+1->x/2+1/2*)
digits=100
f1[n_]:=n/2/;Mod[n,4]==1
f1[n_]:=n/2+1/2/;Mod[n,4]==2
f1[n_]:=n/(1+n)/;Mod[n,4]==3
f1[n_]:=1/(1+n)/;Mod[n,4]==0

f2[n_]:=n/2/;Mod[n,4]==2
f2[n_]:=n/2+1/2/;Mod[n,4]==3
f2[n_]:=n/(1+n)/;Mod[n,4]==0
f2[n_]:=1/(1+n)/;Mod[n,4]==1

f3[n_]:=n/2/;Mod[n,4]==3
f3[n_]:=n/2+1/2/;Mod[n,4]==0
f3[n_]:=n/(1+n)/;Mod[n,4]==1
f3[n_]:=1/(1+n)/;Mod[n,4]==2

f4[n_]:=n/2/;Mod[n,4]==0
f4[n_]:=n/2+1/2/;Mod[n,4]==1
f4[n_]:=n/(1+n)/;Mod[n,4]==2
f4[n_]:=1/(1+n)/;Mod[n,4]==3

f1sin[x_]:=Sum[(-1)^(n)*f1[n]*x^(2*n+1)/((2*n+1)!),{n,0,digits}]
f2sin[x_]:=Sum[(-1)^(n)*f2[n]*x^(2*n+1)/((2*n+1)!),{n,0,digits}]
f3sin[x_]:=Sum[(-1)^(n)*f3[n]*x^(2*n+1)/((2*n+1)!),{n,0,digits}]
f4sin[x_]:=Sum[(-1)^(n)*f4[n]*x^(2*n+1)/((2*n+1)!),{n,0,digits}]

f1cos[x_]:=Sum[(-1)^(n)*f1[n]*x^(2*n)/((2*n)!),{n,0,digits}]
f2cos[x_]:=Sum[(-1)^(n)*f2[n]*x^(2*n)/((2*n)!),{n,0,digits}]
f3cos[x_]:=Sum[(-1)^(n)*f3[n]*x^(2*n)/((2*n)!),{n,0,digits}]
f4cos[x_]:=Sum[(-1)^(n)*f4[n]*x^(2*n)/((2*n)!),{n,0,digits}]

Plot[f1sin[x],{x,-Pi,Pi}]
Plot[f1cos[x],{x,-Pi,Pi}]

Plot[f2sin[x],{x,-Pi,Pi}]
Plot[f2cos[x],{x,-Pi,Pi}]

Plot[f3sin[x],{x,-Pi,Pi}]
Plot[f3cos[x],{x,-Pi,Pi}]

Plot[f4sin[x],{x,-Pi,Pi}]
Plot[f4cos[x],{x,-Pi,Pi}]

Plot[f1sin[x]+f2sin[x]+f3sin[x]+f4sin[x],{x,-Pi,Pi}]
Plot[f1cos[x]+f2cos[x]+f3cos[x]+f4cos[x],{x,-Pi,Pi}]

ParametricPlot[{f1sin[x]+f2sin[x]+f3sin[x]+f4sin[x],f1cos[x]+f2cos[x]+f3cos[x]+f4cos[x]},{x,-Pi,Pi}]

(* ifs of the four parts function as two 1d ifs*)
f1[{x_,y_}] = {x/2, y/2};
f2[{x_,y_}] = {1/(x+1), y/(y+1)};
f3[{x_,y_}] = {x/(x+1), 1/(y+1)};
f4[{x_,y_}] = {x/2+1/2, y/2+1/2};
f[x_] := Which[(r=Random[]) <= 1/4, f1[x],r <=2/4, f2[x],r <= 3/4,
f3[x],r <= 1.00, f4[x]]
ifs[n_] := Show[Graphics[{PointSize[.001],
Map[Point, NestList[f, {0,0}, n]]}],
PlotRange->All,AspectRatio->Automatic]
ifs
Respectfully, Roger L. Bagula