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)
- Reply-to: tftn at earthlink.net
- 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
a trifraction about 1999.
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*)
(* quadfraction as nonlinear spacefill*)
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[10000]
Respectfully, Roger L. Bagula
tftn at earthlink.net, 11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 :
alternative email: rlbtftn at netscape.net
URL : http://home.earthlink.net/~tftn