So I'm building this software that designs mechanisms to follow a specific curve. I'm inspired by the work done by Disney https://youtu.be/DfznnKUwywQ?t=38s

Here's what I've done so far:

  • I've done the modelling of the mechanism and tracing the curve resulting from the specific dimensions: Coupler Curve animation
  • I've tried to write my own implementation of genetic algorithm to optimize the error between 6 points {x,y} on the curve and 6 design points but I'm getting really bad results.

My Question:

  • Is it possible to take input from the user by drawing a curve like the Disney software allows the user to?
  • If it's possible, What kind of optimization can I use? The drawn curve is a list of 360 {x,y} points.

Here's my code if you want to give it a try:

crankRockerSolver[rcx_, rcy_, r1_, r4_, r3_, r2_] = (* 
  r1 is the crank; r2 is the coupler; r3 is the rocker; 
  r4 is the link between oA and oB; 
  This is a pure function that returns expressions with an empty slot \
in the place of the input angle which is passed to it later; 
  This function calculates the output angle of the rocker.*)
  {a1 = 
     N[Sin[# Degree]],
    b1 = N[r4/r1 - Cos[# Degree]],
    c1 = N[-r4/r3 Cos[# Degree] + 
       N[(r1^2 - r2^2 + r3^2 + r4^2)/(2 r1 r2)]],
    \[Psi] = 
     180 - ( 2 ArcTan[
          N[(a1 + \[Sqrt](a1^2 + b1^2 - c1^2))/(b1 + c1)]]/ 
         Degree),(*Output Angle Calculated by Equation from the \

    a = N[AngleVector[{r1, # Degree}]],(*point A Starting from origin*)

        b = N[
        0}, {r3, \[Psi]  Degree}]],(*Point B Starting from Ob*)

    ob = N[AngleVector[{r4, 0}]],(*Point oB*) (*#7*) 
    v = b - a,(*this is the vector of the coupler link. 
    The coupler link closes the triangle between a2 and b2. 
    mathematica deals with vectors are geometrical vectors from the \
origin. in order to get the vector from a to b, 
    the vectors a2 and b2 has to be included in one equation to be \
solved namely a2+coupler=b2*)

     3] = (VectorAngle[{1, 0}, v]/
       Degree),(*this is the Subscript[\[Theta], 3]
    angle from the diagram. The angle between the coupler and x-axis*)

        Subscript[c, x] = 
     N[r1 Cos[# Degree] + rcx Cos[Subscript[\[Theta], 3] Degree] - 
       rcy Sin[Subscript[\[Theta], 3] Degree]],
    Subscript[c, y] = 
     N[r1 Sin[# Degree] + rcx Sin[Subscript[\[Theta], 3] Degree] + 
       rcy Cos[Subscript[\[Theta], 3] Degree]],
    c = {Subscript[c, x], Subscript[c, 
      y]} (*C is the coupler floating link. This co-
    ordinates of this point is to be calculated from the two \
equations above. The equations come form the refrences.*)
    } &;

currentConfing = 
  crankRockerSolver[11.424901483235672`, 15.082872962462773`, 
   21.718791706141616`, 35.80178707917261`, 36.90228323939509`, 

rockerPath = 
    currentConfing[t][[6]], {t, 0, 360, 
     1}];(*This using Table function to get an array of the \
coordinates of one point, rocker tip, at different values of \
currentConfig function then draw a line from it in graphics*)

couplerCurve = 
    currentConfing[t][[12]], {t, 0, 360, 
     1}];(*Same concept yet this traces the cooupler curve*)

{Slider[Dynamic[t], {0, 360, 1}], Dynamic[t]} 

Dynamic[ (*This is the drawing of the four bar linkage*)
   {Blue, Dashed, rockerPath},(* 
   the path of the rocker tip*)
   {Blue, Dashed, 
    couplerCurve}, (*The path of C, the coupler curve*)

   Line[{{0, 0}, currentConfing[t][[5]], currentConfing[t][[6]], 
     currentConfing[t][[7]], {0, 0}}],(*The drawing of the 4 linkages*)

      12]]}],(*The drawing of one side of the coupler from a to c*)

      12]]}],(*The drawing from the other side of the coupler from b \
to c*)
   Locator@{0.9206, 6.37}, Locator@{0.605, 6.29}, 
   Locator@{0.427, 6.23}, Locator@{0.163, 6.11}, 
   Locator@{-0.0501, 5.988}, Locator@{-0.256, 5.84},
   }, Axes -> True, PlotRange -> Automatic, Ticks -> Automatic]
  • $\begingroup$ Please post code as text as well. $\endgroup$
    – Yves Klett
    Aug 4, 2016 at 18:13
  • $\begingroup$ Done.... You can copy it and give it a try... $\endgroup$ Aug 4, 2016 at 18:26
  • $\begingroup$ Something like: 39273? $\endgroup$
    – Kuba
    Aug 4, 2016 at 19:51

1 Answer 1


As for the curve drawing it looks in the video like they are fitting a spline to the points provided by the user. In Mathematica it can be done like this:

pt1 = {0, 0};
pt2 = {1, 0};
pt3 = {1, 1};
pt4 = {0, 1};

 Dynamic[{pt1, pt2, pt3, pt4}],
   Dynamic@BSplineCurve[{pt1, pt2, pt3, pt4}, SplineClosed -> True]
   }, PlotRange -> 2]

Mathematica graphics

NMinimize should be able to optimize the setup. To demonstrate this I will find the points that are needed to recreate the spline, only knowing some points on the curve.

The cost function I will try to optimize is

cost[bspline1_, bspline2_] := Total@Table[Norm[bspline1[i] - bspline2[i]]^2, {i, 0, 1, 0.01}]

Minimization code:

sol = NArgMin[Hold@cost[
     BSplineFunction[{pt1, pt2, pt3, pt4}, SplineClosed -> True],
     BSplineFunction[{{x1, x2}, {x3, x4}, {x5, x6}, {x7, x8}}, SplineClosed -> True]
     ], {x1, x2, x3, x4, x5, x6, x7, x8}];

This works very well, although it would be nice if it were faster:

  BSplineCurve[{pt1, pt2, pt3, pt4}, SplineClosed -> True],
  Red, BSplineCurve[Partition[sol, 2], SplineClosed -> True],
  PointSize[Large], Point[Partition[sol, 2]]
  }, PlotRange -> 2]

Mathematica graphics

In this image the red points were found by the NArgMin without knowing the positions of the original points. In your case you can similarly compare the path of your mechanism with the spline, and optimize the parameters of your model using NArgMin to minimize your version of the given cost function.

  • 1
    $\begingroup$ Brilliant! I've tried your code and it works but I'm still studying it. I'll come back with some questions later. :) $\endgroup$ Aug 5, 2016 at 11:36

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.