3
|
10418 Views
|
4 Replies
|
3 Total Likes
View groups...
Share
GROUPS:

# Unit Distance Heawood Graph

Posted 9 years ago
 At MathWorld, there's the Heawood graph. Noted there and over at Wikipedia there are some unit distance embeddings, where all edges have length 1. But none has symmetry. Let's fix that. pts=N[{ {-1/2,-(1/2) (-1+Sqrt[3-4 x-4 x^2])}, {x,1/2}, {x,-1/2}, {-1/2,1/2 (-1+Sqrt[3-4 x-4 x^2])}, {1/2,1/2 (-1+Sqrt[3-4 x-4 x^2])}, {-x,-1/2}, {-x,1/2}, {1/2,-(1/2) (-1+Sqrt[3-4 x-4 x^2])}, {1/2 (-1+Sqrt[3-4 x (1+x)]) Sqrt[(7+8 Sqrt[3-4 x (1+x)]-8 x (-1+x (1+2 x (2+x))))/(13+8 x (1+x) (-3+2 x (1+x)))],-(1/2) Sqrt[(7+8 Sqrt[3-4 x (1+x)]-8 x (-1+x (1+2 x (2+x))))/(13+8 x (1+x) (-3+2 x (1+x)))]},{Sqrt[3-4 x^2]/(2 Sqrt[1+4 x^2]),-((x Sqrt[3-4 x^2])/Sqrt[1+4 x^2])}, {-Sqrt[3-4 x^2]/(2 Sqrt[1+4 x^2]),-((x Sqrt[3-4 x^2])/Sqrt[1+4 x^2])}, {-(1/2) (-1+Sqrt[3-4 x (1+x)]) Sqrt[(7+8 Sqrt[3-4 x (1+x)]-8 x (-1+x (1+2 x (2+x))))/(13+8 x (1+x) (-3+2 x (1+x)))],-(1/2) Sqrt[(7+8 Sqrt[3-4 x (1+x)]-8 x (-1+x (1+2 x (2+x))))/(13+8 x (1+x) (-3+2 x (1+x)))]} , {1/2,-((x Sqrt[3-4 x^2])/Sqrt[1+4 x^2])-Sqrt[(8 x^2+Sqrt[3+8 x^2-16 x^4])/(2+8 x^2)]}, {-1/2,-((x Sqrt[3-4 x^2])/Sqrt[1+4 x^2])-Sqrt[(8 x^2+Sqrt[3+8 x^2-16 x^4])/(2+8 x^2)]} }/.x->Root[-153027+1353114 #1-1986024 #1^2+2763312 #1^3+10497808 #1^4+31063072 #1^5-8457728 #1^6-40590336 #1^7+44468736 #1^8+164975616 #1^9+119705600 #1^10-494067712 #1^11-763912192 #1^12+414924800 #1^13+1154613248 #1^14+48496640 #1^15-864485376 #1^16-376307712 #1^17+253231104 #1^18+271581184 #1^19+89128960 #1^20+10485760 #1^21&,1],300]; points = pts[[#]] & /@ {13, 12, 4, 5, 9, 14, 11, 3, 2, 1, 8, 7, 6, 10}; edges = {{1, 2}, {1, 6}, {1, 14}, {2, 3}, {2, 11}, {3, 4}, {3, 8}, {4, 5}, {4,13}, {5, 6}, {5, 10}, {6, 7}, {7, 8}, {7, 12}, {8, 9}, {9, 10}, {9,14}, {10, 11}, {11, 12}, {12, 13}, {13, 14}} These are the same edges as GraphData["HeawoodGraph", "EdgeIndices"] Graphics[{Red, Disk[#, .02] & /@ points, Black, Line[{points[[#[[1]]]], points[[#[[2]]]]}] & /@ edges}] With this code, we can verify that all the edges are 1. EuclideanDistance[points[[#[[1]]]], points[[#[[2]]]]] & /@ edges So, how did I find this? I originally had the 8 points at the top in a regular octagon, but that made the bottom edge longer than 1. I needed an 8 cycle where all the edges had length 1. MyEuc[{a, b}, {c, d}] := Sqrt[(a - c)^2 + (b - d)^2]; Solve[MyEuc[{x, 1/2}, {-1/2, -y}] == 1] That gives the first eight pts. Next we need pts 9 at a distance of 1 from pts 1 and 5. {a, b} /. FullSimplify[Solve[{MyEuc[pts[[1]], {a, b}] == 1, MyEuc[pts[[5]], {a, b}] == 1}]] Turns out we want the second of those. With symmetry, we have pts 1-12. For the last 2, b /. FullSimplify[Solve[{MyEuc[{Sqrt[3 - 4 x^2]/(2 Sqrt[1 + 4 x^2]), -((x Sqrt[3 - 4 x^2])/Sqrt[1 + 4 x^2])}, {1/2, b}] == 1}]] From that, we get the last two points. {1/2, -((x Sqrt[3 - 4 x^2])/Sqrt[1 + 4 x^2]) - Sqrt[(8 x^2 + Sqrt[3 + 8 x^2 - 16 x^4])/(2 + 8 x^2)]} To solve for x, we need a solution for a nasty equation. Solve[] wasn't working, so I tried a trick. NMinimize[{Abs[ Sqrt[(((x Sqrt[3 - 4 x^2])/Sqrt[1 + 4 x^2] + Sqrt[(8 x^2 + Sqrt[3 + 8 x^2 - 16 x^4])/(2 + 8 x^2)] - 1/2 Sqrt[(7 + 8 Sqrt[3 - 4 x (1 + x)] - 8 x (-1 + x (1 + 2 x (2 + x))))/(13 + 8 x (1 + x) (-3 + 2 x (1 + x)))])^2 + (-(1/2) - 1/2 (-1 + Sqrt[3 - 4 x (1 + x)]) Sqrt[(7 + 8 Sqrt[3 - 4 x (1 + x)] - 8 x (-1 + x (1 + 2 x (2 + x))))/(13 + 8 x (1 + x) (-3 + 2 x (1 + x)))])^2)] - 1], .1 < x < .3}, x, AccuracyGoal -> 2000, WorkingPrecision -> 4000] Then I took that and put it into RootApproximant[] -- and got the solution. Root[-153027 + 1353114 #1 - 1986024 #1^2 + 2763312 #1^3 + 10497808 #1^4 + 31063072 #1^5 - 8457728 #1^6 - 40590336 #1^7 + 44468736 #1^8 + 164975616 #1^9 + 119705600 #1^10 - 494067712 #1^11 - 763912192 #1^12 + 414924800 #1^13 + 1154613248 #1^14 + 48496640 #1^15 - 864485376 #1^16 - 376307712 #1^17 + 253231104 #1^18 + 271581184 #1^19 + 89128960 #1^20 + 10485760 #1^21 &, 1] And so, we get an exact unit-distance embedding with the Heawood graph, with symmetry. Attachments:
4 Replies
Sort By:
Posted 9 years ago
 ...
Posted 9 years ago
Posted 9 years ago
 NMinimize[{Abs[ Sqrt[(((x Sqrt[3 - 4 x^2])/Sqrt[1 + 4 x^2] + Sqrt[(8 x^2 + Sqrt[3 + 8 x^2 - 16 x^4])/(2 + 8 x^2)] - 1/2 Sqrt[(7 + 8 Sqrt[3 - 4 x (1 + x)] - 8 x (-1 + x (1 + 2 x (2 + x))))/(13 + 8 x (1 + x) (-3 + 2 x (1 + x)))])^2 + (-(1/2) - 1/2 (-1 + Sqrt[3 - 4 x (1 + x)]) Sqrt[(7 + 8 Sqrt[3 - 4 x (1 + x)] - 8 x (-1 + x (1 + 2 x (2 + x))))/(13 + 8 x (1 + x) (-3 + 2 x (1 + x)))])^2)] - 1], .1 < x < .3}, x, AccuracyGoal -> 2000, WorkingPrecision -> 4000] It was right in the notebook. The big Sqrt[] doesn't copy over correct as input text.
Posted 9 years ago