How to solve trisecting a pentagon

I thought maybe I could learn Mathematica to help me trisect a pentagon. I can't figure out how to write a Solve to get d0 on L0 to match all the other d's around it. The slider changes d and the three lines stay an equal distance from the edges. I estimated d0 to be .4935 but I was hoping to get an "exact" answer using Solve or something similar. Sorry for the static labels. I'm really just trying to solve for the segment length of d0 to equal the segment length of d. Any help would be greatly appreciated. (code updated)

p = Table[{Cos[θ], Sin[θ]} // N, {θ, π/2 + 2 π/5, -3 π/2 + 2 π/5, -2 π/5}]
dp[d_] := d Sin[2 Pi/5] (* d'prime *)
Manipulate[
i1 = Solve[{x, y} ∈ InfiniteLine[{p[[1]], p[[5]]}] &&
{x, y} ∈ InfiniteLine[{p[[5]] + {0, dp[d] }, p[[4]] + {0, dp[d]}}], {x, y}];
i2 = Solve[{x, y} ∈ InfiniteLine[{p[[1]] + {d, 0}, p[[5]] + {d, 0}}] &&
{x, y} ∈ InfiniteLine[{p[[5]] + {0, dp[d] }, p[[4]] + {0, dp[d]}}], {x, y}];
i3 = Solve[{x, y} ∈ InfiniteLine[{p[[3]] - {d, 0}, p[[4]] - {d, 0}}] &&
{x, y} ∈ InfiniteLine[{p[[5]] + {0, dp[d] }, p[[4]] + {0, dp[d]}}], {x, y}];
i4 = Solve[{x, y} ∈ InfiniteLine[{p[[3]], p[[4]]}] &&
{x, y} ∈ InfiniteLine[{p[[5]] + {0, dp[d] }, p[[4]] + {0, dp[d]}}], {x, y}];
x0 = Flatten[{x} /. {i1, i2, i3, i4}];

Graphics[{
Text[Row[{"d = ", x0[[2]] - x0[[1]], ", d0 = ", x0[[3]] - x0[[2]]}]],
Text[{"p1", "p2", "p3", "p4", "p5"}[[#]], p[[#]] 1.1] & /@ Range[5],
Line[p], Blue,
Line[{{0, -0.8}, {0, -0.35}}],
Text[Subscript["d", "p"], {-.05, -.53}], Black,
Text[Subscript["d", "0"], {-.05, -.3}],
Text["d", #] & /@ {
{-.5, -.3}, {.5, -.3}, {-.63, -.53}, {-.25, -.53},
{.25, -.53}, {.63, -.53}, {-.35, -.77}, {.35, -.77}
},
Text[Subscript["L", "0"], {-1, -.3}],
Text["i1", {-.7, -.3}], Text["i2", {-.32, -.3}],
Text["i3", {.32, -.3}], Text["i4", {.7, -.3}],
InfiniteLine[{p[[1]] + {d, 0}, p[[5]] + {d, 0}}],
InfiniteLine[{p[[3]] - {d, 0}, p[[4]] - {d, 0}}],
InfiniteLine[{p[[5]] + {0, dp[d] }, p[[4]] + {0, dp[d]}}]},
ImageSize -> Automatic],
{{d, .4935}, .3, .6},
TrackedSymbols :> d]

• I don't see how your approach, even if your technical difficulties were solved, can divide a regular pentagon into three equal areas Apr 29, 2020 at 0:00
• Your StringJoin expression can replaced with the simpler Row[{"d = ", x0[[2]] - x0[[1]], ", dp = ", x0[[3]] - x0[[2]], ", d = ", x0[[4]] - x0[[3]]}] Apr 29, 2020 at 1:14
• I'm not trying to solve an area, it's a length of d problem. I'm trying to find an intersection point i1 so that the sement length of i2-i1 equals segment length i3-i2 equals segment length i4-i3. Hope that helps. Sorry I'm not able to explain it very well. Thanks for the tip on StringJoin. I'll look at Row. Apr 29, 2020 at 2:04
• Here is another tip. p = Table[{Cos[θ], Sin[θ]} // N, {θ, π/2 + 2 π/5, -3 π/2 + 2 π/5, -2 π/5}] Apr 29, 2020 at 2:58
• I love your Table function even though I don't understand it yet. I also use Row now. Thanks again. Apr 29, 2020 at 4:17

Edit

Maybe this will help you along with your problem. It shows you how to write a Manipulate expression that performs as I think you intend. It confirms that d = .4935 is quite close the trisection point.

In this edit I am adding labels since I found some free time to write the simple—if somewhat tedious—code needed to display them.

dp[d_] := d Sin[2. Pi/5]
pts = {"p1", "p2", "p3", "p4", "p5"};
p = Table[{Cos[θ], Sin[θ]} // N, {θ, π/2 + 2 π/5, -3 π/2 + 2 π/5, -2 π/5}];
DynamicModule[{ln1, ln2, ln3, i1, i2, i3, i4},
Manipulate[
ln1 = InfiniteLine[{p[[1]] + {d, 0}, p[[5]] + {d, 0}}];
ln2 = InfiniteLine[{p[[3]] - {d, 0}, p[[4]] - {d, 0}}];
ln3 = InfiniteLine[{p[[5]] + {0, dp[d]}, p[[4]] + {0, dp[d]}}];
i1 =
Solve[{x, y} ∈ InfiniteLine[{p[[1]], p[[5]]}] && {x, y} ∈ ln3, {x, y}][[1, All, 2]];
i2 = Solve[{x, y} ∈ ln1 && {x, y} ∈ ln3, {x, y}][[1, All, 2]];
i3 = Solve[{x, y} ∈ ln2 && {x, y} ∈ ln3, {x, y}][[1, All, 2]];
i4 =
Solve[{x, y} ∈ InfiniteLine[{p[[3]], p[[4]]}] && {x, y} ∈ ln3, {x, y}][[1, All, 2]];
Column[{
Graphics[
{Line[p],
Text[pts[[#1]], Offset[#2, p[[#1]]]] &,
{Range[5], {{-8, 0}, {0, 6}, {9, 0}, {7, -7}, {-7, -8}}}],
Text["i1", Offset[{9, 7}, i1]],
Text["i2", Offset[{9, 7}, i2]],
Text["i3", Offset[{-9, 7}, i3]],
Text["i4", Offset[{-9, 7}, i4]],
Text["d", Offset[{0, 7}, (i1 + i2)/2]],
Text[Subscript["d", "0"], Offset[{0, 7}, (i2 + i3)/2]],
Text["d", Offset[{0, 7}, (i3 + i4)/2]],
Text[Subscript["d", "p"], Offset[{8, 0}, {0, p[[5, 2]] + dp[d]/2}]],
Blue, Line[{{0, p[[5, 2]]}, {0, p[[5, 2]] + dp[d]}}], ln1, ln2, ln3,
Red, AbsolutePointSize[5], Point[{i1, i2, i3, i4}]},
ImageSize -> Medium],
Spacer[{1, 20}],
Row[{"i1 = ", i1, " i2 = ", i2, "\ni3 = ", i3, " i4 = ", i4}],
Item[
Row[{"d = ", d, " dp = ", dp[d], " d0 = ", EuclideanDistance[i2, i3]}],
Alignment -> Left]},
Center],
{d, .45, .55, .0001, ImageSize -> 400}],
SaveDefinitions -> True]


• I appreciate you refactoring my code. It's a lot cleaner now. I thought of a solution last night. dx = Solve[{x, y} ∈ ln2 && {x, y} ∈ ln3 && d == 2 x, {x, y, d}] {{x -> 0.246765, y -> -0.339643, d -> 0.49353}} Apr 29, 2020 at 15:31
• @shirha. I found time to add dynamically positioned labels to the diagram. Apr 29, 2020 at 23:43
• Yea, I just noticed that! Apr 30, 2020 at 22:51
• @DavidC. Thanks for the invite, but I can't find the time for that these days. Sorry. Jul 4, 2020 at 21:22
• No problem. Thanks anyway. Jul 5, 2020 at 2:17

Here is an alternate synthetic geometry approach using GeometricScene.

ri = RandomInstance[
GeometricScene[{{o -> {0, 0}, d0,
p1 -> {-Sqrt[5/8 + Sqrt[5]/8], 1/4 (-1 + Sqrt[5])}, p2, p3, p4,
p5, i1, i2, i3, i4, m}, {r -> 1}}, {circ = Circle[o, r],
EuclideanDistance[i1, i2] == EuclideanDistance[i2, i3] ==
EuclideanDistance[i3, i4] == EuclideanDistance[i1, p5],
EuclideanDistance[m, p4] == EuclideanDistance[m, p5],
EuclideanDistance[o, p1] == EuclideanDistance[o, p3] ==
EuclideanDistance[o, p5] == r,
EuclideanDistance[i2, d0] == EuclideanDistance[d0, i3],
GeometricAssertion[{Polygon[{p1, p2, p3, p4, p5}]}, "Regular",
"Clockwise"],
GeometricAssertion[{i1, i2, i3, i4}, {"Inside", circ}],
GeometricAssertion[{i1, i2, i3, i4, d0}, "Collinear"],
GeometricAssertion[{p1, i1, p5}, "Collinear"],
GeometricAssertion[{p3, i4, p4}, "Collinear"],
GeometricAssertion[{p4, m, p5}, "Collinear"],
GeometricAssertion[{Line[{p4, p5}], Line[{i1, i4}]},
"Parallel"]}], RandomSeeding -> 1]
pts = ri["Points"];
{EuclideanDistance[i1, i2], EuclideanDistance[i1, p5],
EuclideanDistance[i2, i3]} /. pts


• Thank you so much for this code. I think it's amazing and I learned a lot from it. I hadn't studied Geometric Scene's yet. Quick question, does it generate p2-p5 given o and p1 and GeometricAssertion[{Polygon[{p1, p2, p3, p4, p5}]}, "Regular", "Clockwise"]? Apr 29, 2020 at 16:09
• @shirha You are welcome. If you do not specify p1, it gives you a randomly oriented pentagram. If you don't specify Clockwise, it may reverse the direction of the ordering of the vertices on the pentagram. It was purely to get the visualization consistent with your figure. I find GeometricScene to be interesting, underused, but sometimes tricky to get the hang of. Apr 29, 2020 at 16:19