Message Boards Message Boards

GROUPS:

Narayana Cow Triangle Fractal

Posted 9 months ago
1928 Views
|
4 Replies
|
10 Total Likes
|

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]}]

fractal Narayana Cow spiral

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.

Narayana cow fractal egg

The opening gave an order 3 infinite spiral. Is there an order 5 infinite spiral? It turns out there is. Behold the cow-nautilus!

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]
4 Replies

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!

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming!

Posted 9 months 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.

cow-nautilus

hi, Would like to know how do I elaborate a fractal hexagon with a manipulate to interact with it. Help me please.

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract