4
$\begingroup$

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)

trisect pentagon

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]
$\endgroup$
5
  • 1
    $\begingroup$ I don't see how your approach, even if your technical difficulties were solved, can divide a regular pentagon into three equal areas $\endgroup$
    – m_goldberg
    Apr 29, 2020 at 0:00
  • $\begingroup$ Your StringJoin expression can replaced with the simpler Row[{"d = ", x0[[2]] - x0[[1]], ", dp = ", x0[[3]] - x0[[2]], ", d = ", x0[[4]] - x0[[3]]}] $\endgroup$
    – m_goldberg
    Apr 29, 2020 at 1:14
  • $\begingroup$ 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. $\endgroup$
    – shirha
    Apr 29, 2020 at 2:04
  • $\begingroup$ Here is another tip. p = Table[{Cos[θ], Sin[θ]} // N, {θ, π/2 + 2 π/5, -3 π/2 + 2 π/5, -2 π/5}] $\endgroup$
    – m_goldberg
    Apr 29, 2020 at 2:58
  • $\begingroup$ I love your Table function even though I don't understand it yet. I also use Row now. Thanks again. $\endgroup$
    – shirha
    Apr 29, 2020 at 4:17

2 Answers 2

4
$\begingroup$

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]

manipulate

$\endgroup$
5
  • $\begingroup$ 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}} $\endgroup$
    – shirha
    Apr 29, 2020 at 15:31
  • $\begingroup$ @shirha. I found time to add dynamically positioned labels to the diagram. $\endgroup$
    – m_goldberg
    Apr 29, 2020 at 23:43
  • $\begingroup$ Yea, I just noticed that! $\endgroup$
    – shirha
    Apr 30, 2020 at 22:51
  • $\begingroup$ @DavidC. Thanks for the invite, but I can't find the time for that these days. Sorry. $\endgroup$
    – m_goldberg
    Jul 4, 2020 at 21:22
  • $\begingroup$ No problem. Thanks anyway. $\endgroup$
    – DavidC
    Jul 5, 2020 at 2:17
5
$\begingroup$

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

GeometricScene Solution

$\endgroup$
2
  • $\begingroup$ 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"]? $\endgroup$
    – shirha
    Apr 29, 2020 at 16:09
  • $\begingroup$ @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. $\endgroup$
    – Tim Laska
    Apr 29, 2020 at 16:19

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.