Calculating Multipoles of Rotationally Symmetric Objects w.r. to Legendre Polynomials

hgrie, 23.11.2009
Quick-and-dirty.
Programme works only for parameterisations of objects which have invertible (bijective) functions of y-coordinate as function of x-coordinate.

Plot options

red=RGBColor[1,0,0];
green=darkgreen;(*RGBColor[0,1,0];*)
darkgreen=CMYKColor[1,0,1,.5];
blue=RGBColor[0,0,1];
darkblue= CMYKColor[1,1,0,.3];
violet=RGBColor[.6,0,1];
white=RGBColor[1,1,1];
black=RGBColor[0,0,0];
fillcolour=RGBColor[0.572549, 0.564706, 1];
grey=GrayLevel[.85];
slidegrey=GrayLevel[.6];
solid=Dashing[{1,0}]; (*solid*)
dotdashed=Dashing[{0.005,0.02,0.02,0.02}]; (*dot-dashed*)
middashed=Dashing[{0.02,0.02}];(*mid dashed*)
longdashed=Dashing[{0.04,0.02}]; (*long dashed*)
dashed=middashed; (* CHOOSE DASHING!!!!!*)
dotted=Dashing[{0.003,0.015}]; (*dotted*)
axes=None;
imagesize=Automatic;

figimagesizeexp={290,200};
figimagesize={400*12.5/14.1*10.7/10.6,400/GoldenRatio};
figimagesize2=1.5{400*12.5/14.1*10.7/10.6,400/GoldenRatio};
figimagesizeArray2=1.5 {2*357.9553057674295`,(400/GoldenRatio)};
figimagesizeArray3=1.5 {3*357.9553057674295`,(400/GoldenRatio)};
plotoptions={
Background->white,
Frame->True,
Prolog->AbsoluteThickness[1],
ImageSize-> figimagesize};

define correct ticks for θ ∈[0;180] degree

thetatableprelim=Table[{i,"",{3/900,0}},{i,0,180,5}];
thetatablenumbers=Table[{i,StringForm["``",i],{6/900,0}},{i,0,180,30}];
thetatablenonumbers=Table[{i,"",{6/900,0}},{i,0,180,30}];
thetatableup=Union[
Delete[thetatableprelim,Table[{i},{i,1,Dimensions[thetatableprelim][[1]],6}]],
thetatablenonumbers];
thetatabledown=Union[
Delete[thetatableprelim,Table[{i},{i,1,Dimensions[thetatableprelim][[1]],6}]],
thetatablenumbers];

Define multipoles of Legendre Polynomials

multipole: coefficient of a function in cosθ:

c[l_,function_]:=(2l+1)/2NIntegrate[function[cosθ] LegendreP[l,cosθ],{cosθ,-1,1}]

contribution of the l'th multipole:

term[l_,cosθ_,function_]:=c[l,function]LegendreP[l,cosθ]

sum of all multipoles up to lmax:

total[lmax_,cosθ_,function_]:=Sum[term[l,cosθ,function],{l,0,lmax}]

Apple

This is a famous apple:

Import["appleb.jpg"]

Producing data from images

I used g3data to produce a table of coordiantes (x,y) of the outlines of the image, after lying the image flat:

table = Import["appleb.jpg.dat"]

table = {{0, -0.766397868971`}, {0.0325075879498`, -0.733646954361`}, {0.0613823515601`, -0.709032541739`}, {0.0821547642933`, -0.762880304628`}, {0.152480437817`, -0.800506290208`}, {0.276500194234`, -0.826068396136`}, {0.425185589939`, -0.789799917184`}, {0.55721378168`, -0.691444720025`}, {0.676793893782`, -0.568218976918`}, {0.800420912432`, -0.403696003893`}, {0.882682398945`, -0.218255475917`}, {0.919548522324`, -0.0614591915578`}, {0.91897649123`, 0.215403858222`}, {0.802785876808`, 0.451661238063`}, {0.641345041472`, 0.589025540761`}, {0.409817590383`, 0.648311867938`}, {0.16620064631`, 0.558912799409`}, {0.0631240581764`, 0.447981455947`}, {0, 0.287385860587`}};

