Search code examples
wolfram-mathematicacurve

Catenary with Manipulate


I would like to represent a Catenary-curve in Mathematica, and then allow the user to Manipulate each of the parameters, like the Hanging-Points' position (A,B), the cable's weight, the force of gravity etc.?


Solution

  • I would do it like this:

    First, define the catenary:

    catenary[x_] := a*Cosh[(x - c)/a] + y
    

    Now I can either find the parameters a, c and y of this curve numerically, using FindRoot:

    Manipulate[
     Module[{root},
      (
       root = FindRoot[
                 {
                    catenary[x1] == y1, 
                    catenary[x2] == y2
                 } /. {x1 -> pt[[1, 1]], y1 -> pt[[1, 2]], x2 -> pt[[2, 1]], y2 -> pt[[2, 2]], a -> \[Alpha]}, 
                 {{y, 0}, {c, 0}}];
       Show[
        Plot[catenary[x] /. root /. a -> \[Alpha], {x, -2, 2}, 
         PlotRange -> {-3, 3}, AspectRatio -> 3/2],
        Graphics[{Red, Point[pt]}]]
       )], {{\[Alpha], 1}, 0.001, 10}, {{pt, {{-1, 1}, {1, 1}}}, Locator}]
    

    Alternatively, you could solve for the parameters exactly:

    solution = Simplify[Solve[{catenary[x1] == y1, catenary[x2] == y2}, {y, c}]]
    

    and then use this solution in the Manipulate:

    Manipulate[
     (
      s = (solution /. {x1 -> pt[[1, 1]], y1 -> pt[[1, 2]], 
          x2 -> pt[[2, 1]], y2 -> pt[[2, 2]], a -> \[Alpha]});
      s = Select[s, 
        Im[c /. #] == 0 && 
          Abs[pt[[1, 2]] - catenary[pt[[1, 1]]] /. # /. a -> \[Alpha]] < 
           10^-3 &];
      Show[
       Plot[catenary[x] /. s /. a -> \[Alpha], {x, -2, 2}, 
        PlotRange -> {-3, 3}, AspectRatio -> 3/2],
       Graphics[{Red, Point[pt]}]]
      ), {{\[Alpha], 1}, 0.001, 10}, {{pt, {{-1., 1.}, {1., 0.5}}}, 
      Locator}]
    

    The FindRoot version is faster and more stable, though. Result looks like this:

    enter image description here

    For completeness' sake: It's also possible to find a catenary through 3 points:

    m = Manipulate[
      Module[{root},
       (
        root = 
         FindRoot[
          catenary[#[[1]]] == #[[2]] & /@ pt, {{y, 0}, {c, 0}, {a, 1}}];
        Show[
         Plot[catenary[x] /. root, {x, -2, 2}, PlotRange -> {-3, 3}, 
          AspectRatio -> 3/2],
         Graphics[{Red, Point[pt]}]]
        )], {{pt, {{-1, 1}, {1, 1}, {0, 0}}}, Locator}]
    

    enter image description here