Interpolating Functions to Approximate Volumes

This notebook utilizes digital photos and the method of cross sections to approximate the volume of a wine bottle.  A digital photograph is read and the "edges" of the bottle are approximated using a cubic interpolating function.  The cross sections are constructed and displayed in an animation.  The volume is computed using an integral involving the interpolating functions.

Read in graphics packages and turn off spelling checks.

In[203]:=

<<Graphics`Graphics3D` <<Graphics`Shapes` <<Graphics`FilledPlot` <<Graphics`Colors` <<Graphics`ParametricPlot3D` Off[General :: spell1] Off[General :: spell]

Import the digital photo.  This demo does not account for forshortening so it is useful to include in a photo some article such as a ruler that would give a sense of scale.  In this example, the photo is in JPEG format with a resolution of 72 pixels/inch.  This will be used in the calculations.  NOTE:  If you use your own photograph or if you download the image, you will need to change the path before executing.

In[210]:=

winebottle = Import["C:\Documents and Settings\user\Desktop\Volumeapps\winebottle.jpg"]

Out[210]=

⁃Graphics⁃

In[211]:=

Show[winebottle]

[Graphics:HTMLFiles/winebottle_mma_5.gif]

Out[211]=

⁃Graphics⁃

Select points along the top edge of the bottle in the photograph.  Click on the picture and while holding the Control Key, click the edge while moving from left to right (if you look carefully you will see white pixels corresponding to the selected points).  After selecting the points, choose Edit->Copy to copy the coordinates on the clipboard.  Then paste into the notebook input cell for the variable "toppoints".

In[212]:=

RowBox[{RowBox[{toppoints, =, RowBox[{{, RowBox[{RowBox[{{, RowBox[{RowBox[{-, 0.00467006}], , ... RowBox[{797.006, ,, 184.999}], }}], ,, RowBox[{{, RowBox[{810.006, ,, 184.999}], }}]}], }}]}], ;}]

Compute interpolating function and find maximum and minimum domain and range values.  These values will be used later when constructing graphs.

In[213]:=

top = Interpolation[toppoints] ;

In[214]:=

firstcoordstop = Table[toppoints[[i, 1]], {i, 1, Length[toppoints]}] ; secondcoordstop = Table ... topminx = Min[firstcoordstop] ; topmaxy = Max[secondcoordstop] ; topminy = Min[secondcoordstop] ;

Select points along the bottom edge of the photograph using the same approach as for the top points.  Copy and paste into the input for variable "bottompoints."

In[220]:=

RowBox[{RowBox[{bottompoints, =, RowBox[{{, RowBox[{RowBox[{{, RowBox[{RowBox[{-, 0.00467006}] ... RowBox[{786.006, ,, 119.998}], }}], ,, RowBox[{{, RowBox[{805.006, ,, 121.998}], }}]}], }}]}], ;}]

Compute interpolating function and find maximum and minimum domain and range values.  These values will be used later when constructing graphs.

In[221]:=

bottom = Interpolation[bottompoints] ;

In[222]:=

firstcoordsbottom = Table[bottompoints[[i, 1]], {i, 1, Length[bottompoints]}] ; secondcoordsbo ... irstcoordsbottom] ; bottommaxy = Max[secondcoordsbottom] ; bottomminy = Min[secondcoordsbottom] ;

Compute upper and lower bounds for the graphs.

In[228]:=

upperx = Min[bottommaxx, topmaxx] ; lowerx = Max[bottomminx, topminx] ;

Set PlotRange for the 3D plots.  The parameter addabit may be adjusted to control the space around the graphics.

In[230]:=

addabit = 100 ;

In[231]:=

plotrange3d = {{lowerx, upperx}, {-Min[bottommaxy, topmaxy] - addabit, Max[bottommaxy, topmaxy] + addabit}, {-Min[bottommaxy, topmaxy] - addabit, Max[bottommaxy, topmaxy] + addabit}} ;

Show the interpolating function that fits the points.

In[232]:=

bottlegraph = Show[Plot[{top[x], bottom[x]}, {x, lowerx, upperx}, AxesAutomatic, PlotR ...  1, 0], Thickness[.005]}, {CMYColor[0, 1, 0], Thickness[.005]}}, DisplayFunctionIdentity]]

Out[232]=

⁃Graphics⁃

In[233]:=

Show[{winebottle, bottlegraph}, AspectRatioAutomatic, DisplayFunction$DisplayFunction]

[Graphics:HTMLFiles/winebottle_mma_19.gif]

Out[233]=

⁃Graphics⁃

Set up the partition.

In[234]:=