tab = Table[{table[[i, 2]], table[[i, 1]]}, {i, 1, Dimensions[table][[1]]}]

{{-0.766398, 0}, {-0.733647, 0.0325076}, {-0.709033, 0.0613824}, {-0.76288, 0.0821548}, {-0.800506, 0.15248}, {-0.826068, 0.2765}, {-0.7898, 0.425186}, {-0.691445, 0.557214}, {-0.568219, 0.676794}, {-0.403696, 0.800421}, {-0.218255, 0.882682}, {-0.0614592, 0.919549}, {0.215404, 0.918976}, {0.451661, 0.802786}, {0.589026, 0.641345}, {0.648312, 0.409818}, {0.558913, 0.166201}, {0.447981, 0.0631241}, {0.287386, 0}}

Graphics[Spline[tab, Bezier]]

From that, calculated the following table of points (r(cosθ),cosθ), since this is what is needed for Legendre multipoles (functions of cosθ)!

I also have to make sure that the centre of the apple is in the coordinate origin. I could do that inthe graphics, but I prefer to do it by hand here.

rtable = Sort[Table[{(tab[[i, 1]])/((tab[[i, 1]])^2 + (tab[[i, 2]])^2)^(1/2), ((tab[[i, 1]])^2 + (tab[[i, 2]])^2)^(1/2)}, {i, 1, Dimensions[tab][[1]]}]]

{{-1., 0.766398}, {-0.99902, 0.734367}, {-0.996274, 0.711685}, {-0.994251, 0.767291}, {-0.982338, 0.814899}, {-0.948289, 0.871115}, {-0.880514, 0.896976}, {-0.778635, 0.888022}, {-0.643001, 0.883698}, {-0.450321, 0.896462}, {-0.240035, 0.909265}, {-0.0666875, 0.9216}, {0.22821, 0.943884}, {0.490339, 0.921121}, {0.676427, 0.87079}, {0.845278, 0.76698}, {0.958519, 0.5831}, {0.990218, 0.452407}, {1., 0.287386}}

manipulating away a few bad points (poor scan?), I arrive at the table given below

Rendering of Apple

We only need the data for positive x, arbitrary y, since the object is rotationally symmetric.

rtable={{-1.`,0.766397868971`},{-0.999019773739551`,0.7343667999831455`},{-0.9962735793659033`,0.711684577834812`},{-0.994251358944856`,0.7672911862424837`},{-0.9823378786414703`,0.8148991376725335`},{-0.9482885624565212`,0.8711150053271629`},{-0.8805135798742924`,0.8969764183497962`},{-0.7786347096018167`,0.888021958818912`},{-0.6430010585826081`,0.8836983537329578`},{-0.45032138352680295`,0.8964619906151362`},{-0.2400349363152119`,0.9092654563850187`},{-0.06668748467079613`,0.9216000852512929`},{0.22821014615845034`,0.9438837924079032`},{0.4903389094486968`,0.9211205338993325`},{0.6764269256920147`,0.8707896128741487`},{0.8452784156064533`,0.7669802706045229`},{0.9585188429886303`,0.5831004820586815`},{0.9902179317745182`,0.45240693141579014`},{0.9999999999999999`,0.287385860587`}};
apple[cosθ_]=Interpolation[rtable,InterpolationOrder->1][cosθ];
ListPlot[rtable,Mesh->Full,Joined->True,InterpolationOrder->1,AspectRatio->Automatic,
Frame->True,
FrameLabel->{"Cos[θ]","r","Plot of r(cosθ)",None},
Background->White,
ImageSize->500]
PolarPlot[apple[Cos[θ-π/2]],{θ,-π,π},
Frame->True,
FrameLabel->{"x","y","PolarPlot",None},
Background->White]

