代碼::勾股樹

來自專欄 CODE Viens Vanité

勾股樹的面積是分形領域的未解之謎之一

等腰直角勾股樹的前幾階面積如下:

這樣的一棵勾股樹如果無限畫下去總面積收斂嗎？?

www.zhihu.com

單調遞增有上界, 我覺得上界差不多是 .

PythagorasTree[depth_,arg_:45[Degree]]:=Block[ {pts={{0,0},{1,0},{1,1},{0,1}},t1,t2}, t1=TranslationTransform[{0,1}].ScalingTransform[{Cos@arg,Cos@arg}].RotationTransform[arg]; t2=TranslationTransform[{Cos[arg]^2,Cos[arg]Sin[arg]+1}].ScalingTransform[{Sin@arg,Sin@arg}].RotationTransform[arg-90Degree]; Partition[#,4]&/@NestList[Join[t1@#,t2@#]&,pts,depth]];gra=Polygon/@PythagorasTree[n=9];area=Rationalize[Area[BooleanRegion[Or,DiscretizeRegion[#,AccuracyGoal->10]&/@gra],WorkingPrecision->30]]Export[ "PythagorasTree_1.png", Graphics[gra,PlotLabel->Style[area,Red]], Background->None, ImageSize->600]

接下來可以數值的驗算一下面積:

Table[ gra=Polygon/@PythagorasTree[n]; area=Area[BooleanRegion[Or,DiscretizeRegion/@gra]], {n,1,10}]

{2., 3., 4., 5., 5.9375, 6.82813, 7.63281, 8.22656, 8.7832, 9.24365}

隨迭代次數變化的勾股樹:

v=Join[#,Reverse@#]&@Range[10];TreeDraw:=Block[{tree=PythagorasTree[#]}, Graphics[{ EdgeForm[ColorData["Legacy","DarkGreen"]], {FaceForm[ColorData["Legacy","Burlywood"]], Polygon[Join@@Most@tree]}, {FaceForm[ColorData["Legacy","DarkGreen"]], Polygon@Last@tree} },ImageSize->{400,400} ]]&;Export[ "PythagorasTree_2.gif", TreeDraw/@v, "AnimationRepetitions"->Infinity, "DisplayDurations"->1/2]

隨角度變化的勾股樹:

AnglePythagorasTree[p1_,bend_:4]:=Module[ { p=2^p1,xx=0,yy=0, scale=-1,f=N[Pi/bend], c,cc,ss,sxy,eps=0.005, a1,a2,b1,b2,c1,c2,d1,d2, x1=0,y1=0,u1=1,v1=0,q=0,j=1,k,m,xa,xb,ya,yb, done=False,tree={} }, cc=Cos[f];ss=Sin[f]; a1=(-cc)*ss;a2=cc^2; b1=a1+a2;b2=-a1+a2; c1=b2;c2=1-b1; d1=1-a1;d2=1-a2; s[0]=1; tree={{{xx,yy},{xx+scale,yy},{xx+scale,yy+scale},{xx,yy+scale},{xx,yy}}}; While[!done,m=q+j; x=u1-x1;y=v1-y1; xa=x1+a1*x-a2*y; ya=y1+a2*x+a1*y; xb=x1+b1*x-b2*y; yb=y1+b2*x+b1*y; x2[m]=x1+c1*x-c2*y; y2[m]=y1+c2*x+c1*y; u2[m]=x1+d1*x-d2*y; v2[m]=y1+d2*x+d1*y; sxy=x*x+y*y; s[m]=1; tree=Append[tree,{ {xx+scale*x1,yy-scale*y1},{xx+scale*xa,yy-scale*ya}, {xx+scale*xb,yy-scale*yb},{xx+scale*u1,yy-scale*v1}, {xx+scale*u2[m],yy-scale*v2[m]}, {xx+scale*x2[m],yy-scale*y2[m]}, {xx+scale*x1,yy-scale*y1} }]; x1=xa;y1=ya; u1=xb;v1=yb; If[m==p||sxy<eps, k=1;While[s[m-k]==0,k++]; If[m==k,done=True,q=m-k; x1=x2[q];y1=y2[q]; u1=u2[q];v1=v2[q]; s[q]--;j=0; ];];j++;]; Polygon/@tree];AngleTreeDraw[m_:2,n_:4]:=Graphics[{ With[{pt=PythagorasTree[m,n]},MapIndexed[{ EdgeForm[{Thickness[0.005],ColorData["Rainbow"][1-First[#2]/Length[pt]]}], Opacity[0.7],ColorData["Rainbow"][First[#2]/Length[pt]],#1 }&,pt]]}, Background->Append[ColorData["Rainbow"][0.5],0.3], ImageSize->{400,400}];Manipulate[AngleTreeDraw[2,n],{{n,3,"bend"},2,4}]v=Join[#,Reverse@#]&@Range[2,4,0.05]Export[ "PythagorasTree_3.gif", AngleTreeDraw[3,#]&/@v, "AnimationRepetitions"->Infinity]

面積變化也比較神奇, 居然不是單調遞減的.

vc=Table[Area[BooleanRegion[Or,DiscretizeRegion/@AnglePythagorasTree[3,n]]],{n,2.1,3.9,0.1}]ListLinePlot[vc, PlotTheme -> "Business"]

題圖:sariel (touhou and touhou (pc-98)) drawn by ellipsis (mitei) - Danbooru

推薦閱讀：