来几个分形图

minjiecow

来几个分形图,Mathematica做的

minjiecow

发错地方了，版主将它删了吧！拜托

wolfram

做得不错，LZ能共享一个源代码吗

chungyuandye

1. 
   
2. newpt[A_List,B_List]:={A,A+1/3*(B-A),tp[A+1/3*(B-A),A+2/3*(B-A)],A+2/3*(B-A),B}
   
3. tp[{a_,b_},{c_,d_}]:=If[c>=a, {(a^2-c^2+Sqrt[3]Sqrt[(a-c)^2](-b+d))/(2(a-c)), 1/2(b+Sqrt[3]Sqrt[(a-c)^2]+d)},{(a^2-c^2+Sqrt[3]Sqrt[(a-c)^2](b-d))/(2(a-c)),1/2(b-Sqrt[3]Sqrt[(a-c)^2]+d)}];
   
4. Graphics[{Red,Thickness[0.005],Line/@Nest[Partition[DeleteDuplicates[Flatten[newpt@@@#,1]],2,1]&,{{{0,0},{2,0}}},4]},ImageSize->500]
   
5. data={{{0,0},{1,Sqrt[3]}},{{1,Sqrt[3]},{2,0}},{{2,0},{0,0}}}
   
6. 
   
7. Show[Graphics[{Red,Thickness[0.005],Line/@Nest[Partition[DeleteDuplicates[Flatten[newpt@@@#,1]],2,1]&,{data[[#]]},4]},ImageSize->250]&/@{1,2,3}]
   
8. 
   
9. newpt[A_List,B_List]:={A,A+1/5*(B-A),tp[A+1/5*(B-A),A+2/3*(B-A)],A+(1-1/5)*(B-A),B}
   
10. Show[Graphics[{Red,Thickness[0.005],Line/@Nest[Partition[DeleteDuplicates[Flatten[newpt@@@#,1]],2,1]&,{data[[#]]},4]},ImageSize->250]&/@{1,2,3}]
    
11. newpt[S_List,A_List,B_List,T_List]:=newpt[S,A,B,T]=Block[{temp1,temp2,tm,x},
    
12. tm[xx_]={{Cos[xx],Sin[xx]},{-Sin[xx],Cos[xx]}};
    
13. x=Pi/3;
    
14. temp1=Cos[x]*(B-A);
    
15. temp2=-Sin[x]*(B-A);
    
16. {{A,A+temp1.tm[x+Pi/2],A+Sqrt[2]*temp1.tm[x+Pi/4],
    
17. A+temp1.tm[x]},
    
18. {B+temp2.tm[x-Pi/2],B+Sqrt[2]*temp2.tm[x-Pi/2-Pi/4],
    
19. B+temp2.tm[x-Pi/2-Pi/2],B}}
    
20. ]
    

复制代码

xuruikl

非常漂亮，值得学习

wolfram

学习一下.......

cunlijia

运行出错了啊！

4# chungyuandye