Project Help Notebook by Keith Stroyan

Help NoteBook Copyright 1998 by Academic Press, Inc. - All rights reserved.
Modify this Notebook to prepare your project report.

Project 11: The Tractrix

Initialization

Needs["Graphics`Colors`"];

by A. Student and B. Pupil

with technical help from Da LabMonitor and Help Notebook

Slipping Through the Mud

Write this last.  Begin with the basic question and state your main finding clearly, but with few technical details.  You might even modify the title of this section to make it more interesting.

Beginning Explorations or Computer Experiments

The derivation of the equation of the tractrix is primarily a paper and pencil project.  Read the print project.  However, once you have done this, the computer can help as follows.

Exact Solution

The equation for the tractrix can be solved implicitly using the hints i the printed project.  This gives you a formula for  x  in terms of  y.  Can you solve that formula for  y?  Here's Mathematica's attempt at an exact solution:

Clear[x, y, k];
DSolve[{y'[x]==-y[x]/(Sqrt[(k^2) - y[x]^2]),y[0] == k},y[x],x]

Numerical Solution

Since Mathematica cannot find  y = y[x]  exactly, we use a numerical solution to animate dragging your book through the mud as follows.

Clear[x, y, k];k = 1;
xFinal = 2;soln=NDSolve[{y[0] ==  .99 k,y'[x]==-y[x]/(Sqrt[(k^2) - y[x]^2])},y[x],{x, 0, xFinal}];y[x_] = y[x] /. soln[[1]];
h[x_] = (Sqrt[(k^2) - y[x]^2]);
furrow[ξ_] := 
        Plot[y[x], {x, 0, ξ}, AxesLabel -> {"x", "y"}, 
          PlotRange -> {0, 1}, 
          PlotStyle -> {AbsoluteThickness[2], Brown}, 
          DisplayFunction -> Identity];book[ξ_] := 
        Graphics[{Red, {AbsolutePointSize[7], Point[{ξ, y[ξ]}]}}];
rope[ξ_] := 
        Graphics[{Blue, AbsoluteThickness[3], 
            Line[{{ξ, y[ξ]}, {ξ + h[ξ], 0}}]}];
tractor[ξ_] := 
        Graphics[{
            Purple, {AbsolutePointSize[6], Point[{ξ + h[ξ], 0}]}}];
label[ξ_] :=  
        Graphics[{Text["y[x]", {ξ -  .15, y[ξ]/2}], 
            Text["h[x]", {ξ + h[ξ]/2, - .05}], {SteelBlue, 
              Line[{{ξ, y[ξ]}, {ξ, 0}, {ξ + h[ξ], 0}}]}}]
          \(Do[

      \(Show[furrow[ξ], book[ξ], rope[ξ], tractor[ξ], 
          label[ξ], PlotRange -> {{\(- .2\), xFinal + k}, {\(- .2\), k}}, 
          Ticks -> None, DisplayFunction -> $DisplayFunction];\)

      	, {ξ,  .1, xFinal,  .2}]; \)