Skip to main content

list manipulation - How do I split up a curve into chords of equal length?


I have a curve that is defined as f[x] and what I'm attempting to do is to divide the curve into equal straight lengths for a number of segments of my choosing that I've defined as nSeg.



I've created a sheet that can work through and determine the (x,y) co-ordinates for each segment, but I'm having to manually manipulate the equations to create a single equation for Mathematica to find the roots for.


The straight length of the curve I've defined as;


chordL = Table[
Sqrt[(Subscript[x, i + 1] - Subscript[x,i])^2 +
(f[Subscript[x, i + 1]] - f[Subscript[x, i]])^2
], {i, 1, nSeg}
]

This creates a list of equations for the length of each segment. What I would like to do is make each part of the list equal to each other so that I can feed this into FindRoot later in the sheet so that if I decide to change the number of segments from 8 to 10, the sheet can be refreshed from a single variable.


FindRoot[*combined equations*, {Subscript[x, 2], 1}, {Subscript[x, 3], 2}]


The above is an example of how I'm currently doing it and it means I've a sheet for each value of nSeg, which isn't a smart way to work and I'm manually defining which variables to solve independently of the value of nSeg, even though the first and last co-ordinate will always be known.


I'm quite new to Mathematica and would really appreciate a nudge in the right direction to combine the equations in the first part to give the equations to solve in FindRoot (which I'm using instead of Solve for speed) in a flexible manner, and also increment the number of variables to solve given that x1 will always be 0 and x(nSeg+1) will always be known too as these are the start and end points of the curve which are defined by the input at the beginning of the sheet.



Answer




I'll assume you want to fix the first and last point and then plot the segments. Quick and dirty approach (I'll fix the first point at $x=0$ and the last at x=upVal; also note that actually nSeg isn't the number of segments here, but never mind):


upVal = 6;
nSeg = 10;
chordL = Table[
Sqrt[(x[i + 1] - x[i])^2 + (f[x[i + 1]] - f[x[i]])^2], {i, 1,

nSeg}];
combEqs = # == d & /@ chordL;

That is, I set the length of all the segments to $d$, for which I will solve. Here's how to define the list of vars (with initial conditions, which are arbitrarily chosen here):


ClearAll[vars, x];
vars = Append[{x[#], #, x[1]+10^-6, upVal-10^-6} & /@ Range[2, nSeg],{d, 1}]

you can see I am adding $d$, the segment length, as a variable to solve for. Let's try for $f(x)=\sin(x)$:


f[x_] := Sin[x];
x[1] = 0;

x[nSeg + 1] = upVal;
sol = FindRoot[combEqs, vars];


points = Table[{{x[i], f[x[i]]}, {x[i + 1], f[x[i + 1]]}}, {i, 1,
nSeg}];

Show[
Plot[f[x], {x, x[1], 1.1 x[nSeg + 1]}],
Graphics@Line[points /. sol],

Graphics[{Red, PointSize[Large], Point[Flatten[points, 1] /. sol]}]
]

Mathematica graphics


So it seems to work.



If I just want to split up the curve in segments of equal length along the curve, I could do it like this:


ClearAll[findx, length];
findx[ell_, f_] := x /. FindRoot[length[x, f] \[Equal] ell, {x, 1}]
length[xf_?NumericQ, f_] := NIntegrate[Sqrt[1 + f'[z]^2], {z, 0, xf}]


Here, length gives the length of a curve f[x] from x=0 to x=xf, and findx uses that to obtain the coordinate x at which the length from x=0 to x=xf is ell. Then, we find the total length, split it into equal pieces $\delta L$, and use findx to obtain the values $x_n$ at which the length from the starting point is $n\delta L$:


nsegs = 10;
f[x_] := Cos[x^2]
xup = 2;
totalLength = length[xup, f];
dL = totalLength/nsegs;
xvals = Table[findx[n*dL, f], {n, 0, nsegs}];
Show[
Plot[f[x], {x, 0, xup}],

Graphics[{Red, PointSize[Large],
Point[Transpose[{xvals, f /@ xvals}]]}]
]

And here is the result:


Mathematica graphics


Well, unless I messed it up.


Comments

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],