Can degenerating Nicomachus' triangle down to $0$ area by using `Graph` be done?

Question

I noticed a pattern in Nicomachus' Triangle that might be used to reduce the triangle to the number line. If the Edge size could be set to the absolute difference of its two vertices, I conjecture that this would occur without duplicates. Edit 4---this produces deranged triangles whose areas are $0$.

How can we set this Edge size?

Edit 3 Thanks to the link in the comment by: Rahul Narain, we have a viable solution:

a = {k[{1, 1, 1}] <-> k[{1, 2, 1}],
 k[{1, 2, 1}] <-> k[{1, 2, 2}],
 k[{1, 2, 2}] <-> k[{1, 3,1}], k[{1, 3, 1}] <->
 k[{1, 3, 2}], k[{1, 3, 2}] <-> k[{1, 3, 3}]}
elength = {1, 1, 1, 2, 3}; (* kludge *)    
Graph[a,VertexLabels -> "Name", EdgeWeight -> elength,
 EdgeLabels\[Rule]"EdgeWeight", GraphLayout ->
 {"VertexLayout" -> {"SpringElectricalEmbedding",
 "EdgeWeighted" ->  True}}]

Edit 2 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 < third side, we have an unconnected graph, thus an error under my definitions.

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.

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.

To create the transposition from triangle to line:
Make original triangle graph;
Extract Edge and Vertex lists;
Create a new Vertex list using k[{t,r,i}];
Create an EdgeWeight list using the absolute differences between the new vertices;
The hard part! Make a new graph using the weights as the actual lengths of the edges.
An additional thought: This might be as simple as changing the internal triangle inequality rule to allow straight lines.

Edit 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: line graph
Above, set the edges to the differences to get the straight line.

(* This converts the generic triangle vertices to the specific Nicomachus' triangle vertices *)  
k[j_List] := 
Block[{t = j[[1]], r = j[[2]], i = j[[3]]}, (2 t - 1) 2^(-i + r)
3^(-1 + i)]  
(* These graph the generic and specific triangles *)
Graph[{{1, 1, 1} <-> {1, 2, 1}, {1, 2, 1} <-> {1, 2, 2}, {1, 2, 
2} <-> {1, 1, 1},
{1, 2, 1} <-> {1, 3, 1}, {1, 2, 1} <-> {1, 3, 2}, {1, 2, 2} <-> {1, 
  3, 2},
{1, 2, 2} <-> {1, 3, 3}, {1, 3, 1} <-> {1, 3, 2}, {1, 3, 2} <-> {1, 
3, 3}
}, VertexLabels -> "Name"]
Graph[{k[{1, 1, 1}] <-> k[{1, 2, 1}], k[{1, 2, 1}] <-> k[{1, 2, 2}], 
k[{1, 2, 2}] <-> k[{1, 1, 1}],
k[{1, 2, 1}] <-> k[{1, 3, 1}], k[{1, 2, 1}] <-> k[{1, 3, 2}], 
k[{1, 2, 2}] <-> k[{1, 3, 2}],
k[{1, 2, 2}] <-> k[{1, 3, 3}], k[{1, 3, 1}] <-> k[{1, 3, 2}], 
k[{1, 3, 2}] <-> k[{1, 3, 3}]
}, VertexLabels -> "Name" ]
(* These show the target graphs that I want when the `Edge` is set to the vertices differences *)
Graph[{{1, 1, 1} <-> {1, 2, 1}, {1, 2, 1} <-> {1, 2, 2},
{1, 2, 2} <-> {1, 3, 1}, {1, 3, 1} <-> {1, 3, 2},
{1, 3, 2} <-> {1, 3, 3}}, VertexLabels -> "Name"]
Graph[{k[{1, 1, 1}] <-> k[{1, 2, 1}], k[{1, 2, 1}] <-> k[{1, 2, 2}],
k[{1, 2, 2}] <-> k[{1, 3, 1}], k[{1, 3, 1}] <-> k[{1, 3, 2}],
k[{1, 3, 2}] <-> k[{1, 3, 3}]}, VertexLabels -> "Name"]
Graph[{k[{3, 1, 1}] <-> k[{3, 2, 1}], 
k[{3, 2, 1}] <-> k[{3, 2, 2}],
k[{3, 2, 2}] <-> k[{3, 3, 1}], k[{3, 3, 1}] <-> k[{3, 3, 2}],
k[{3, 3, 2}] <-> k[{3, 3, 3}]}, VertexLabels -> "Name"]

"reduce the triangle to the number line" isn't clear enough for me. Could you explain further, please? — Dr. belisarius, Oct 28 '14 at 13:10
@belisarius, When triangle 1-2-3 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 1-2-3 with an edge back from 3-1. — Fred Daniel Kline, Oct 28 '14 at 13:24
Well, I still don't understand, but don't worry. Perhaps this one isn't my better day :) — Dr. belisarius, Oct 28 '14 at 13:38
@belisarius, I have posted the image. It's close to what we should get. — Fred Daniel Kline, Oct 28 '14 at 14:31
The question is hard to understand, but since you ask "How can we set this Edge size?" perhaps you want to draw a graph with specified edge lengths? — , Oct 29 '14 at 04:31

Junho Lee · Accepted Answer · 2014-10-28T16:30:56.537

k[] is function defined by you and tri is making UndirectedEdge-s

k[j_List] := Block[{t = j[[1]], r = j[[2]], i = j[[3]]},(2 t - 1) 2^(-i + r) 3^(-1 + i)]
tri[{t_, r_, i_}] := {{t, r, i} <-> {t, r + 1, i},
    {t, r + 1, i} <-> {t, r + 1, i + 1},{t, r + 1, i + 1} <-> {t, r, i}}

I remaked your code like this for making Graph.

d = 4;
data = Flatten@Table[tri[{1, i, j}],{i, 1, d - 1}, {j, 1, i}];
data2 = Apply[k[{##}] &, data, {2}];
vert = (VertexList@Graph@data)[[All, 2 ;; 3]];
co = Composition[
    RotationTransform[-\[Pi]/3],
    ShearingTransform[\[Pi]/6, {-1, 0}, {0, 1}], 
    ScalingTransform[Sqrt[3]/2, {0, 1}]] /@ vert;
Graph[data2,VertexLabels -> "Name",VertexCoordinates -> co]

and I make number lines by following code, this is my guess you wanted.

l1 = k /@ VertexList@Graph@data;
l2 = Transpose@{l1, co};
l3 = Sort[l2, #1[[2, 1]] > #2[[2, 1]] && #1[[2, 2]] > #2[[2, 2]] &];
Reverse@(Transpose@l3)[[1]]

{1, 2, 3, 4, 6, 8, 9, 12, 18, 27}

PathGraph[Reverse@(Transpose@l3)[[1]], VertexLabels -> "Name"]

9-row triangle

Can degenerating Nicomachus' triangle down to $0$ area by using `Graph` be done?

1 Answers1