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 '20 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 '20 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 '20 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 '20 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 '20 at 4:17
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 '20 at 15:31
  • $\begingroup$ @shirha. I found time to add dynamically positioned labels to the diagram. $\endgroup$ – m_goldberg Apr 29 '20 at 23:43
  • $\begingroup$ Yea, I just noticed that! $\endgroup$ – shirha Apr 30 '20 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 '20 at 21:22
  • $\begingroup$ No problem. Thanks anyway. $\endgroup$ – DavidC Jul 5 '20 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 '20 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 '20 at 16:19

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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