MathGroup Archive 2004

[Date Index] [Thread Index] [Author Index]

Search the Archive

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


  • Prev by Date: Re: pair sums applied to trignometry sums
  • Next by Date: Re: New User - Programming
  • Previous by thread: Re: Inserting user material in the HelpBrowser
  • Next by thread: Re: Re: Proving inequalities with Mathematica