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.

Statement of the problem:

Conceptually, what I'm trying to achieve is pretty simple. I have some code that generates a set of diagrams from a list of sets of points using BSplineCurve. Certain conditions cause some of these diagrams to come out differently from what I need. With SplineDegree -> 1 the images look like:

Spline Degree 1

and with SplineDegree -> 3 the images become:

Spline Degree 3

The problematic cases are images a7, a8 and a9, which I need to look like:

Correct Images

The general rule is that I need closed smooth curves through the specified points, but the curve must not lie on top of itself when the points all lie on a straight line (I also need the curves to pass directly through the points, but this is another issue that is probably fairly easily solved - I've tried clamping without much success so far).

I have tried to solve this problem by implementing clunky IF statements that add additional guide points, but in addition to the fact that I struggle to make it work, it's very undesirable, because I need this to generalize to more complicated diagrams. For example, here is a preview of the higher dimensional case (the full list is very long):

Higher Dimension Sample

The last five images are problematic and should look like

Correct Higher Dimension Sample

I have also considered using Graph to try and do this, but I'm not really sure where to start.

Code:

I can't provide the full code, because the process of generating the list of points is exceptionally long. Here is the section that is relevant:

Clear[\[Delta]ToBirdTrack1];
Options[\[Delta]ToBirdTrack1] = {Background -> White, Trace -> Tr, 
   Scale -> 1};
\[Delta]ToBirdTrack1[expr_, A_: a, B_: b, 
   options___Rule] := \[Delta]ToBirdTrack1[expr, A, B, options] = 
   Module[{l, s, aa, bb, h, res, res1, hsep, vsep, samesep, bgcolor, 
 trace, scale, split},

(* options *)
bgcolor = Background /. {options} /. Options[\[Delta]ToBirdTrack1];
trace = Trace /. {options} /. Options[\[Delta]ToBirdTrack1];
scale = Scale /. {options} /. Options[\[Delta]ToBirdTrack1];

hsep = 5;
vsep = 2;
samesep = hsep/6;
l = (expr // 
     Cases[#, Subscript[A,  i], Infinity, Heads -> True] & // 
    Union // Length);
h = l*vsep;

(*line 1*)
res = (expr /. 
      Tr[aa__] :> m[Line[(*Append[*)aa(*,First[aa]]*)]] //. 
     m[aa__] m[bb__] -> m[aa, bb]) /. UP -> Sequence /. 
  Subscript[t, i_] -> i;

(*line 2*)
res = res // (# /. m[aa__] :> (m[aa] /. a_Line :> pos /@ a)) &;

(*line 3*)
res // (# /. 
     Line[aa__] :> 
      BSplineCurve[{aa}, SplineClosed -> True]) & // (# /. 
    m[aa__] :> Graphics[{aa}]) &
];

ExplicitList[NgI[2]] // 
  Sum[Subscript[\[Alpha], i] #[[i]], {i, 
 Length[#]}] & // \[Delta]ToBirdTrack1[#] &

I can't provide the data being put into this code, again because of length, but I can however show what it looks like. At "line 1" res is being shaped into this list:

Algebraic List

At "line 2" it is shaped into this list:

Line object list of coordinates

And at "line 3" the "aa's" that are being considered by the Spline Curve plotting look like this:

Coordinates

Any and all help would be greatly appreciated, with the most general solution being the goal.

share|improve this question

1 Answer 1

up vote 6 down vote accepted

Here's a way with Interpolation. It passes through the points as the OP desires. It specifies the velocity (derivative) through the points by bisecting the exterior angle of the polygon; if the path turns back on itself, it specifies a velocity at a right angle (to the "left" of the direction of approach to the vertex) to the edge. The weights multiply the velocities; it can be a single scalar or a list of scalars, one for each vertex. There are probably shortcomings with more complicated diagrams but it works pretty well on the ones I tested.

Clear[diag, intPts];
intPts[list_, weights_: 1] := 
  With[{dl = 
     weights (Through[{Cos, Sin}[
           If[Total[#] == {0, 0}, ArcTan @@ Cross@First@#, 
            ArcTan @@ Total[#]]]] & /@ (Normalize /@ # &) /@ 
         Differences /@ Partition[list, 3, 1, 2])},
   Transpose@{
     List /@ Rescale[Range[1 + Length@list]],
     Append[#, First@#] &@list,
     Append[#, First@#] &@dl}
   ];
diag[pts_] := Interpolation /@ intPts /@ pts;
diag[pts_, wts_List] := Interpolation /@ MapThread[intPts, {pts, wts}];
diag[pts_, wts_] := Interpolation /@ (intPts[#, wts] &) /@ pts;

Examples

Since copyable coordinates weren't provided, I made up my own. These are like the last three of the first set of the OP's examples.

a7 = {{{0, 0}, {2, 1}}, {{2, 0}, {0, 1}}};
a8 = {{{0, 0}, {2, 0}}, {{0, 1}, {2, 1}}};
a9 = {{{0, 0}, {0, 1}}, {{2, 0}, {2, 1}}};
GraphicsRow[
 ParametricPlot[Evaluate@Through[diag[#][t]], {t, 0, 1}, 
    Axes -> False, PlotStyle -> Thick,
    Prolog -> {EdgeForm @ Directive[Dashed, Thickness[Small], Red], 
      Opacity[0], Polygon /@ #},
    Epilog -> {Red, PointSize[Medium], Point /@ #}] & /@ {a7, a8, a9}
 ]

Mathematica graphics

The last three figures of the second set of examples:

d3 = {{{0, 0}, {2, 1}, {2, 0}, {2, 2}, {0, 1}, {0, 2}}};
d4 = {{{0, 0}, {2, 1}, {1, 1}, {0, 1}, {0, 2}, {1, 1}, {2, 0}, {2, 2}, {1, 1}}};
d5 = {{{0, 0}, {2, 0}, {2, 2}, {0, 2}, {0, 1}, {2, 1}}};
GraphicsRow[
 ParametricPlot[Evaluate @ Through[diag[#, 5][t]], {t, 0, 1}, 
    Axes -> False, PlotStyle -> Thick,
    Prolog -> {EdgeForm @ Directive[Dashed, Thickness[Small], Red], 
      Opacity[0], Polygon /@ #},
    Epilog -> {Red, PointSize[Medium], Point /@ #}] & /@ {d4, d5, d6}
 ]

Mathematica graphics

share|improve this answer

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.