गणित में सिएरपिंस्की त्रिकोण उत्पन्न करना?

Question

मैंने कोड लिखा है जो सिएरपिंस्की फ्रैक्टल को आकर्षित करता है। यह वास्तव में धीमा है क्योंकि यह रिकर्सन का उपयोग करता है। क्या आप में से कोई भी यह जानता है कि बिना किसी रिकॉर्शन के मैं एक ही कोड कैसे लिख सकता हूं ताकि इसे तेज किया जा सके? यहाँ मेरी कोड है:

midpoint[p1_, p2_] := Mean[{p1, p2}] 
trianglesurface[A_, B_, C_] := Graphics[Polygon[{A, B, C}]] 
sierpinski[A_, B_, C_, 0] := trianglesurface[A, B, C] 
sierpinski[A_, B_, C_, n_Integer] := 
Show[ 
sierpinski[A, midpoint[A, B], midpoint[C, A], n - 1], 
sierpinski[B, midpoint[A, B], midpoint[B, C], n - 1], 
sierpinski[C, midpoint[C, A], midpoint[C, B], n - 1] 
] 

संपादित करें:

मैं अराजकता खेल दृष्टिकोण मामले में कोई रुचि रखता है के साथ लिखा है। आपके महान उत्तरों के लिए धन्यवाद!

random[A_, B_, C_] := Module[{a, result}, 
a = RandomInteger[2]; 
Which[a == 0, result = A, 
a == 1, result = B, 
a == 2, result = C]] 

Chaos[A_List, B_List, C_List, S_List, n_Integer] := 
Module[{list}, 
list = NestList[Mean[{random[A, B, C], #}] &, 
Mean[{random[A, B, C], S}], n]; 
ListPlot[list, Axes -> False, PlotStyle -> PointSize[0.001]]] 

Answer 1

आप सिएरपिन्स्की त्रिकोण का एक उच्च गुणवत्ता वाले सन्निकटन चाहते हैं, तो आप उपयोग कर सकते हैं एक दृष्टिकोण chaos game कहा जाता है: यहाँ कोड है। विचार इस प्रकार है - तीन बिंदुओं को चुनें जिन्हें आप सिएरपिंस्की त्रिभुज के शिखर के रूप में परिभाषित करना चाहते हैं और उन बिंदुओं में से एक को यादृच्छिक रूप से चुनें। फिर, जब तक आप चाहें, निम्न प्रक्रिया दोहराएं:

1. ट्रांगल का यादृच्छिक वर्टेक्स चुनें।
2. वर्तमान बिंदु से अपने वर्तमान स्थान और त्रिकोण के कशेरुक के बीच आधे रास्ते तक ले जाएं।
3. उस बिंदु पर एक पिक्सेल प्लॉट करें।

जैसा कि आप at this animation देख सकते हैं, यह प्रक्रिया अंततः त्रिकोण के उच्च-रिज़ॉल्यूशन संस्करण का पता लगाएगी। यदि आप चाहें, तो आप इसे एकाधिक प्रक्रियाओं को एक साथ पिक्सेल प्लॉट करने के लिए बहुसंख्यक कर सकते हैं, जो त्रिभुज को अधिक तेज़ी से चित्रित कर देगा।

वैकल्पिक रूप से, यदि आप केवल अपने रिकर्सिव कोड को पुनरावर्तक कोड में अनुवाद करना चाहते हैं, तो एक विकल्प कार्यसूची दृष्टिकोण का उपयोग करना होगा। एक स्टैक (या कतार) बनाए रखें जिसमें रिकॉर्ड्स का संग्रह होता है, जिनमें से प्रत्येक त्रिकोण के शीर्ष और संख्या n को रखता है। प्रारंभ में इस कार्यसूची में मुख्य त्रिकोण और फ्रैक्टल गहराई के शिखर सम्मिलित करें। तब:

• जबकि worklist खाली नहीं है:
  • worklist से पहले तत्व निकालें।
  • तो इसकी n मान शून्य नहीं है:
    • ड्रा त्रिकोण त्रिकोण के मध्य बिन्दुओं को जोड़ने।
    • प्रत्येक subtriangle के लिए, उस त्रिकोण को n-value n-1 के साथ कार्यसूची में जोड़ें।

यह अनिवार्य रूप से iteratively प्रत्यावर्तन simulates।

आशा है कि इससे मदद मिलती है!

Answer 2

आप कोशिश कर सकते हैं

l = {{{{0, 1}, {1, 0}, {0, 0}}, 8}}; 
g = {}; 
While [l != {}, 
k = l[[1, 1]]; 
n = l[[1, 2]]; 
l = Rest[l]; 
If[n != 0, 
    AppendTo[g, k]; 
    (AppendTo[l, {{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1}] & @@ #) & /@ 
               NestList[RotateLeft, k, 2] 
    ]] 
Show@Graphics[{EdgeForm[Thin], Pink,Polygon@g}] 

और फिर और अधिक कुशल कुछ द्वारा AppendTo बदलें।उदाहरण https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile

संपादित

तेज़ के लिए देखें:

f[1] = {{{0, 1}, {1, 0}, {0, 0}}, 8}; 
i = 1; 
g = {}; 
While[i != 0, 
k = f[i][[1]]; 
n = f[i][[2]]; 
i--; 
If[n != 0, 
    g = Join[g, k]; 
    {f[i + 1], f[i + 2], f[i + 3]} = 
    ({{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1} & @@ #) & /@ 
               NestList[RotateLeft, k, 2]; 
    i = i + 3 
    ]] 
Show@Graphics[{EdgeForm[Thin], Pink, Polygon@g}] 

Answer 3

यह Scale और Translate संयोजन में Nest साथ त्रिकोण के सूची बनाने के लिए उपयोग करता है।

Manipulate[ 
    Graphics[{Nest[ 
    Translate[Scale[#, 1/2, {0, 0}], pts/2] &, {Polygon[pts]}, depth]}, 
    PlotRange -> {{0, 1}, {0, 1}}, PlotRangePadding -> .2], 
    {{pts, {{0, 0}, {1, 0}, {1/2, 1}}}, Locator}, 
    {{depth, 4}, Range[7]}] 

Answer 4

चूंकि त्रिकोण आधारित कार्यों को पहले से ही अच्छी तरह से कवर किया गया है, यहाँ एक रेखापुंज आधारित दृष्टिकोण है।
यह सामान्य रूप से पास्कल के त्रिभुज का निर्माण करता है, फिर मॉड्यूलो 2 लेता है और परिणाम प्लॉट करता है।

NestList[{0, ##} + {##, 0} & @@ # &, {1}, 511] ~Mod~ 2 // ArrayPlot 

Answer 5

Clear["`*"]; 
sierpinski[{a_, b_, c_}] := 
    With[{ab = (a + b)/2, bc = (b + c)/2, ca = (a + c)/2}, 
    {{a, ab, ca}, {ab, b, bc}, {ca, bc, c}}]; 

pts = {{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}} // N; 
n = 5; 
d = Nest[Join @@ sierpinski /@ # &, {pts}, n]; // AbsoluteTiming 
Graphics[{EdgeForm@Black, Polygon@d}] 

(*sierpinski=Map[Mean, Tuples[#,2]~Partition~3 ,{2}]&;*) 

यहाँ एक 3 डी संस्करण है, https://mathematica.stackexchange.com/questions/22256/how-can-i-compile-this-function

ListPlot@NestList[(# + RandomChoice[{{0, 0}, {2, 0}, {1, 2}}])/2 &, 
N@{0, 0}, 10^4] 

With[{data = 
    NestList[(# + RandomChoice@{{0, 0}, {1, 0}, {.5, .8}})/2 &, 
    N@{0, 0}, 10^4]}, 
Graphics[Point[data, 
    VertexColors -> ({1, #[[1]], #[[2]]} & /@ Rescale@data)]] 
] 

With[{v = {{0, 0, 0.6}, {-0.3, -0.5, -0.2}, {-0.3, 0.5, -0.2}, {0.6, 
    0, -0.2}}}, 
ListPointPlot3D[ 
    NestList[(# + RandomChoice[v])/2 &, N@{0, 0, 0}, 10^4], 
    BoxRatios -> 1, ColorFunction -> "Pastel"] 
]