Message Boards

WOLFRAM COMMUNITY

25081 Views

6 Replies

12 Total Likes

View groups...

Follow this post

Share this post:

GROUPS:

Staff Picks Mathematics Recreation Visual Arts Algebra Discrete Mathematics Geometry Graphics and Visualization Wolfram Language Numerical Computation

Narayana Cow Triangle Fractal

Ed Pegg

Ed Pegg, Wolfram Research

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

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

Sort By:

Yasmin Hussain

Posted 4 years ago

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

POSTED BY: Yasmin Hussain

David Barnes

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 BY: David Barnes

Ana Sofia Trejos Vanegas

Posted 7 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 BY: Ana Sofia Trejos Vanegas

Ed Pegg

Ed Pegg, Wolfram Research

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.

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

EDITORIAL BOARD

EDITORIAL BOARD, WOLFRAM

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 BY: EDITORIAL BOARD

Kapio Letto

Kapio Letto, Consalting

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!

POSTED BY: Kapio Letto

Reply to this discussion

Reply Preview

Attachments

Remove Add a file to this post

Follow this discussion

or Discard

Group Abstract

Feedback