Skip to main content

numerical integration - Find lengths of contours in a ContourPlot


I am trying to find the lengths of different contours in the following plot:


ContourPlot of interest!!


It is a complicated piecewise function evaluated on the unit disk. I am hoping there is an easy, generalized way to numerically approximate each of the contours' lengths.



Essentially, I am looking for a way to solve for the length of a homogenous equation bound by a region. Given a function f(x,y) - f* == 0 on a region R, where f* is the value of the contour of interest, is there a way to find the length of the curve that satisfies that equation?


For concreteness, the above is the ContourPlot of


q[r_] := Piecewise[{{25/(0.1*1), r < 0.1}, {25/r, r >= 0.1}}]
phi[r_, t_] := (Pi/2) + q[r]*t
v[r_, t_] := q[r]*r*Cos[phi[r, t]]
s[x_] := Piecewise[{{x = -1, x < 0}, {x = 1, x >= 0}}]

f[x_,y_] := s[x]*v[Sqrt[x^2 + y^2],ArcTan[y/x]/q[Sqrt[x^2 + y^2]]]

How does one numerically find the lengths of each of those contours?




Answer



How about


pl = ContourPlot[f[x, y], {x, -1, 1}, {y, -1, 1}, 
RegionFunction -> Function[{x, y}, x^2 + y^2 < 1], PlotPoints -> 25,ContourShading -> False]

Mathematica graphics


Then


lines = Cases[pl // Normal, Line[pts_] :> List[pts], Infinity];
lines = Select[lines, Length[#[[1]]] > 20 &];
lines = Map[Flatten[Transpose[#], 1] &, lines];


Picking up the first segment;


 l1 = lines[[1]]; ListLinePlot[l1]

Mathematica graphics


So that the Length is just


 pts = (l1 - RotateLeft[l1] // Most);
Total@ Map[Norm, pts]

(* 1.91 *)



If you want all lengths, then loop


  Table[l1 = lines[[i]];pts = (l1 - RotateLeft[l1] // Most);Total@ Map[Norm, pts],
{i, Length[lines] - 1}]

(* {1.91801,1.9595,1.98317,1.99609,1.9987,1.99605,1.9832,1.95951,1.91821} *)


Comments