This is not the very best rendering, but it suffices.

Multipoles

lmin=0;
lmax=10;
GraphicsGrid[{{
Show[PolarPlot[apple[Cos[θ-π/2]],
{θ,-π,π},
PlotStyle->Thick,
Frame->True,
FrameLabel->{"x","y",StringForm["Sum of multipoles l∈[``;``]",lmin,lmax],None},
PlotRange->{{-1,1},{-1,1}},
AspectRatio->Automatic,
Background->White,
ImageSize->300],
PolarPlot[
Evaluate[
Table[total[l,Cos[θ-π/2],apple],{l,lmin,lmax}]
],
{θ,-π,π}]
],
PolarPlot[
Evaluate[
Table[term[l,Cos[θ-π/2],apple],{l,lmin,lmax}]
],
{θ,-π,π},
Frame->True,
FrameLabel->{"x","y",StringForm["Each multipole l∈[``;``]",lmin,lmax],None},
PlotRange->{{-1,1},{-1,1}},
AspectRatio->Automatic,
Background->White,
ImageSize->300]}}]
Clear[lmin,lmax]

lmin=0;
lmax=20;
GraphicsGrid[{{
Show[PolarPlot[apple[Cos[θ-π/2]],
{θ,-π,π},
PlotStyle->Thick,
Frame->True,
FrameLabel->{"x","y",StringForm["Sum of multipoles l∈[``;``]",lmin,lmax],None},
PlotRange->{{-1,1},{-1,1}},
AspectRatio->Automatic,
Background->White,
ImageSize->300],
PolarPlot[
Evaluate[
Table[total[l,Cos[θ-π/2],apple],{l,lmin,lmax}]
],
{θ,-π,π}]
],
PolarPlot[
Evaluate[
Table[term[l,Cos[θ-π/2],apple],{l,lmin,lmax}]
],
{θ,-π,π},
Frame->True,
FrameLabel->{"x","y",StringForm["Each multipole l∈[``;``]",lmin,lmax],None},
PlotRange->{{-1,1},{-1,1}},
AspectRatio->Automatic,
Background->White,
ImageSize->300],
PolarPlot[
Evaluate[
Table[term[l,Cos[θ-π/2],apple],{l,10,lmax}]
],
{θ,-π,π},
Frame->True,
FrameLabel->{"x","y",StringForm["Each multipole l∈[``;``], magnified",10,20],None},
PlotRange->All,
AspectRatio->Automatic,
Background->White,
ImageSize->300]}}]
Clear[lmin,lmax]

See how nicely higher-order Legendre Polynomials decrease in rapidly in size. The apple is a simple object, so we do not need lots of multipoles.
In the following multipoles up to a high number. 
You will get non-convergences of the integration routine because my table to render an apple is not that good for interpolating.

lmin=0;
lmax=40;
lstep=10;
Show[PolarPlot[apple[Cos[θ-π/2]],
{θ,-π,π},
PlotStyle->Thick,
Frame->True,
FrameLabel->{"x","y",StringForm["Sum of multipoles l∈{``;``}, in steps of ``",lmin,lmax,lstep],None},
PlotRange->{{-1,1},{-1,1}},
AspectRatio->Automatic,
Background->White,
ImageSize->500],
PolarPlot[
Evaluate[
Table[total[l,Cos[θ-π/2],apple],{l,lmin,lmax,lstep}]
],
{θ,-π,π}]
]
Clear[lmin,lmax,lstep]

Bowling Pin

This is what a Bowling Pin looks like:

Import["bowlingpin.jpg"]

Producing data from images

I used g3data to produce a table of coordiantes (x,y) of the outlines of the image, after lying the image flat:

tab = Import["bowlingpin.jpg.dat"]

