Whitworth's Quick Return Mechanism

({{, ●ground
●crank
●drivearm
●peg
●conrod
●slider}})

Initialization

Load the LinkageDesigner package

<< LinkageDesigner`

Load the Shapes package

<< Graphics`Shapes`

Load the MultipleListPlot package

<< Graphics`MultipleListPlot`

The reference of this function is found http://support.wolfram.com/Graphics/Axes/TwoAxisGraph.html

\(TwoAxisListPlot[f_List, g_List, \((opts___)\)?OptionQ] := 
      Block[{old, new, sc, gmax, gmin, funcmax, funcmin, ng}, 
        gmax = Max[\(Transpose[g]\)[\([2]\)]]; \ 
        gmin = Min[\(Transpose[g]\)[\([2]\)]]; 

        funcmax = Max[\(Transpose[f]\)[\([2]\)]]; 

        funcmin = Min[\(Transpose[f]\)[\([2]\)]]; 

        sc = \((\((#1 - gmin)\)*\((funcmax - funcmin)\))\)/\((gmax - 
                  gmin)\) &; 

        old = \(FullOptions[
              ListPlot[g, Frame -> True, 
                DisplayFunction -> Identity], FrameTicks]\)[\([2]\)]; 

        new = \((Prepend[Rest[#1], sc[First[#1]]] &)\) /@ old; 

        ng = Transpose[{\(Transpose[g]\)[\([1]\)], 
              Map[sc, \(Transpose[g]\)[\([2]\)], {1, 2}]}]; 

        MultipleListPlot[f, ng, Frame -> True, 
          FrameTicks -> {Automatic, Automatic, None, new}, 
          SymbolStyle -> {{RGBColor[1, 0, 0]}, {RGBColor[0, 0, 1]}}, 
          FrameStyle -> {{}, {RGBColor[1, 0, 0]}, {}, {RGBColor[0, 0, 
                  1]}}, opts]]\)

Definition

Create the  LinkageData object and assign it to quickReturn variable

quickReturn = 
      CreateLinkage["quickReturn", WorkbenchName -> "ground", 
        GroundName -> "reference", 
        SimpleParameters -> {d1 -> 5, lcrank -> 3, 
            ldrivearm -> 9, lconrod -> 5, 
            d2 -> 10}]

Define a rotational joint between ground and crank (using d1 parameter)

\(DefineKinematicPairTo[
quickReturn, 
"Rotational", 
{θ1}, 
{"ground", 
        MakeHomogenousMatrix[{0, d1, 0}]}, 
{"crank", 
        MakeHomogenousMatrix[{0, 0, 0}]}
]\)

Assign geometry to "crank"

\(\(quickReturn[\([$LDLinkGeometry, "crank"]\)] = 
        PlaceShape[

          Graphics3D[{SurfaceColor[RGBColor[1, 1, 0]], 

              LinkShape[lcrank,  .5,  .5,  .2]}], 

          MakeHomogenousMatrix[{0, 0, \(- .7\)}]];\)\)

Define a rotational joint between ground and drivearm

\(DefineKinematicPairTo[
quickReturn, 
"Rotational", 
{q2}, 
{"ground", 
        MakeHomogenousMatrix[{0, 0, 0}]}, 
{"drivearm", 
        MakeHomogenousMatrix[{0, 0, 0}]}
]\)

Assign geometry to "drivearm"

quickReturn[[$LDLinkGeometry, "drivearm"]] = 
        Graphics3D[{SurfaceColor[RGBColor[0,  .5, 1]], 
            LinkShape[ldrivearm,  .3,  .3,  .2]}];

Define a rotational joint between crank and peg ( using lcrank parameter)

\(DefineKinematicPairTo[
quickReturn, 
"Rotational", 
{q3}, 
{"crank", 
        MakeHomogenousMatrix[{lcrank, 0, 0}]}, 
{"peg", 
        MakeHomogenousMatrix[{0, 0, 0}]}
]\)

Assign geometry to "peg"

quickReturn[["$LinkGeometry", "peg"]] = 
        PlaceShape[
          Graphics3D[{SurfaceColor[RGBColor[1, 0, 1]], Cylinder[0.6,  .5]}], 
          MakeHomogenousMatrix[{0, 0, 0}, {1, 0, 0}]];

In case of loop closing kinematic pair definition it is advisable to move the mechanism close to to constrained posture. This way the numerical root finding procedure- that is applied when the generated constraint equations are  solved - resolves the constraint equations more easily.

Move the mechanism with SetDrivingVariablesTo and render the joint markers of the loop-closing kinematic pair

\(Show[
      Linkage3D[
        SetDrivingVariablesTo[
          quickReturn, {θ1\  -> \ 1.2, \ q2\  -> \ 1.2, \ 
            q3\  -> \  .2}, 
MaxIterations -> 
            150, 
AccuracyGoal -> 
            8], 
\ \ MarkerSize -> 
          3, 
\ \ Axes -> 
          True, 
\ \ LinkMarkers -> {
\ {"peg", 
              MakeHomogenousMatrix[{0, 0, 0}, {1, 0, 
                  0}]}, 
{"drivearm", 
              MakeHomogenousMatrix[{8, 0, 0}, {1, 0, 
                  0}]}
}
]]\)

Define a translational joint between peg and DriveArm (set Verbose option to True to see the messages of the automatic constraint equation generation)

\(DefineKinematicPairTo[
quickReturn, 
"Translational", 
{q4}, 
{"peg", 
        MakeHomogenousMatrix[{0, 0, 0}, {1, 0, 
            0}]}, 
{"drivearm", 
        MakeHomogenousMatrix[{ldrivearm, 0, 0}, {1, 0, 
            0}]}, 
Verbose -> 
        True
]\)

Define a rotational joint between drivearm and conrod

\(DefineKinematicPairTo[
quickReturn, 
"Rotational", 
{q5}, 
{"drivearm", 
        MakeHomogenousMatrix[{ldrivearm, 0, 
            0}]}, 
{"conrod", 
        MakeHomogenousMatrix[{0, 0, 0}]}
]\)

Assign geometry to "conrod"

quickReturn[["$LinkGeometry", "conrod"]] = 
        Graphics3D[{RGBColor[1, 0, 1], Thickness[0.01], 
            LinkShape[lconrod,  .3,  .3,  .2]}];

Define a rotational joint between ConrRod and Slider

\(DefineKinematicPairTo[
quickReturn, 
"Rotational", 
{q6}, 
{"conrod", 
        MakeHomogenousMatrix[{lconrod, 0, 
            0}]}, 
{"slider", 
        MakeHomogenousMatrix[{0, 0, 0}]}, 
      Parameters -> {lconrod -> 5}
]\)

Assign geometry to "slider"

quickReturn[["$LinkGeometry", "slider"]] = 
        Graphics3D[{SurfaceColor[RGBColor[1, 0, 0]], 
            Cuboid[{-2, -1, - .2}, {2, 
                1, - .3}]}];

Move the mechanism with SetDrivingVariablesTo and render the joint markers of the next loop-closing kinematic pair

\(Show[
Linkage3D[
        SetDrivingVariablesTo[
          quickReturn, {θ1\  -> \ 1. , \ q5\  -> \(- .5\), \ 
            q6\  -> \(-1\)}], 
MarkerSize -> 
          3, 
Axes -> 
          True, 
PlotRange -> 
          All, 
LinkMarkers -> {
{"ground", 
              MakeHomogenousMatrix[{10, 10, 0}, {1, 0, 
                  0}]}, 
{"slider", 
              MakeHomogenousMatrix[{0, 0, 0}, {1, 0, 
                  0}]}
}
]]\)

Define a translational joint between slider and ground

\(DefineKinematicPairTo[
quickReturn, 
"Translational", 
{q7}, 
{"ground", 
        MakeHomogenousMatrix[{10, d2, 0}, {1, 0, 
            0}]}, 
{"slider", 
        MakeHomogenousMatrix[{0, 0, 0}, {1, 0, 0}]}, 
      Parameters -> {d2 -> 10}, 
      Verbose -> True
]\)

Show the kinematic graph of the linkage

ShowLinkageGraph[quickReturn, 
      IncludeClosingConstraints -> True]

Place the mechanism to the origin

PlaceLinkageTo[quickReturn]

Set the driving variable of the mechanism to 0

SetDrivingVariablesTo[quickReturn, {θ1  ->  0.0}, 
      MaxIterations -> 150]

Rendering & Animations

Render the quick return mechanism

Show[Linkage3D[quickReturn, LinkMarkers -> All, MarkerSize -> 2], 
      ViewPoint -> {0, 0, 5}, Boxed -> False, Axes -> True, 
      FaceGrids -> {{0, 0, -1}}]

Set simple parameters to the default values

SetSimpleParametersTo[
      quickReturn, {d1 -> 5, lcrank -> 3, ldrivearm -> 9, 
        lconrod -> 5, d2 -> 10}, MaxIterations -> 150, 
      AccuracyGoal -> 6]

Animate linkage

AnimateLinkage[
        quickReturn, {{θ1  ->  0.0}, {θ1  ->  2  π}}, 
        Resolution -> 15, MaxIterations -> 1500, LinkMarkers -> All, 
        MarkerSize -> 1, ViewPoint -> {0, 0, 5}, 
        PlotRange -> {{-10, 15}, {-1, 13}, {-3,  .1}}, 
        Boxed -> False, Axes -> True, AccuracyGoal -> 6, 
        FaceGrids -> {{0, 0, -1}}];

Change the simple parameters and copy the resulted mechanism to quickReturn1

quickReturn1 = 
      SetSimpleParameters[
        quickReturn, {lcrank  ->  4,  d2  ->  8, ldrivearm -> 10}, 
        MaxIterations -> 150]

Animate the new linkage

AnimateLinkage[
        quickReturn1, {{θ1  ->  0.0}, {θ1  ->  2  π}}, 
        Resolution -> 15, MaxIterations -> 1500, LinkMarkers -> All, 
        MarkerSize -> 1, ViewPoint -> {0, 0, 5}, 
        PlotRange -> {{-10, 15}, {-1, 13}, {-3,  .1}}, 
        Boxed -> False, Axes -> True, AccuracyGoal -> 6, 
        FaceGrids -> {{0, 0, -1}}];

Export the animation in óto VRML file

fName = 
      WriteVRMLAnimation[
        quickReturn, {{θ1  ->  0. }, {θ1  ->  6.28}}, 
        Resolution -> 35, MaxIterations -> 150, LinkMarkers -> All, 
        MarkerSize -> 1, Boxed -> False, Axes -> True, 
        AccuracyGoal -> 6, FaceGrids -> {{0, 0, -1}}, 
        VRMLCycleTime -> 2]

Kinematic Analysis

The quick-return mechanism has one degree of freedom, because it has only one driving variable. In order to calculate the correct velocity and acceleration function the driving variable should be replaced by the time. The old driving variable θ1 then has to be expressed as the function of the time.

Replace driving variables

quickReturnT1 = 
      ToTimeDependentLinkage[
        ReplaceDrivingVariables[
          quickReturn, {t -> 0}, {θ1 -> ω*t}, 
          SimpleParameters -> {ω -> 2  π}], 
        t]

Calculate the position of the slider

sliderPos = 
      Simplify[ExtractTranslationVector[
          GetLLRFMatrix[quickReturnT1, "slider"]]]

Calculate the velocity of the slider

sliderVelo = 
      GetLinkageDerivative[quickReturnT1, "slider", 1]

Calculate the acceleration of the slider

sliderAcc = 
        GetLinkageDerivative[quickReturnT1, "slider", 2];

Calculate the subtitution values of quickReturnT linkage, when t goes from 0 to 1

\(Timing[
\(sub = 
          GetLinkageRules[
            quickReturnT1, {{t -> 0. }, {t -> 
                  1}}, 
AccuracyGoal -> 6, 

            Resolution -> 100, 

            MaxIterations -> 50];\)]\)

Animate the quick-return mechanism

AnimateLinkage[quickReturnT1, Partition[sub, 10][[All, 1]], 
        Resolution -> None, 
        PlotRange -> {{-7, 12}, {-1, 12}, {-1, 2}}, 
        ViewPoint -> {0, 0, 50}, Axes -> {True, True, False}, 
        FaceGrids -> {{0, 0, -1}}];

\(pl0 = 
      ListPlot[{t, sliderPos[\([1]\)]} /. sub, PlotJoined -> True, 
        PlotStyle -> {Thickness[0.01]}, 
        FrameLabel -> {"t", \ \*""\!\(pos\_x\)""}, 
        Frame -> True, GridLines -> Automatic]\)

Plot the x coordinate of the slider's velocity

\(pl1 = 
      ListPlot[{t, 
            sliderVelo[[1, 
              1]]} /. sub, 
        PlotJoined -> True, 
        PlotStyle -> {Thickness[0.01], RGBColor[1, 0, 0]}, 
        FrameLabel -> {"t", \ \*""\!\(vel\_x\)""}, 
        Frame -> True, GridLines -> Automatic]\)

Plot the x coordinate of the slider's acceleration

\(pl2 = 
      ListPlot[{t, sliderAcc[\([1, 1]\)]} /. sub, 
	
        PlotJoined -> True, 
	
        PlotStyle -> {Thickness[0.01], 
            RGBColor[0, \ 0.738293, \ 0]}, 
	
        FrameLabel -> {"t", \ \*""\!\(acc\_x\)""}, 
        Frame -> True, GridLines -> Automatic, 
        PlotRange -> All]\)

Plot the x coordinate of the slider's position and velocity and accelerationtogether

Show[pl0, pl1, pl2, PlotRange -> {-50, 50}]

The y component of the slider's position should be constant along the simulation, since the slider is restricted to slide along the x axis. This implies that the y component of the slider velocity is equal to zero. If we plot the y velocity component we can se that there is some error in the computation. This error is resulted from the fact, that the constraint equations are solved for certain digit of precision. The higher the precison used in the calculation the smaller error resulted in the velocity functions.

Plot the y component of the slider's velocity

\(err1 = 
      ListPlot[{t, sliderVelo[\([1, 2]\)]} /. sub, 
	
        PlotJoined -> True, 
	
        PlotStyle -> {Thickness[0.01], 
            RGBColor[1, 0, 0]}, 
	
        FrameLabel -> {"t", \ \*""\!\(vel\_y\)""}, 
        Frame -> True, GridLines -> Automatic]\)

Plotting Two-axes graph

Plot the position and velocity together

\(TwoAxisListPlot[{t, sliderVelo[\([1, 1]\)]} /. 
        sub, {t, sliderPos[\([1]\)]} /. sub, ImageSize -> {500, 350}, 
      TextStyle -> {FontFamily -> "Times", 
          FontSize -> 14}, 

      FrameLabel -> {"t", "velocity", "", "position"}, 

      PlotLabel -> "Position and velocity plot of the slider link", 
GridLines -> Automatic, 
PlotJoined -> True]\)