Subdividing a polygon , equivalent fractions

Question

I see that I was a real "doofus" here and my original question was flawed. You can't divide a polygon like you can a circle or a rectangle, except in special cases... I should have seen that right away, as always, I learn so much connecting with users here.... I can still use the solutions that are being posted, but limit the divisions to special cases... sorry for the poorly thought out question....

I'm working with a grade 7 student and going over fractions.... it's always fractions...

I have a simple demonstration that shows fractions, and then emphasizes equivalent fractions by subdividing the pieces.

 Manipulate[

 Graphics[{

   Flatten[{Red, 
     Disk[{0, 0}, 1, {(# - 1)   2 \[Pi]/divs,  #  2 \[Pi]/divs}] & /@ 
      Range[pieces]}],

   {Thickness[0.005], Circle[]},

   {Thickness[0.005], 
    Line /@ Table[{{0, 0}, {Cos[i], Sin[i]}}, {i, 0, 2 \[Pi], 
       2 \[Pi]/divs}]},

   {Thickness[0.001], 
    Line /@ Table[{{0, 0}, {Cos[i], Sin[i]}}, {i, 0, 2 \[Pi], 
       2 \[Pi]/(mult divs)}]}},
  ImageSize -> 600],

 {{divs, 2, "divisions"}, 2,  10, 1, ControlPlacement -> Left},
 {{pieces, 1, "pieces"}, 1,  divs, 1, ControlPlacement -> Left},
 {{mult, 1, "multiplier"}, 1, 10, 1, ControlPlacement -> Left}
 ]

Same idea with rectangles

     Manipulate[
 Graphics[{

   {Pink, Rectangle [{0, 0}, {60, pieces 100/divs}]},

   {Thickness[0.005], 
    Line[{{0, 0}, {60, 0}, {60, 100}, {0, 100}, {0, 0}}]},

   {Thickness[0.005], 
    Line /@ Table[{{0, i 100/divs}, {60, i 100/divs}}   , {i, 1, 
       divs}]},

   {Thickness[0.001], 
    Line /@ Table[{{i 60/divs2, 0}, { i 60/divs2, 100}}   , {i, 1, 
       divs2}]}


   }, ImageSize -> 500],
 {{divs, 2, "vertical"}, 1, 10, 1, ControlPlacement -> Left},
 {{divs2, 1, "horizontal"}, 1, 10, 1, ControlPlacement -> Left},
 {pieces, 1, divs, 1, ControlPlacement -> Left}
 ]

Okay, my polygon demonstration is sort of working, but way out of my depth here... if I "subdivide" the polygon to show equivalent fractions, I'd need to find points on the polygon, but the "easy" points are on the enclosing circle.

Manipulate[Module[{perimeter, spokes, shaded, minispokes},

  perimeter = 
   Line[Table[{Cos[i], Sin[i]}, {i, 0, 2 \[Pi], 2 \[Pi]/divs}]];
  spokes = 
   Line /@ Table[{{0, 0}, {Cos[i], Sin[i]}}, {i, 0, 2 \[Pi], 
      2 \[Pi]/divs}];
  minispokes = 
   Line /@ Table[{{0, 0}, {Cos[i], Sin[i]}}, {i, 0, 2 \[Pi], 
      2 \[Pi]/(mult divs)}];
  shaded = {Green, 
    Polygon[Flatten[{ {{0, 0}}, 
       Table[{Cos[i], Sin[i]}, {i, 0, pieces 2 \[Pi]/divs, 
         2 \[Pi]/divs}], {{0, 0}}}, 1]]};
  Graphics[{shaded, {Thickness[0.005], perimeter, 
     spokes}, {Thickness[0.001], minispokes}}, ImageSize -> 500, 
   PlotRange -> {{-1, 1}, {-1, 1}}]
  ],
 {{divs, 5, "sides"}, 1, 12, 1, ControlPlacement -> Left},
 {{pieces, 1, "pieces"}, 1, divs, 1, ControlPlacement -> Left},
 {{mult, 1, "multiplier"}, 1, 10, 1, ControlPlacement -> Left}
 ]

Hopefully my problem makes sense. How would I create those subdivision lines so the endpoints are on the polygon, not on the circle?

I'd welcome any suggestions, feedback, etc.

Tom

Answer 1

Given the corners of a non-self-intersecting polygon and a point inside its kernel it divides the polygon into desired number of equal-area pieces that are connected at the given point:

The method is pretty straightforward. Starting with the interior point $c$ and the first edge point $p_1$ it finds an expression in $s$ for the area $a(s)$ of the polygon given by $\{c,p_1,...,p_{\lfloor s \rfloor }, (1-t(s)) p_{\lfloor s \rfloor} + t(s) p_{\lfloor s \rfloor+1}\}$ Since the area is piece-wise linear and strictly increasing it has a trivial inverse that is used to find the $s$ s.t. $a(s_i) = \frac{i\text{ total area}}{\text{divisions}}$ Which are then used to construct the equal-area decomposition.

starPts[d_, or_: 1, ir_: 1/2] := Module[{
  outer = or {Cos[#], Sin[#]} & /@ Range[-Pi, Pi - 2 Pi/d, (2 Pi)/d], 
  inner = ir {Cos[#], Sin[#]} & /@ Range[-Pi + Pi/d, Pi - Pi/d, 2 Pi/d]}, 
  Flatten[{outer, inner}\[Transpose], 1]]

regularPts[d_, r_: 1.] := r {Cos[#], Sin[#]} & /@ Range[-Pi, Pi - 2 Pi/d, 2 Pi/d];

polyArea[pts_] := 1/2 Abs[Total[
  Det[{First@#, Last@#}\[Transpose]] & /@ ({pts, RotateLeft[pts]}\[Transpose])]]

polyInterpolate[poly_] := 
  Interpolation[MapIndexed[{First@#2, #1} &, poly], InterpolationOrder -> 1]

areaDivisions[opts_, c_, ndivs_: 3, rot_: 1] := Module[
              {totA, pts, edge, divisions, area, areainv, s},
  pts = N@opts;
  totA = polyArea[pts];
  If[rot != 1,
   If[Ceiling[rot] != rot,
    edge = polyInterpolate[Append[pts, First@pts]];
    pts = Insert[pts, edge[rot], Ceiling[rot]];];
   pts = RotateLeft[pts, Ceiling[rot] - 1];];

  pts = Append[pts, First@pts];
  edge = polyInterpolate@pts;

  area[s_] := polyArea[{c, Sequence @@ edge[Join[Range[1, s], {s}]]}];
  areainv = Interpolation[{area@#, #} & /@ Range[Length@pts]
                          ,InterpolationOrder -> 1];
  divisions = areainv[totA/ndivs Range[0, ndivs]];
  Join[{c, edge[First@#]}, pts[[Ceiling@First@# ;; Floor@Last@#]],
           {edge[Last@#]}] & /@ ({Most@divisions, Rest@divisions}\[Transpose])
 ]

Manipulate[
 Graphics[{Opacity[0.5], EdgeForm[Thick], 
   MapIndexed[{ColorData[3][First@#2], Polygon@#1} &, 
    areaDivisions[Rest@pt, First@pt, divisions, r]], 
   EdgeForm[Directive[Dashed, Thin]], FaceForm[None], 
   Polygon@areaDivisions[Rest@pt, First@pt, m divisions, r]}
   ,AspectRatio -> 1, PlotRange -> {{-1, 1}, {-1, 1}}, PlotRangePadding -> 0.2
   ,GridLines -> {Range[-1, 1, .2], Range[-1, 1, .2]}],
 {{divisions, 5, "Divisions"}, 3, 8, 1},
 {{m, 2, "Multiplier"}, 1, 10, 1},
 {{r, 1, "Rotation" }, 1, Length@pt},
 {{pt, Prepend[regularPts[5], {0, 0}]}, Locator, LocatorAutoCreate -> True},
 {{y, 0, ""}, 
  Row[{Button["Star", r = 2; 
        pt = Prepend[starPts[divisions], {0, 0}]], 
      Button["Regular polygon", r = 1; 
        pt = Prepend[regularPts[divisions], {0, 0}]]
     }] &}
 ]

Answer 2

As Michael commented you can simply interpolate along the edges. Here's a function that allows you to find points along the edge of the polygon using non-integer indices, so for instance using 4.5 will give you the point halfway between 4 and 5:

around[v_] := Append[v,First@v]

polyInterpolate[poly_]:=With[{
x=Interpolation[poly\[Transpose][[1]],InterpolationOrder->1],
y=Interpolation[poly\[Transpose][[2]],InterpolationOrder->1],
},
Function[n,{x@n,y@n}]
]

You can use this to find new points along the outer edges of a polygon:

poly = {{0.3, 0.1}, {0.8, 0.8}, {0.5, 0.9}, {0.2, 0.6}};
polyInterpolate[around@poly] /@ Range[1, Length@around@poly, 0.1] // 
Point // Graphics

To get what you are trying to do, you'd then need to figure out which points to take, and likely how to handle fractions that don't neatly divide your polygon.

Answer 3

I like the other answers better, but here's what first came to mind for me. Just subdividing each line of the polygon, and then drawing a polygon from some subset of that list, plus the point {0,0}.

(* table made by subdividing the line {p1,p2} into numtimes segments. \
*)
subdivideLine[v_, numtimes_] := 
  Table[(v[[2]] - v[[1]]) i/(numtimes + 1) + v[[1]], {i, 0, 
    numtimes}];  

(* Subdivides each edge of a polygon the required number of times, \
using the subdivideLine function *)
subdividePolygon[plist_, numtimes_] :=
  Flatten[
   Table[subdivideLine[{plist[[i]], 
      plist[[ Mod[i, Length[plist]] + 1]]}, numtimes], {i, 1, 
     Length[plist]}],
   1];

(* returns a regular polygon with nsides, subdivided numdivisions \
times, radius r. *)
getDividedPolygon[numsides_, numdivisions_, r_] :=
  subdividePolygon[
   Table[{r Cos[2 Pi i/numsides], r Sin[2 Pi i/numsides]}, {i, 0, 
     numsides - 1, 1}],
   numdivisions];

Manipulate[Module[{poly},
  poly = getDividedPolygon[n, d, 1];
  Graphics[{Red, Polygon@poly,
    (* Draw the filled portion of the polygon. 
    The If statement is needed to smoothly handle the case when "m" \
is at the last element in the polygon. *)
    Green, 
    Polygon@Join[{{0, 0}}, 
      If[m == n*(d + 1), Join[Take[poly, m], {poly[[1]]}], 
       Take[poly, m + 1]]],
    Black, Point /@ poly}]
  ], {n, 3, 10, 1}, {d, 0, 10, 1}, {{m, 2}, 0, n*(d + 1), 1}]

Answer 4

I think this is what you're after, but I changed how the polygon is drawn. A triangle is rotated repeatedly. The subdivisions interpolate equally spaced points on the base of the triangle. Since area is base x height / 2, the areas will be equal. One difficulty with this presentation is that the triangles are not congruent, which might raise questions in a youngster's mind whether the areas are the same.

Manipulate[Module[{vertices, triangle, minispokes, polygon},
  vertices = {{0, 0}, {1, 0}, {Cos[2 π/divs], Sin[2 π/divs]}};
  minispokes = {Black, Thickness[0.001], 
    Line@Table[{{0, 0}, m/mult vertices[[2]] + (1 - m/mult) vertices[[3]]}, {m, 1, mult - 1}]};
  triangle = {EdgeForm[Directive[Black, Thickness[0.005]]], 
    Polygon[vertices], minispokes};
  polygon = Table[Rotate[triangle, 2 π (p - 1)/divs, {0, 0}], {p, divs}]; 
  Graphics[{Green, Insert[polygon, White, Min[pieces, divs] + 1]}, 
   PlotRange -> 1, ImageSize -> 500]
  ],
 {{divs, 5, "sides"}, 3, 12, 1},
 {{pieces, 1, "pieces"}, 0, divs, 1},
 {{mult, 1, "multiplier"}, 1, 10, 1},
 ControlPlacement -> Left
 ]

One could go further and unroll the polygon. Then the triangles will be on equal bases and between the same parallels. Then the vertices of the triangle can slide along the parallels until congruent:

Manipulate[
 Module[{vertices, polyGraphics, unrollGraphics, basepoint, triangle},

  vertices = Table[{Sin[i - π/divs], -Cos[i - π/divs]}, {i, 0, 2π, 2 π/divs}];(* beg = end *)

  triangle[0] := {EdgeForm[Directive[Black, Thickness[0.005]]], 
    Polygon[{{0, 0}, vertices[[1]], vertices[[2]]}], Black, 
    Thickness[0.001], 
    Line@Table[{{0, 0}, m/mult vertices[[1]] + (1 - m/mult) vertices[[2]]}, {m, 1, mult - 1}]}; 
  triangle[t_] := {EdgeForm[Directive[Black, Thickness[0.001]]], 
    Polygon@Table[{{-2 t (m + 0.5 - mult/2) Sin[π/divs]/mult, 0}, 
       m/mult vertices[[1]] + (1 - m/mult) vertices[[2]],
      (m + 1)/mult vertices[[1]] + (1 - (m + 1)/mult) vertices[[2]]}, {m, 0, mult - 1}]};

  polyGraphics = 
   Table[{If[p <= pieces, Green, White], Rotate[triangle[0], 2 \[Pi] (p - 1)/divs, {0, 0}]}, {p, divs}];

  basepoint = {-1, -3} - vertices[[1]];

  unrollGraphics[-1] = 
   Graphics[polyGraphics, PlotRange -> {{-1.5, 1.5}, {-1, 1}}];
  unrollGraphics[t_] := 
   Graphics[{Translate[polyGraphics, (1 + t) basepoint], polyGraphics}, 
     PlotRange -> {{-1.5, 1.5} + (1 + t) {0.5, 4}, {-1, 1} + (1 + t) {-7/3, 0}}] /; t <= 0;
  unrollGraphics[t_] := 
   Module[{segs = Min[Ceiling[divs t], divs], angle = -2 π t, cornerpoint},
     cornerpoint = basepoint + {2 (segs - 1) Sin[π/divs], 0} + vertices[[2]];
     Graphics[{polyGraphics, 
       Table[{If[p <= pieces, Green, White], 
         Translate[triangle[Clip[t - 1, {0, 1}]], 
          basepoint + {2 (p - 1) Sin[π/divs], 0}]}, {p, segs}], 
       Rotate[Translate[Drop[polyGraphics, segs], 
         cornerpoint - vertices[[segs + 1]]], angle, cornerpoint],
       If[t > 1, 
        Line@Table[p + j {0, Cos[π/divs]}, {j, 0, 1}, {p, {basepoint + vertices[[1]], cornerpoint}}]]
       }, PlotRange -> {{-1, 5.5}, {-10/3, 1}}]
     ] /; t > 0;

  unrollGraphics[unroll]

  ],
 {{divs, 5, "sides"}, 3, 12, 1},
 {{pieces, 1, "pieces"}, 1, divs, 1},
 {{mult, 1, "multiplier"}, 1, 10, 1},
 {{unroll, -1}, -1, 2.5}
]

Answer 5

You could use a polar description of the polygon perimeter:

polyRadius[n_, th_] := Cos[Pi/n]/Cos[Mod[th, 2 Pi/n] - Pi/n]

e.g.

n = 5;
spokes = 2 n;

spokeEnds = polyRadius[n,#] {Cos[#], Sin[#]} & /@ Range[2 Pi/spokes, 2 Pi, 2 Pi/spokes];

PolarPlot[polyRadius[n, th], {th, 0, 2 Pi}, Axes -> False,
 Epilog -> Line[Tuples[{{{0, 0}}, spokeEnds}]]]