tab = {{0, 0}, {0.003`, 0.368220168742`}, {0.006`, 0.736641221374`}, {0.01`, 0.894736842105`}, {0.02`, 1}, {0.0381679389313`, 1.05283246284`}, {0.267175572519`, 1.15930092407`}, {0.458015267176`, 1.31820008035`}, {0.725190839695`, 1.48276416231`}, {1.14503816794`, 1.69023704299`}, {1.60305343511`, 1.90317396545`}, {2.06106870229`, 2.06347930896`}, {2.63358778626`, 2.17175572519`}, {3.24427480916`, 2.22760144636`}, {3.89312977099`, 2.12575331458`}, {4.31297709924`, 1.97006830052`}, {4.77099236641`, 1.65668943351`}, {5.15267175573`, 1.50080353556`}, {5.49618320611`, 1.29208517477`}, {6.06870229008`, 1.03194053837`}, {6.45038167939`, 0.928686219365`}, {6.8320610687`, 0.878063479309`}, {7.13740458015`, 0.879670550422`}, {7.4427480916`, 0.956540779429`}, {7.74809160305`, 1.04077942949`}, {8.0534351145`, 1.20028123744`}, {8.43511450382`, 1.30755323423`}, {9.00763358779`, 1.31056649257`}, {9.35114503817`, 1.25974286862`}, {9.77099236641`, 0.946163117718`}, {9.92`, 0.683607874648`}, {9.97`, 0.420650863801`}, {9.99`, 0.2103254319`}, {10, 0}}

This gives the following curve:

Graphics[Spline[tab, Bezier]]

From that, calculated the following table of points (r(cosθ),cosθ), since this is what is needed for Legendre multipoles (functions of cosθ)!

rtable = Sort[Table[{(tab[[i, 1]] - 5)/((tab[[i, 1]] - 5)^2 + tab[[i, 2]]^2)^(1/2), ((tab[[i, 1]] - 5)^2 + tab[[i, 2]]^2)^(1/2)}, {i, 1, Dimensions[tab][[1]]}]];

manipulating away a few bad points (poor scan?), I arrive at the table given below

Rendering of Bowling Pin

We only need the data for positive x, arbitrary y, since the object is rotationally symmetric.

rtable={{-1,5},{-0.9981049154667889`,5.00648771743903`},{-0.9924706684156326`,5.03188674378897`},{-0.9889337201220717`,5.045838662862104`},{-0.9861792180961343`,5.049792074927442`},{-0.9846049046796108`,5.0394143249604`},{-0.9796391525634637`,4.831191582223328`},{-0.9717619523115479`,4.673968477588464`},{-0.9603765459121363`,4.451180298499394`},{-0.9388237425317604`,4.106161420315365`},{-0.9054598703778789`,3.7516257495457412`},{-0.8622356816203988`,3.40850113299286`},{-0.7931575511374406`,2.9835336123906377`},{-0.6856985056494187`,2.560491493527711`},{-0.5283802026517636`,2.0948366790712227`},{-0.3847302103975032`,1.7857264186510533`},{-0.16300906774673504`,1.404876653523387`},{0.12069775106348686`,1.2649096970306846`},{0.4171467951992445`,1.1894690593823338`},{0.7778697405872509`,1.3738833564514101`},{0.8814788438696471`,1.6453959042543767`},{0.9281590704612352`,1.9738653933420953`},{0.9455161559872547`,2.2605690728978`},{0.9502988013117125`,2.5705052855251806`},{0.9528466811544354`,3.6051072767112293`},{0.9645492026928448`,4.154929138504724`},{0.9718933841029539`,4.4769777316532045`},{0.9865126505839945`,4.8362201575273005`},{0.9933107533076153`,4.953132726709081`},{0.9975021333635719`,4.982445484343163`},{0.9993787796180014`,4.9931018166178776`},{1,5}};
bowlingpin[cosθ_]=Interpolation[rtable,InterpolationOrder->1][cosθ];
GraphicsGrid[{{
ListPlot[rtable,Mesh->Full,Joined->True,InterpolationOrder->1,AspectRatio->Automatic,
Frame->True,
FrameLabel->{"Cos[θ]","r","Plot of r(cosθ)",None},
Background->White,
ImageSize->300],
PolarPlot[bowlingpin[Cos[θ-π/2]],{θ,-π,π},
Frame->True,
FrameLabel->{"x","y","PolarPlot",None},
Background->White]}}]

This is not the very best rendering, but it suffices.

Multipoles

lmin=0;
lmax=10;
GraphicsGrid[{{
Show[PolarPlot[bowlingpin[Cos[θ-π/2]],
{θ,-π,π},
PlotStyle->Thick,
Frame->True,
FrameLabel->{"x","y",StringForm["Sum of multipoles l∈[``;``]",lmin,lmax],None},
PlotRange->{{-3,3},{-6,6}},
AspectRatio->Automatic,
Background->White,
ImageSize->300],
PolarPlot[
Evaluate[
Table[total[l,Cos[θ-π/2],bowlingpin],{l,lmin,lmax}]
],
{θ,-π,π}]
],
PolarPlot[
Evaluate[
Table[term[l,Cos[θ-π/2],bowlingpin],{l,lmin,lmax}]
],
{θ,-π,π},
Frame->True,
FrameLabel->{"x","y",StringForm["Each multipole l∈[``;``]",lmin,lmax],None},
PlotRange->{{-3,3},{-6,6}},
AspectRatio->Automatic,
Background->White,
ImageSize->300]}}]
Clear[lmin,lmax]

lmin=0;
lmax=20;
GraphicsGrid[{{
Show[PolarPlot[bowlingpin[Cos[θ-π/2]],
{θ,-π,π},
PlotStyle->Thick,
Frame->True,
FrameLabel->{"x","y",StringForm["Sum of multipoles l∈[``;``]",lmin,lmax],None},
PlotRange->{{-3,3},{-6,6}},
AspectRatio->Automatic,
Background->White,
ImageSize->300],
PolarPlot[
Evaluate[
Table[total[l,Cos[θ-π/2],bowlingpin],{l,lmin,lmax}]
],
{θ,-π,π}]
],
PolarPlot[
Evaluate[
Table[term[l,Cos[θ-π/2],bowlingpin],{l,lmin,lmax}]
],
{θ,-π,π},
Frame->True,
FrameLabel->{"x","y",StringForm["Each multipole l∈[``;``]",lmin,lmax],None},
PlotRange->{{-3,3},{-6,6}},
AspectRatio->Automatic,
Background->White,
ImageSize->300],
PolarPlot[
Evaluate[
Table[term[l,Cos[θ-π/2],bowlingpin],{l,10,lmax}]
],
{θ,-π,π},
Frame->True,
FrameLabel->{"x","y",StringForm["Each multipole l∈[``;``], magnified",10,20],None},
PlotRange->All,
AspectRatio->Automatic,
Background->White,
ImageSize->300]}}]
Clear[lmin,lmax]

See how nicely higher-order Legendre Polynomials decrease in rapidly in size. Still, the Bowling Pin is a complicated object, so we need lots of multipoles.
In the following multipoles up to a high number. 
You will get non-convergences of the intergation routine because my table to render a Bowling Pin is not that good for interpolating.

lmin=0;
lmax=40;
lstep=10;
Show[PolarPlot[bowlingpin[Cos[θ-π/2]],
{θ,-π,π},
PlotStyle->Thick,
Frame->True,
FrameLabel->{"x","y",StringForm["Sum of multipoles l∈{``;``}, in steps of ``",lmin,lmax,lstep],None},
PlotRange->{{-3,3},{-6,6}},
AspectRatio->Automatic,
Background->White,
ImageSize->300],
PolarPlot[
Evaluate[
Table[total[l,Cos[θ-π/2],bowlingpin],{l,lmin,lmax,lstep}]
],
{θ,-π,π}]
]
Clear[lmin,lmax,lstep]