Four Triangle Fractals using Bucky Numbers and Synergetics Coordinates

By Cliff Nelson

Abstract

(Subscript[B, 3]) numbers and my version of "Synergetics coordinates" are used to make four fractals based on the same method: the Sierpinski triangle when the Mean is used; a trefoil I call the Harmonic Trinity when the HarmonicMean is used; half of a circle when the GeometricMean is used; and something else when the RootMeanSquare is used.

Reference

Initialization

VertexesOf[x_List,n_Integer]:=ReplacePart[x,-Plus@@Delete[x,-n],-n]

VertexesOf[x_List]:=(VertexesOf[x,#1]&)/@Range[Length[x]]

VertexesOf[x_B]:=VertexesOf[List@@Drop[x,-1]]

StoP[x_List]:=Module[{wx=x,anser={},i},Do[anser=Prepend[anser,-((wx[[i]] (Sqrt[Tri[i]]))/(i-1))];wx=Drop[wx,-1]+((wx[[i]])/(i-1)),{i,Length[x],2,-1}];anser]

Tri[n_Integer]:=(1/2) n (n-1)

StraightLineDistance[x_List]:=(Sqrt[((Plus@@(x^2))/2)])

VectorDistance[x_List]:=(1/2) Plus@@Sqrt/@(x^2)

PtoS[x_List]:=(∑_(i=2)^(Length[x]+1))((x[[i-1]] uni[i-1,Length[x]+1])/(Sqrt[Tri[i]]))

uni[n_Integer,s_Integer]:=PadRight[Append[Table[1,{n}],-n],s]

gB5[x_B]:=Line/@Subsets[StoP/@VertexesOf[List@@Drop[x,-1]],{2}]

tetrapoint[x_,{i_}]:={Text[i,StoP[(1/4) Plus@@VertexesOf[List@@Drop[x,-1]]]],Line/@Subsets[StoP/@VertexesOf[List@@Drop[x,-1]],{2}]}

Bmultiply[x_List,y_List]:=(-((RotateRight[Reverse[x],#1].y)/(Length[x]))&)/@Range[0,Length[x]-1]

BeigenNumber[x_List,n_Integer]:=Append[x[[Mod[Range[Length[x]-1] n,Length[x]]]],Last[x]]

Breciprical[x_List]:=Module[{wx,iii},wx=BeigenNumber[x,2];Do[wx=Bmultiply[wx,BeigenNumber[x,iii]],{iii,3,Length[x]-1}];-((Length[x] wx)/(Reverse[x].wx))]

Bdivide[x_List,y_List]:=Bmultiply[x,Breciprical[y]]

Bunity[n_Integer]:=Append[Table[1,{n-1}],-(n-1)]

mz[x_List]:=Append[x,-Plus@@x]

mid[x_B]:=x+((Last[x])/(Length[x]-1))

width[x_B]:=x-mid[x]

Bconjugate[x_List]:=Module[{wx,iii},wx=BeigenNumber[x,2];Do[wx=Bmultiply[wx,BeigenNumber[x,iii]],{iii,3,Length[x]-1}];wx]

rootOfUnity[n_Integer]:=B@@RotateLeft[Bunity[n]]

Bpowern[x_List,n_]:=MatrixPower[(RotateRight[-((Reverse[x])/(Length[x]))+(1/(Length[x])),#1]&)/@Range[0,Length[x]-1],n].Bunity[Length[x]]

panmaux[n_]:=Riffle[-Reverse[n],n]

pandm[n_]:=((π panmaux[Range[Floor[(n/2)]]])/n)

bnI[n_]:=B@@Append[Tan/@pandm[n],0]

reIm[x_B]:=Im/@x bnI[Length[x]]+Re/@x

Clear[B]

Conjugate[B[x__]]^:=B@@Bconjugate[{x}]

x_B y_B^:=B@@Bmultiply[List@@x,List@@y]

n_?NumberQ x_B^:=B@@(n List@@x)

x_B+y_B^:=B@@(List@@x+List@@y)

x_B+n_?NumberQ^:=B@@(List@@x+n Bunity[Length[x]])

((x_B)^(n_?NumberQ))^:=B@@If[!IntegerQ[n],Bpowern[List@@x,n],Nest[Bmultiply[If[Sign[n]==-1,Breciprical[List@@x],List@@x],#1]&,Bunity[Length[x]],Abs[n]]]

Unprotect[Times];
a_B x_+b_B x_^:=x (a+b);
Protect[Times];

Discussion

The deterministic way to make the Sierpinski triangle is to start at a vertex of an equiangular triangle and make new points which are the midpoints of the point and each vertex of the triangle, and then repeat the process for all new points. See the book Mathematica in Action, 1991, by Stan Wagon, section 5.2. The midpoint of two points is the Mean of the two points.

itr[s_,n_,ff_]:=Show[Graphics[{BaseTriangle,(Point[StoP[List@@#1]]&)/@Flatten[NestList[ff,{s},n]]}],AspectRatio->Automatic,PlotRange->All]

The function itr[s_,n_,ff_] nests the function ff n times starting with s as the first input B number, and then converts each B number result to a Point in perpendicular coordinates, and Shows a Graphics of the Points. And it Shows the base triangle as three points in red.

simplex[n_]:=VertexesOf[Table[1,{n}]]

simplex[n_] gives the n vertices of an n-1 dimensional regular simplex of edge length n centered at the origin in Synergetics coordinates.

For instance:

simplex[3]

They can be converted to the kind of coordinates that Mathematica can graph by the function StoP. For instance:

StoP/@simplex[3]

?PointSize

BaseTriangle={Hue[1],PointSize[(1/20)],Point/@StoP/@simplex[3],Hue[0],PointSize[(1/200)]}

(Subscript[B, 3]) numbers are a field over the reals. They are two dimensional. The three coordinates sum to zero. Here is an example of multiplication.

Clear[a,b,c,d,e,f]

B[a,b,c] B[d,e,f]

outerff[x_,ff_]:=Flatten[Outer[ff[{#1,#2}]&,x,Apply[B,simplex[3],{1}]]]

average[x_]:=outerff[x,Mean]

Mean[{a,b}]

itr[B[1,1,-2],7,average]

harmonic[x_]:=outerff[x,HarmonicMean]

HarmonicMean[{a,b}]

The HarmonicMean is substituted for the Mean in the function harmonic, which is otherwise just like the function average. The 1955 Webster’s Unabridged Dictionary shows a trefoil rotated 90 degrees from this one as the official symbol of The Girl Scouts of America.

itr[B[1,1,-2],7,harmonic]

Clear[gm]

gm[{x_,y_}]:=reIm[(((N[x] N[y]))^(.5))]

geometric[x_]:=outerff[N[x],gm]

GeometricMean[{a,b}]

itr[N[B[1,1,-2]],7,geometric]

The root mean square can be tried too.

RootMeanSquare[{a,b}]

rmsquare[{a_,b_}]:=reIm[(((((a^2)+(b^2)))^(.5))/(N[(Sqrt[2])]))]

rms[x_]:=outerff[N[x],rmsquare]

itr[N[B[1,1,-2]],7,rms]