Message Boards Message Boards

Narayana Cow Triangle Fractal

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

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
6 Replies
Posted 3 years ago

This is so good, the coding might looks a bit hard, but the output looks great!

POSTED BY: Yasmin Hussain
Posted 3 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 BY: David Barnes

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

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

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

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