n = 21 ; Δx = (upperx - lowerx)/(n - 1) ; xgrid[i_] = lowerx + (i - 1) Δx ; partitio ... id[i]]}, {xgrid[i], 0, top[xgrid[i]]}}]}], ImageSize300, DisplayFunctionIdentity]

In[238]:=

partitionall := Table[partition[i], {i, 1, n - 1}]

Find the centers of the cross sections.  Compute the radius function by computing 1/2 (top(x) - bottom(x)).

In[239]:=

centers[x_] = {x, (top[x] + bottom[x])/2} ; radii[x_] = (top[x] - bottom[x])/2 ;

Generate the cross sectional slices.

In[241]:=

rightends = Table[ParametricPlot3D[{xgrid[i], u * radii[xgrid[i - 1]] * Cos[t], u * radii[xgri ... ; {20, 20}, DisplayFunctionIdentity, BoxedFalse, ImageSize350], {i, 2, n}]

Out[241]=

{⁃Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics ... 9;Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics3D⁃}

In[242]:=

leftends = Table[ParametricPlot3D[{xgrid[i], u * radii[xgrid[i]] * Cos[t], u * radii[xgrid[i]] ... ; {20, 20}, BoxedFalse, DisplayFunctionIdentity, ImageSize350], {i, 1, n}]

Out[242]=

{⁃Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics ... 9;Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics3D⁃, ⁃Graphics3D⁃}

In[243]:=

xsections := Table[ParametricPlot3D[{u, radii[xgrid[i - 1]] * Cos[t], radii[xgrid[i - 1]] * Si ... ; {20, 20}, BoxedFalse, DisplayFunctionIdentity, ImageSize350], {i, 2, n}]

The cross section (perpendicular to the base of the bottle) is generated by filled rectangles.

In[244]:=

numpts = 50 ; dx = (upperx - lowerx)/numpts ; xrect[i_] = lowerx + i * dx ; vertices[k_] := {{ ... ect[k], 0, bottom[xrect[k]]}, {xrect[k], 0, top[xrect[k]]}, {xrect[k - 1], 0, top[xrect[k - 1]]}}

In[248]:=

region = Show[Graphics3D[{SurfaceColor[Magenta], EdgeForm[], Table[Polygon[vertices[k]], {k, 1, numpts}]}]]

[Graphics:HTMLFiles/winebottle_mma_31.gif]

Out[248]=

⁃Graphics3D⁃

Show the partition and the region.

In[249]:=

Show[region, partitionall, BoxedFalse, ViewPoint {1, -3, .5}, ImageSize350]

[Graphics:HTMLFiles/winebottle_mma_34.gif]

Out[249]=

⁃Graphics3D⁃

Generate a 3-dimensional model of the bottle.

In[250]:=

bottlegraph = ParametricPlot3D[{x, radii[x] * Cos[t], radii[x] * Sin[t] + centers[x][[2]], Edg ... -3, .5}, PlotPoints {20, 20}, BoxedFalse, ImageSize350, AxesFalse]

[Graphics:HTMLFiles/winebottle_mma_37.gif]

Out[250]=

⁃Graphics3D⁃

Generate the cross sections.  The frames can be animated.

In[251]:=

For[m = 1, m<n, m ++, Show[{region, partitionall, Table[{xsections[[k]], rightends[[k]], le ... 3, 0}, DisplayFunction$DisplayFunction, PlotRangeplotrange3d, BoxedFalse]]

[Graphics:HTMLFiles/winebottle_mma_60.gif]

The following codes set up frames to animate the selection of the points along the edges of the bottle.  They are not necessary for the demo but might be useful in the event you wish to use a different photo.

In[252]:=

For[k = 1, k<Length[toppoints], k ++, If[k<Length[toppoints] - 1, Show[{winebottle, Tabl ... ; {Thickness[.005], CMYColor[0, 1, 0]}, DisplayFunctionIdentity]}, ImageSize500]]]

[Graphics:HTMLFiles/winebottle_mma_89.gif]

In[253]:=

For[k = 1, k<Length[bottompoints], k ++, If[k<Length[bottompoints] - 1, Show[{winebottle ... ; {Thickness[.005], CMYColor[0, 1, 0]}, DisplayFunctionIdentity]}, ImageSize500]]]

[Graphics:HTMLFiles/winebottle_mma_119.gif]

This Mathematica notebook was developed for Demos with Positive Impact (NSF DUE -9952306) by
Lila F. Roberts (lila.roberts@gcsu.edu)
Georgia College & State University

Special thanks to James P. Braselton at Georgia Southern University for his Mathematica advice and assistance.


Created by Mathematica  (December 31, 2003)