13
$\begingroup$

I want to emphasize the self-intersections ("leaves") of parametric curves by applying a pattern or color to them.

Using cvgmt's answer to this question:

how-to-separate-the-regions-enclosed-by-curves

We define:

MeshComponents[plot_, n_, d_] :=
 Module[{mc},
  mc = RegionDistance[DiscretizeGraphics @ plot];
  mc = ImplicitRegion[mc @ {x, y} >= d, {{x, -n, n}, {y, -n, n}}];
  mc = BoundaryDiscretizeRegion[mc,
    Method -> "Semialgebraic",
    MaxCellMeasure -> 0.01];
  ConnectedMeshComponents @ mc]

We also define

$fill = PatternFilling["Diamond", ImageScaled[1/30]];

and

ColorLeaves[plot_, n_, d_, del_] :=
 Module[{mc, cl},
  mc = Delete[List /@ del] @ MeshComponents[plot, n, d];
  cl = Transpose[{Array[$fill &, Length @ mc], mc}];
  Show[Graphics[cl, Axes -> True], plot]]

Filling the leaves of an Epitrochoid is now relatively easy:

fun = 
 {a Sin[u] - b Sin[2 a u], a Cos[u] - b Cos[2 a u]} /. {a :> 3.5, b :> 1.2};

plot = ParametricPlot[fun, {u, 0, 2 Pi}];

MeshComponents[plot, 5, 0.025]

enter image description here

To only select the leaves we have to delete the first and third component.

ColorLeaves[plot, 5, 0.025, {1, 3}]

enter image description here

We use the same procedure to colour two other curves:

$fill = FaceForm[ColorData[97, "ColorList"][[2]]];

fun =
  {Cos[u] (a Sin[u]^b + 1)/a, -Sin[u] (a Cos[u]^c + 1)/a} /. {a :> 3, b :> 3, c :> 2};

plot = ParametricPlot[fun, {u, 0, 2 Pi}];

Looking at its mesh components we see that the 1st and 4th component must be deleted.

ColorLeaves[plot, 1, 0.0025, {1, 4}]

enter image description here

Similarly with the next plot:

fun = {Sin[u], -Cos[u]} Cos[u] (4 Sin[u]^2 - 1);

plot = ParametricPlot[fun, {u, 0, 2 Pi}];

ColorLeaves[plot, 1, 0.0025, {2}]

enter image description here

My question

It is cumbersome to visually inspect the mesh components for each curve and select the right ones. How can this process be automated? I need a short function which automatically detects the roundish leave-like shapes and ignores the other ones.

Thank you in advance for your suggestions and a Happy New Year for all of you

$\endgroup$
1
  • 1
    $\begingroup$ It is recommended to rewrite the code MeshComponents as below that we need not set the rangement n manually. Clear[MeshComponents]; MeshComponents[plot_, d_] := Module[{reg, bd, dist, mc, imreg}, reg = DiscretizeGraphics@plot; bd = RegionBounds[reg]; dist = RegionDistance[reg]; imreg = ImplicitRegion[dist@{x, y} >= d, {x, y}]; mc = BoundaryDiscretizeRegion[imreg, ScalingTransform[1.2*{1, 1}, Mean /@ bd]@bd, Method -> "Semialgebraic", MaxCellMeasure -> 0.01]; ConnectedMeshComponents@mc], after that , the code by @kglr work for the complex cases. $\endgroup$
    – cvgmt
    Jan 3 at 1:40

2 Answers 2

9
$\begingroup$
Clear["Global`*"];
fun = 8 {Cos[u], Sin[u]} - 2.5 {Cos[10 u], Sin[8 u]};
$fill = PatternFilling["Diamond", ImageScaled[1/30]];

plot = ParametricPlot[fun, {u, 0, 2 \[Pi]}, PlotPoints -> 60, 
   MaxRecursion -> 2];
lines = Cases[plot, _Line, -1] // First;
data = Region`Mesh`SplitIntersectingSegments[lines];
pts = data[[1]];
splits = data[[2]];
segments = Flatten[Partition[#, 2, 1] & /@ splits, 1];
g = Graph[Range@Length@pts, UndirectedEdge @@@ segments, 
   VertexCoordinates -> pts];
faces = PlanarFaceList[g];
polys = Polygon[pts[[#]]] & /@ faces;
polys = Pick[polys, Or @@@ Outer[RegionDisjoint, polys, polys]];
polys = DeleteDuplicates[polys, RegionEqual];
Graphics[{lines, {$fill, polys}, Magenta, 
  MapIndexed[Text[Style[First@#2, 18, Bold], RegionCentroid@#1] &, 
   polys]}]

enter image description here

  • For
fun = 8 {Cos[u], Sin[u]} - 1.5 {Cos[8 u], Sin[10 u]};

enter image description here

$\endgroup$
8
$\begingroup$
ClearAll[meshLeaves]

meshLeaves = GraphComputation`SinkVertexList @
  RelationGraph[UnsameQ @ ## && 
       RegionWithin[BoundingRegion[#], BoundingRegion[#2]] &, 
     MeshComponents[##]] &;

Examples:

$fill = PatternFilling["Diamond", ImageScaled[1/30]];

fun1 = {a Sin[u] - b Sin[2 a u], 
    a Cos[u] - b Cos[2 a u]} /. {a :> 3.5, b :> 1.2};

plot1 = ParametricPlot[fun1, {u, 0, 2 Pi}];

Show[Graphics[{$fill, meshLeaves[plot1, 5, 0.025]}, Axes -> True], plot1]

enter image description here

fun2 = {Cos[u] (a Sin[u]^b + 1)/a, -Sin[u] (a Cos[u]^c + 1)/a} /. {a :>
      3, b :> 3, c :> 2};

plot2 = ParametricPlot[fun2, {u, 0, 2 Pi}];

Show[Graphics[{$fill, meshLeaves[plot2, 1, 0.0025]}, Axes -> True], plot2]

enter image description here

fun3 = {Sin[u], -Cos[u]} Cos[u] (4 Sin[u]^2 - 1);

plot3 = ParametricPlot[fun3, {u, 0, 2 Pi}];

Show[Graphics[{$fill, meshLeaves[plot3, 1, 0.0025]}, Axes -> True], plot3]

enter image description here

$\endgroup$

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.