5
$\begingroup$

I'm wondering if anyone has a nice solution for breaking a kinked line into $(n-1)$ segments of equal euclidean distance?

Here is a MWE of my attempt. I think it does the job, and I'm sure the code can be improved, but I'm wondering if there is an much more simple/elegant way to do the job

topslope = .5;
botslope = 2;
kinkptX = 7.5;
kinkptY = 15;

kLine[x_]:=Piecewise[{{(kinkptY+kinkptX topslope)-topslope x,x<=kinkptX},{(kinkptY+kinkptX botslope)-botslope x,x>kinkptX}}]

(*Get Euclidean length of line *)
dist = Module[{xint},
   xint = Solve[kLine[x] == 0, x][[1, 1, 2]]; 
   EuclideanDistance[{xint, 0}, {kinkptX, kLine[kinkptX]}] + 
    EuclideanDistance[{kinkptX, kLine[kinkptX]}, {0, kLine[0]}]
   ];

(*note: n is number of points, which will give (n-1) segments *)
makePieces[n_] :=
 Module[{dist1, pLen, a, lowdist, ptForRdist, rKpt, rLpt, ptForLdist, 
   highdist, xint},
  dist1 = dist/(n - 1) ;
  xint = Solve[kLine[x] == 0, x][[1, 1, 
     2]];(*divide by n-1 to get n-1 equal length segments, 
  consisting of n points *)
  ptForRdist = 
   Solve[EuclideanDistance[{xint, 0}, {x, kLine[x]}] == dist1 && 
      kinkptX <= x < xint, x][[1, 1, 
     2]]; (*this point is used to find the distance between points on \
portion of the line to the right of the kink *)
  ptForLdist = 
   Solve[EuclideanDistance[{0, kLine[0]}, {x, kLine[x]}] == dist1 && 
      0 < x < kinkptX, x][[1, 1, 
     2]];(*this point is used to find the distance between points on \
portion of the line to the left of the kink *)
  highdist = ptForLdist - 0; (* 
  this gives distance between points on upper portion *)
  lowdist = 
   xint - ptForRdist; (*this gives distance between points on lower \
portion *)
  a = {};
  For[i = kinkptX; t = 0, i <= xint, i = i + lowdist, 
   AppendTo[a, xint - t]; t = t + lowdist];
  rKpt = Last[a];(*point to the right of the kink *)
  rLpt = Solve[
     EuclideanDistance[{rKpt, kLine[rKpt]}, {kinkptX, 
          kLine[kinkptX]}] + 
        EuclideanDistance[{kinkptX, kLine[kinkptX]}, {x, kLine[x]}] ==
        dist1 && 0 <= x < kinkptX, x][[1, 1, 2]];
  For[i = rLpt, i >= 0, i = i - highdist, AppendTo[a, i]];
  a
  ]

makePieces[4]

