Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

pie in pieces

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

rectangle pieces

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

polygon pieces

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

share|improve this question
    
Interpolate along each edge: minispokes = Line@Flatten[Table[{{0, 0}, m/mult {Cos[2 \[Pi] d/divs], Sin[2 \[Pi] d/divs]} + (1 - m/mult) {Cos[2 \[Pi] (d - 1)/divs], Sin[2 \[Pi] (d - 1)/divs]}}, {m, 1, mult - 1}, {d, divs}], 1] –  Michael E2 Feb 22 '13 at 11:32
    
These will not answer your coding question but may be of interest for your actual goal: demonstrations.wolfram.com/ConvertingFractions demonstrations.wolfram.com/… demonstrations.wolfram.com/MultiplicationOfFractions demonstrations.wolfram.com/FundamentalLawOfFractions I'd think demonstrations.wolfram.com may have others of relevance as well. –  Daniel Lichtblau Feb 22 '13 at 15:10
    
Thanks for that! I appreciate it. I always go to the demonstrations site first for ideas. Sometimes it's just what I need, other times I need something "simpler", but it's a great resource. –  Tom De Vries Feb 23 '13 at 11:44
add comment

5 Answers

up vote 6 down vote accepted

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:

star

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}]]
     }] &}
 ]
share|improve this answer
    
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
add comment

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

Graphics showing the interpolated points

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.

share|improve this answer
add comment

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

subdivided polygon fraction

share|improve this answer
    
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. –  NeuroFuzzy 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
add comment

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

enter image description here

share|improve this answer
1  
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
add comment

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
 ]

Manipulate output

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

Grid of Manipulate outputs

share|improve this answer
    
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
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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