Can degenerating Nicomachus' triangle down to \$0\$ area by using `Graph` be done? - Mathematica Stack Exchange most recent 30 from mathematica.stackexchange.com 2019-08-19T08:55:25Z https://mathematica.stackexchange.com/feeds/question/64298 http://www.creativecommons.org/licenses/by-sa/3.0/rdf https://mathematica.stackexchange.com/q/64298 1 Can degenerating Nicomachus' triangle down to \$0\$ area by using `Graph` be done? Fred Kline https://mathematica.stackexchange.com/users/973 2014-10-28T12:13:40Z 2014-11-21T00:32:08Z <p>I noticed a pattern in Nicomachus' Triangle that might be used to reduce the triangle to the number line. If the <code>Edge</code> size could be set to the absolute difference of its two vertices, I conjecture that this would occur <strong>without</strong> duplicates. <strong>Edit 4---this produces deranged triangles whose areas are \$0\$.</strong></p> <p>How can we set this <code>Edge</code> size?</p> <p><strong>Edit 3</strong> Thanks to the link in the comment by: Rahul Narain, we have a viable solution: </p> <blockquote> <pre><code>a = {k[{1, 1, 1}] &lt;-&gt; k[{1, 2, 1}], k[{1, 2, 1}] &lt;-&gt; k[{1, 2, 2}], k[{1, 2, 2}] &lt;-&gt; k[{1, 3,1}], k[{1, 3, 1}] &lt;-&gt; k[{1, 3, 2}], k[{1, 3, 2}] &lt;-&gt; k[{1, 3, 3}]} elength = {1, 1, 1, 2, 3}; (* kludge *) Graph[a,VertexLabels -&gt; "Name", EdgeWeight -&gt; elength, EdgeLabels\[Rule]"EdgeWeight", GraphLayout -&gt; {"VertexLayout" -&gt; {"SpringElectricalEmbedding", "EdgeWeighted" -&gt; True}}] </code></pre> </blockquote> <p><strong>Edit 2</strong> The triangle inequality states that: if the sum of the lengths of the two shortest sides > length of the third side, we have a triangle. I want to change that to >=, then we have a triangle, straight line, or a point. All three types remain connected. If the sum &lt; third side, we have an unconnected graph, thus an error under my definitions.</p> <p>All of the examples I have found keep the original graph and manipulate the co-ordinates to get these edges. I want to use the normal graph transpositions, instead.</p> <p>Motivation: I hope to show that we can take each triangle of an infinite prism and telescope it into a connected straight line. Then I hope to take that infinite array of straight lines and telescope it into a connected point. And I hope that point is 1.</p> <p>To create the transposition from triangle to line:<br> Make original triangle graph;<br> Extract <code>Edge</code> and <code>Vertex</code> lists;<br> Create a new <code>Vertex</code> list using <code>k[{t,r,i}]</code>;<br> Create an <code>EdgeWeight</code> list using the absolute differences between the new vertices;<br> <strong>The hard part!</strong> Make a new graph using the weights as the actual lengths of the edges.<br> <strong>An additional thought:</strong> This might be as simple as changing the internal triangle inequality rule to allow straight lines. </p> <p><strong>Edit</strong> When a 4-row triangle is graphed, we get a triangle with uniform edges. If we make the edges equal to the differences, the triangle loses its shape and becomes a straight line: <img src="https://i.stack.imgur.com/b7i0e.jpg" alt="line graph"><br> Above, set the edges to the differences to get the straight line.</p> <pre><code>(* This converts the generic triangle vertices to the specific Nicomachus' triangle vertices *) k[j_List] := Block[{t = j[], r = j[], i = j[]}, (2 t - 1) 2^(-i + r) 3^(-1 + i)] (* These graph the generic and specific triangles *) Graph[{{1, 1, 1} &lt;-&gt; {1, 2, 1}, {1, 2, 1} &lt;-&gt; {1, 2, 2}, {1, 2, 2} &lt;-&gt; {1, 1, 1}, {1, 2, 1} &lt;-&gt; {1, 3, 1}, {1, 2, 1} &lt;-&gt; {1, 3, 2}, {1, 2, 2} &lt;-&gt; {1, 3, 2}, {1, 2, 2} &lt;-&gt; {1, 3, 3}, {1, 3, 1} &lt;-&gt; {1, 3, 2}, {1, 3, 2} &lt;-&gt; {1, 3, 3} }, VertexLabels -&gt; "Name"] Graph[{k[{1, 1, 1}] &lt;-&gt; k[{1, 2, 1}], k[{1, 2, 1}] &lt;-&gt; k[{1, 2, 2}], k[{1, 2, 2}] &lt;-&gt; k[{1, 1, 1}], k[{1, 2, 1}] &lt;-&gt; k[{1, 3, 1}], k[{1, 2, 1}] &lt;-&gt; k[{1, 3, 2}], k[{1, 2, 2}] &lt;-&gt; k[{1, 3, 2}], k[{1, 2, 2}] &lt;-&gt; k[{1, 3, 3}], k[{1, 3, 1}] &lt;-&gt; k[{1, 3, 2}], k[{1, 3, 2}] &lt;-&gt; k[{1, 3, 3}] }, VertexLabels -&gt; "Name" ] (* These show the target graphs that I want when the `Edge` is set to the vertices differences *) Graph[{{1, 1, 1} &lt;-&gt; {1, 2, 1}, {1, 2, 1} &lt;-&gt; {1, 2, 2}, {1, 2, 2} &lt;-&gt; {1, 3, 1}, {1, 3, 1} &lt;-&gt; {1, 3, 2}, {1, 3, 2} &lt;-&gt; {1, 3, 3}}, VertexLabels -&gt; "Name"] Graph[{k[{1, 1, 1}] &lt;-&gt; k[{1, 2, 1}], k[{1, 2, 1}] &lt;-&gt; k[{1, 2, 2}], k[{1, 2, 2}] &lt;-&gt; k[{1, 3, 1}], k[{1, 3, 1}] &lt;-&gt; k[{1, 3, 2}], k[{1, 3, 2}] &lt;-&gt; k[{1, 3, 3}]}, VertexLabels -&gt; "Name"] Graph[{k[{3, 1, 1}] &lt;-&gt; k[{3, 2, 1}], k[{3, 2, 1}] &lt;-&gt; k[{3, 2, 2}], k[{3, 2, 2}] &lt;-&gt; k[{3, 3, 1}], k[{3, 3, 1}] &lt;-&gt; k[{3, 3, 2}], k[{3, 3, 2}] &lt;-&gt; k[{3, 3, 3}]}, VertexLabels -&gt; "Name"] </code></pre> https://mathematica.stackexchange.com/questions/64298/can-degenerating-nicomachus-triangle-down-to-0-area-by-using-graph-be-done/64333#64333 3 Answer by Junho Lee for Can degenerating Nicomachus' triangle down to \$0\$ area by using `Graph` be done? Junho Lee https://mathematica.stackexchange.com/users/16245 2014-10-28T16:25:08Z 2014-10-28T16:30:56Z <p><code>k[]</code> is function defined by you and <code>tri</code> is making <code>UndirectedEdge</code>-s</p> <pre><code>k[j_List] := Block[{t = j[], r = j[], i = j[]},(2 t - 1) 2^(-i + r) 3^(-1 + i)] tri[{t_, r_, i_}] := {{t, r, i} &lt;-&gt; {t, r + 1, i}, {t, r + 1, i} &lt;-&gt; {t, r + 1, i + 1},{t, r + 1, i + 1} &lt;-&gt; {t, r, i}} </code></pre> <p>I remaked your code like this for making <code>Graph</code>.</p> <pre><code>d = 4; data = Flatten@Table[tri[{1, i, j}],{i, 1, d - 1}, {j, 1, i}]; data2 = Apply[k[{##}] &amp;, data, {2}]; vert = (VertexList@Graph@data)[[All, 2 ;; 3]]; co = Composition[ RotationTransform[-\[Pi]/3], ShearingTransform[\[Pi]/6, {-1, 0}, {0, 1}], ScalingTransform[Sqrt/2, {0, 1}]] /@ vert; Graph[data2,VertexLabels -&gt; "Name",VertexCoordinates -&gt; co] </code></pre> <blockquote> <p><img src="https://i.stack.imgur.com/S4VQk.png" alt="enter image description here"></p> </blockquote> <p>and I make number lines by following code, this is my guess you wanted.</p> <pre><code>l1 = k /@ VertexList@Graph@data; l2 = Transpose@{l1, co}; l3 = Sort[l2, #1[[2, 1]] &gt; #2[[2, 1]] &amp;&amp; #1[[2, 2]] &gt; #2[[2, 2]] &amp;]; Reverse@(Transpose@l3)[] </code></pre> <blockquote> <p><code>{1, 2, 3, 4, 6, 8, 9, 12, 18, 27}</code></p> </blockquote> <pre><code>PathGraph[Reverse@(Transpose@l3)[], VertexLabels -&gt; "Name"] </code></pre> <blockquote> <p><img src="https://i.stack.imgur.com/3plIm.png" alt="Blockquote"></p> </blockquote> <p><strong>9-row triangle</strong></p> <blockquote> <p><img src="https://i.stack.imgur.com/TVQMv.png" alt="enter image description here"></p> </blockquote>