How to solve trisecting a pentagon
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
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],
MapThread[
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]