Message Boards Message Boards

Narayana Cow Triangle Fractal

GROUPS:

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]
POSTED BY: Ed Pegg
Answer
5 months 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!

POSTED BY: Kapio Letto
Answer
5 months ago

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 BY: Moderation Team
Answer
5 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

POSTED BY: Ed Pegg
Answer
5 months ago

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

Answer
2 months ago

Group Abstract Group Abstract