7
|
23461 Views
|
6 Replies
|
12 Total Likes
View groups...
Share
GROUPS:

# Narayana Cow Triangle Fractal

Posted 7 years ago
 In 1356, Narayana posed a question in his book Ga?ita Kaumudi: "A cow gives birth to a calf every year. In turn, the calf gives birth to another calf when it is three years old. What is the number of progeny produced during twenty years by one cow?" This is now known as Narayana's cows sequence. The Narayana's cows sequence constant, cow=1.4655712318767680266567312252199391080255775684723, is the limit ratio between neighboring terms. LinearRecurrence[{1, 0, 1}, {2, 3, 4}, 21] NestList[Round[# Root[-1 - #1^2 + #1^3 &, 1]] &, 2, 20]  Either gives {2, 3, 4, 6, 9, 13, 19, 28, 41, 60, 88, 129, 189, 277, 406, 595, 872, 1278, 1873, 2745, 4023}. This turns out to be a good constant to use for a Rauzy fractal. The outer fractal triangle can be divided into copies of itself r = Root[-1 - #1^2 + #1^3 &, 3]; iterations = 6; cowed[comp_] := First /@ Split[Flatten[RootReduce[#[[1]] + (#[[2]] - #[[1]]) {0, -r^5, r^5 + 1, 1}] & /@ Partition[comp, 2, 1, 1], 1]]; poly = ReIm[Nest[cowed[#] &, #, iterations]] & /@ Table[N[RootReduce[r^({4, 1, 3, 5} + n) {1, 1, -1, 1}], 50], {n, 1,14}]; Graphics[{EdgeForm[{Black}], Gray, Disk[{0, 0}, .1], MapIndexed[{Hue[#2[[1]]/12], Polygon[#1]} &, poly]}]  The ratio of areas for the triangles turns out to be cow. Try Area[Polygon[poly[[1]]]]/Area[Polygon[poly[[2]]]] and you'll see. If you want to laser cut that, it's handy to get a single path. cowpath[comp_] := First /@ Split[Flatten[RootReduce[#[[1]] + (#[[2]] - #[[1]]) {0, -r^5, r^5 + 1, 1}] & /@ Partition[comp, 2, 1], 1]]; path = ReIm[Nest[cowpath[#] &, N[Drop[Flatten[Table[r^({4, 1, 3} + n) {1, 1, -1}, {n, 1, 16}]], -1], 50], iterations]]; Graphics[{Line[path]}]  What else can be done with cow? With some trickier code I put together the pieces this way. Notice how order 5 spokes appear. The opening gave an order 3 infinite spiral. Is there an order 5 infinite spiral? It turns out there is. Behold the cow-nautilus! It can be made with the following code: r=Root[-1-#1^2+#1^3&,3]; iterate=3; cowed[comp_]:= First/@Split[Flatten[RootReduce[#[[1]]+(#[[2]]-#[[1]]){0,-r^5,r^5+1,1}]&/@Partition[comp,2,1,1],1]]; base={{r^10,r^7,-r^9,r^11},{-r^12,-r^9,r^11,-r^13},{r^8,r^5,-r^7,r^9},{-r^7,-r^4,r^6,-r^8}}+{-r^10,r^11,-r^6,r^4+r^8}; naut=RootReduce[Join[Table[base[[1]] (-r)^n,{n,0,-4,-1}],Flatten[Table[Drop[base,1](-r)^n,{n,-8,0}],1]]]; poly=ReIm[Nest[cowed[#]&,#,iterate]]&/@N[naut,50]; Graphics[{EdgeForm[{Black}],MapIndexed[{ColorData["BrightBands"][N[Norm[Mean[#1]]/2]],Polygon[#1]}&,poly]},ImageSize-> 800] 
6 Replies
Sort By:
Posted 4 years ago
 This is so good, the coding might looks a bit hard, but the output looks great!
Posted 4 years ago
 Thanks for posting interesting work. I wonder if you can point me towards tutorials or texts that would explain how the kernel in your recurrence relates to the word problem. After 20 years with Mathematica, I have learned how to do tensor contractions but I have never seen any explanation of what a kernel is or what a matrix represents in physical terms. As a result, I can work with expressions but I cannot craft any of my own. What sort of text explains the relationship between expressions and words?
Posted 6 years ago
 hi, Would like to know how do I elaborate a fractal hexagon with a manipulate to interact with it. Help me please.
Posted 7 years ago
 Here is code for the cow-nautilus. It could probably be simplified. r=Root[-1-#1^2+#1^3&,3]; s=Root[-1-#1^2+#1^3&,1]; add= RootReduce[{2-s,2s-s^3,-s+s^2}]; iterate=5; cowed[comp_]:= First/@Split[Flatten[RootReduce[#[[1]]+(#[[2]]-#[[1]]){0,-r^5,r^5+1,1}]&/@Partition[comp,2,1,1],1]]; vecs={{{4,3,6},{0,0,0},{-6,-4,-9},{7,5,10},{0,0,0},{-1,-1,-2},{-3,-2,-5},{1,1,1},{0,0,0},{2,1,3},{5,3,7},{-1,-1,-2},{0,0,0},{-3,-2,-4},{-7,-5,-10},{2,1,3},{0,0,0},{4,3,6},{10,7,15},{-3,-2,-4}},{{-1,0,-1},{2,2,3},{4,3,6},{-5,-3,-7},{4,3,6},{2,2,3},{1,1,1},{7,5,10},{-5,-3,-7},{4,3,6},{10,7,15},{-18,-12,-26}}}; naut=RootReduce[Join[Partition[{1,r,r^2}.#&/@vecs[[1]],4],Flatten[Table[Partition[({1,r,r^2}.#&/@vecs[[2]]),4](-r)^n,{n,-8,0}],1]]]; poly=ReIm[Nest[cowed[#]&,#,iterate]]&/@N[naut,50]; Graphics[{EdgeForm[{Black}],MapIndexed[{ColorData["BrightBands"][N[Norm[Mean[#1]]/2]],Polygon[#1]}&,poly]}, ImageSize-> 600] Here's alternate code all in terms of the root, which I've also placed in the initial post. r=Root[-1-#1^2+#1^3&,3]; iterate=6; cowed[comp_]:= First/@Split[Flatten[RootReduce[#[[1]]+(#[[2]]-#[[1]]){0,-r^5,r^5+1,1}]&/@Partition[comp,2,1,1],1]]; base={{r^10,r^7,-r^9,r^11},{-r^12,-r^9,r^11,-r^13},{r^8,r^5,-r^7,r^9},{-r^7,-r^4,r^6,-r^8}}+{-r^10,r^11,-r^6,r^4+r^8}; naut=RootReduce[Join[Table[base[[1]] (-r)^n,{n,0,-4,-1}],Flatten[Table[Drop[base,1](-r)^n,{n,-8,0}],1]]]; poly=ReIm[Nest[cowed[#]&,#,iterate]]&/@N[naut,50]; Graphics[{EdgeForm[{Black}],MapIndexed[{ColorData["BrightBands"][N[Norm[Mean[#1]]/2]],Polygon[#1]}&,poly]},ImageSize-> 800] It looks slightly different since I shifted one of the triangles.
Posted 7 years ago
 - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming!
Posted 7 years ago
 Ed this is a very nice work, thanks for sharing! Could you please edit your post and add also the missing code for other images: With some trickier code I put together... I cannot wait to see how it works. Thank you!