(note: the above needs to be modified to better deal with if solve encounters no solutions, since you can't take parts of {}

$\endgroup$
3
  • 1
    $\begingroup$ Can you explain your problem in more detail for those of us who are not versed in Oligopoly or where such a line is used? So you have two lines that have an intersection point. Per definition, a line is infinitely long, so what exactly do you want to break into equal segments? $\endgroup$
    – halirutan
    Feb 11, 2020 at 22:19
  • $\begingroup$ Possible duplicate: mathematica.stackexchange.com/a/57708/4999 $\endgroup$
    – Michael E2
    Feb 12, 2020 at 0:21
  • 1
    $\begingroup$ @halirutan I have a function defined on $(0,b)$ -- specifically a kinked line. I want to find points in the domain that break the function into $n-1$ equal-length segments. (Apologize for not being clear that I am considering only $(0,b)$ as the domain). I believe the existing answers are quite nice, so perhaps my response is too late to matter. Thank you for considering the question though. $\endgroup$
    – user106860
    Feb 12, 2020 at 7:01

2 Answers 2

7
$\begingroup$

Easy. This is the function of the arc length of the graph of kLine measured from the origin.

L[y_] = Integrate[Sqrt[1 + kLine'[x]^2], {x, 0, y}, Assumptions -> y > 0];

Now one can obtain the point y such that L[y] equals a desired length with FindRoot:

desiredlength = 8;
y0 = y /. FindRoot[L[y] == desiredlength, {y, 0, 10}, Method -> "Brent"];

Test for accuracy:

Abs[L[y0] - desiredlength]

0.

Here the full subdivision:

n = 12;
S = y /. FindRoot[L[y] == #, {y, -1, 12}, Method -> "Brent"] &;
t = S /@ Subdivide[0., L[10], n];

Show[
 Graphics[{PointSize[Medium], Red, Point[{#, kLine[#]} & /@ t]}],
 Plot[kLine[x], {x, 0, 10}]
 ]

enter image description here

$\endgroup$
4
  • $\begingroup$ I can't run the code right now, so it's likely that I'm just misunderstanding, but wouldn't this just give one point that is the desired distance away (as opposed to giving me $n$ points at distance desiredlength,)? (The reason it seems this way to me is that we are only measuring distance from the origin, and not between successive points?) $\endgroup$
    – user106860
    Feb 12, 2020 at 6:53
  • 1
    $\begingroup$ Of course you can apply the method to compute points of distance $h$, $2h$, $3h, \dotsc$ from the orgin. $\endgroup$ Feb 12, 2020 at 6:57
  • $\begingroup$ I see. Thank you for this nice solution. Any particular reason you did not use the ArcLength function and instead defined your own? $\endgroup$
    – user106860
    Feb 12, 2020 at 7:03
  • $\begingroup$ Any particular reason you did not use the ArcLength function and instead defined your own? No really. It just did not come to my mind (I used to think that ArcLength only works for mesh regions). Notice that I updated my post because I made a typo in the formula for the arc length (I forgot the derivative). $\endgroup$ Feb 12, 2020 at 7:13
5
$\begingroup$

You can also use the function LineScaledCoordinate (from the "GraphUtilities`" package) as follows:

Needs["GraphUtilities`"]

pnts = Table[{x, kLine[x]}, {x, 0, 10, 10^-3}];
n = 7;
coords = LineScaledCoordinate[pnts, N@#] & /@ Subdivide[n]

{{0, 18.75}, {1.78571, 17.8571}, {3.57143, 16.9643}, {5.35714, 16.0714}, {7.14286, 15.1786}, {8.21429, 13.5714}, {9.10714, 11.7857}, {10., 10.}}

To verify that coords divides the line into equal-length segments, construct Lines taking successive pairs and inserting the kink in the segment it belongs and check ArcLength of each segment:

kink = 7.5;
ArcLength /@ Line /@ (Replace[Partition[coords, 2, 1], 
   {p1 : {a_, _}, p2 : {b_, _}} /; a <= kink < b :> {p1, {kink, kLine@kink}, p2}, All])

{1.99649, 1.99649, 1.99649, 1.99649, 1.99649, 1.99649, 1.99649}

Show[ListPlot[List /@ coords, BaseStyle -> PointSize[Large], 
  PlotLegends -> Placed[{coords}, Right]], Plot[kLine[x], {x, 0, 10}],
  AspectRatio -> Full]

enter image description here

Update: An alternative approach extracting coordinates of mesh points from graphics output produced using options MeshFunctions and Mesh:

n = 7;
plt = Plot[ArcLength[{x, kLine[x]}, {x, 0, k}], {k, 0, 10}, 
  MeshFunctions -> {#2 &}, Mesh -> n - 1, 
  MeshStyle -> Directive[Red, PointSize[Large]], AspectRatio -> Full]

enter image description here

Get the x-coordinates of points and add the end points 0 and 10:

xcoords = Join[{0}, Cases[Normal @ plt, Point[x_] :> x[[1]], All], {10}];
coords2 = Sort[{#, kLine@#} & /@ xcoords ];

Chop[coords2 - coords, 10^-6]

{{0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0}}

Note: Incidentally, a more straightforward approach using ArcLength as the mesh function in Plot of kLine does not work: Somehow, Plot divides each piece of the piecewise function into n segments:

n = 7;
Plot[kLine[k], {k, 0, 10}, MeshFunctions -> {ArcLength}, 
 Mesh -> n - 1, MeshStyle -> Directive[Red, PointSize[Large]], 
 AspectRatio -> Full]

enter image description here

$\endgroup$
4
  • $\begingroup$ Nice solution. In looking at the computed ArcLength, most are exactly the same but one is an outlier at 1.93155. Why? I get the same answer when using EuclideanDistance between successive points, so it isn't just the ArcLength that shows a different value. $\endgroup$
    – Mark R
    Feb 12, 2020 at 1:07
  • $\begingroup$ @MarkR, it looks like the kink is causing a glitch somewhere; puzzling. $\endgroup$
    – kglr
    Feb 12, 2020 at 1:58
  • 1
    $\begingroup$ OK, the reason appears to be that if you follow the line to the kink and add the two segments, they do in fact add to the desired amount. That is, EuclideanDistance @@ {{7.14285714285074, 15.17857142857463}, {7.5, 15}} + EuclideanDistance @@ {{7.5, 15}, {8.21428571428055, 13.5714285714389}} yields 1.99649 just as the others. $\endgroup$
    – Mark R
    Feb 12, 2020 at 2:23
  • $\begingroup$ @MarkR, thank you for the pointer. I updated with the fix you suggested. $\endgroup$
    – kglr
    Feb 12, 2020 at 4:34

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.