# Subdividing a polygon , equivalent fractions

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)}];
Polygon[Flatten[{ {{0, 0}},
Table[{Cos[i], Sin[i]}, {i, 0, pieces 2 \[Pi]/divs,
2 \[Pi]/divs}], {{0, 0}}}, 1]]};
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

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} &,
EdgeForm[Directive[Dashed, Thin]], FaceForm[None],
,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}]]
}] &}
]

• Absolutely amazing, remarkable! that is very cool, but sadly, not something I can use with my junior high kids! But it answers my (flawed) question! – Tom De Vries Feb 25 '13 at 19:32

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.

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 \
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}]


• Have you noticed that subdividing the perimeter into equal-length segments does not subdivide the area into equal-area pieces? This distinction seems of great importance in the intended application of visualizing fractions! – whuber Feb 22 '13 at 16:38
• Details. Minor details. – user273 Feb 23 '13 at 1:50
• Yes, I realized my original question was totally flawed as posted... thanks for the time you took to reply. – Tom De Vries Feb 25 '13 at 19:31

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}
]


• Wow, that is so amazing. A very neat visual effect. I'll save that and use it, but probably only with a few kids. I really appreciate the time that must have taken. I wish my programming skills could produce that kind of demonstration. I with the "demonstrations" site had an "offshoot", a "lessons" side. Bring the skills of a community to bear writing GOOD lessons (using Mathematica) that teach " " . It would be amazing. – Tom De Vries Feb 25 '13 at 19:30

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}]]]


• The actual fractions that it shows won't be correct except for special cases. – jVincent Feb 22 '13 at 13:40
• @jVincent, good point. Tom's original code uses equal angular divisions and I unthinkingly copied that but with the spoke radius changed. – Simon Woods Feb 22 '13 at 14:57
• I do apologize for my flawed question! – Tom De Vries Feb 25 '13 at 19:32