3 replaced http://mathematica.stackexchange.com/ with https://mathematica.stackexchange.com/
source | link

After writing up the code for this answer, some searching around shows that a similar strategy for generating surfaces of revolution has been done by Yu-Sung ChangYu-Sung Chang in this Wolfram Demonstration.

After writing up the code for this answer, some searching around shows that a similar strategy for generating surfaces of revolution has been done by Yu-Sung Chang in this Wolfram Demonstration.

After writing up the code for this answer, some searching around shows that a similar strategy for generating surfaces of revolution has been done by Yu-Sung Chang in this Wolfram Demonstration.

2 a missing close bracket is added
source | link
m = 3; (* degree of the B-spline *)
(* knots for interpolating B-spline *)
knots = Join[ConstantArray[0, m + 1], MovingAverage[ArrayPad[tvals, -1], m],
             ConstantArray[1, m + 1];1]];
(* basis function matrix *)
bas = Table[BSplineBasis[{m, knots}, j - 1, tvals[[i]]],
            {i, Length[wineGlassPoints]}, {j, Length[wineGlassPoints]}];
ctrlpts = LinearSolve[bas, wineGlassPoints];
m = 3; (* degree of the B-spline *)
(* knots for interpolating B-spline *)
knots = Join[ConstantArray[0, m + 1], MovingAverage[ArrayPad[tvals, -1], m],
             ConstantArray[1, m + 1];
(* basis function matrix *)
bas = Table[BSplineBasis[{m, knots}, j - 1, tvals[[i]]],
            {i, Length[wineGlassPoints]}, {j, Length[wineGlassPoints]}];
ctrlpts = LinearSolve[bas, wineGlassPoints];
m = 3; (* degree of the B-spline *)
(* knots for interpolating B-spline *)
knots = Join[ConstantArray[0, m + 1], MovingAverage[ArrayPad[tvals, -1], m],
             ConstantArray[1, m + 1]];
(* basis function matrix *)
bas = Table[BSplineBasis[{m, knots}, j - 1, tvals[[i]]],
            {i, Length[wineGlassPoints]}, {j, Length[wineGlassPoints]}];
ctrlpts = LinearSolve[bas, wineGlassPoints];
    Bounty Ended with 100 reputation awarded by Community
1
source | link

A different (but related) possibility from my previous answer is to use B-splines for rendering both the outline and the corresponding surface of revolution. The strategy that follows is adapted from The NURBS Book by Piegl and Tiller.

First, we build the B-spline corresponding to the outline. Here again are the points for the wine glass contour:

wineGlassPoints = {{32.75, 283.75}, {37.75, 275.75}, {43.25, 267.25}, {49.25, 256.75},
                   {53.75, 247.75}, {58.25, 236.25}, {61.75, 224.25}, {64.25, 211.75},
                   {65.25, 198.75}, {64.25, 185.75}, {61.75, 174.25}, {58.25, 165.75},
                   {53.25, 157.25}, {46.25, 149.25}, {38.75, 143.75}, {30.25, 139.75},
                   {23.25, 137.25}, {17.75, 135.25}, {13.75, 134.75}, {13.75, 128.75},
                   {10.25, 126.75}, {7.25, 122.25}, {5.75, 115.75}, {4.75, 109.25},
                   {4.25, 101.25}, {3.75, 88.25}, {3.75, 70.25}, {3.75, 53.75},
                   {4.75, 39.75}, {6.75, 25.75}, {8.25, 20.25}, {11.25, 16.75},
                   {17.25, 14.25}, {25.25, 11.25}, {33.75, 9.25}, {41.25, 7.75},
                   {48.25, 5.75}, {48.75, 0.25}};

We will use, again, Eugene Lee's centripetal parametrization scheme to generate corresponding parameter values:

parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
 FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /; MatrixQ[pts, NumericQ]

tvals = parametrizeCurve[wineGlassPoints];

At this point, we do things a bit differently from my previous answer. One thing about B-splines is that they need the control points, as opposed to the interpolation points. We thus have to generate the control points for the (cubic) B-spline that passes through wineGlassPoints. To do that, we use a procedure suggested by Piegl and Tiller:

m = 3; (* degree of the B-spline *)
(* knots for interpolating B-spline *)
knots = Join[ConstantArray[0, m + 1], MovingAverage[ArrayPad[tvals, -1], m],
             ConstantArray[1, m + 1];
(* basis function matrix *)
bas = Table[BSplineBasis[{m, knots}, j - 1, tvals[[i]]],
            {i, Length[wineGlassPoints]}, {j, Length[wineGlassPoints]}];
ctrlpts = LinearSolve[bas, wineGlassPoints];

With the control points now available, it's easy to render the B-spline corresponding to the wine glass profile. You could do something like ParametricPlot[BSplineFunction[ctrlpts, SplineDegree -> 3, SplineKnots -> knots][u] // Evaluate, {u, 0, 1}] to see the profile curve, but you should know that Mathematica has the BSplineCurve[] graphics primitive that you can use instead:

Graphics[{BSplineCurve[ctrlpts, SplineDegree -> 3, SplineKnots -> knots],
         {AbsolutePointSize[4], Point[wineGlassPoints]}},
         Axes -> None, Frame -> True]

B-spline profile curve for wine glass

For generating the corresponding surface of revolution, we could again use an appropriately constructed rotation matrix to generate the equations of the surface of revolution (just like in my previous answer). Instead, we use a NURBS representation of the circle for generating the surface of revolution. This is the approach taken in this article by Piegl and Tiller (also discussed in The NURBS Book).

First, recall the following B-spline representation of a unit circle:

circPoints = {{1, 0}, {1, 1}, {-1, 1}, {-1, 0}, {-1, -1}, {1, -1}, {1, 0}};
circKnots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1};
circWts = {1, 1/2, 1/2, 1, 1/2, 1/2, 1};
BSplineCurve[circPoints, SplineDegree -> 2, SplineKnots -> circKnots,
             SplineWeights -> circWts] // Graphics

Here, then, is the procedure for generating the B-spline surface of revolution corresponding to the wine glass:

(* control points for surface of revolution *)
wgpts = Map[Function[pt, Append[#1 pt, #2]], circPoints] & @@@ ctrlpts;
(* weights for surface of revolution *)
wgwts = ConstantArray[circWts, Length[ctrlpts]];

We could use ParametricPlot3D[] along with BSplineFunction[] for rendering the surface of revolution, but we could instead use the BSplineSurface[] primitive. Let's generate the wine glass in the same style as my previous answer:

Graphics3D[{Directive[EdgeForm[], Opacity[1/5, ColorData["Legacy", "PowderBlue"]]], 
            BSplineSurface[wgpts, SplineClosed -> {False, True}, SplineDegree -> {3, 2},
                           SplineKnots -> {knots, circKnots}, SplineWeights -> wgwts]},
           Boxed -> False, Lighting -> "Neutral"]

B-spline wine glass

And we're done.


After writing up the code for this answer, some searching around shows that a similar strategy for generating surfaces of revolution has been done by Yu-Sung Chang in this Wolfram Demonstration.