Re: Drawing a bounded smooth region with Mathematica
- To: mathgroup at smc.vnet.net
- Subject: [mg76345] Re: [mg76290] Drawing a bounded smooth region with Mathematica
- From: Murray Eisenberg <murray at math.umass.edu>
- Date: Sun, 20 May 2007 02:26:19 -0400 (EDT)
- Organization: Mathematics & Statistics, Univ. of Mass./Amherst
- References: <f2em3g$2oo$1@smc.vnet.net><f2h8hr$q5$1@smc.vnet.net> <200705190834.EAA20921@smc.vnet.net>
- Reply-to: murray at math.umass.edu
The final, Show, cell is causing errors in Mathematica 6.0. Of course Graphics`Arrow` is obsolete in Mathematica 6.0, and accordingly the options HeadLength and HeadCenter are also obsolete. So I omitted loading that package and deleted those two options. And I changed the 5.2 StyleForm in the big Block to Style. Although there's an error "+" symbol and a pink background with red border on the graphic indicating an error, I cannot get error messages by clicking on the "+". The displayed graphic shows the smooth curve with the labels V and S. The tangent line segment is OK (but no arrow). The normal is thin, short, and bent! And no arrow. And the letter "n" is reduced to nearly a dot. There's a large blank triangular region (with pink background exposed) inside the curve . See attached screenshot. [Attachments are not sent to the group. See the graphics file at http://smc.vnet.net/mgattach/curve.png - moderator] dimitris wrote: > The following code appeared in a recent post. > But as Murray watched, it was not very easy to follow. > > So... > > Let make another attempt with the hope that everything > will appear readable! > > ---------------------------------------------------------------------------= > ---------- > Drawing a bounded smooth region with Mathematica > ---------------------------------------------------------------------------= > ---------- > > In[41]:= > Clear["Global`*"] > > In[42]:= > << "Graphics`Arrow`" > > We want to take a circle and add an arbitrary modulation to the radius > to obtain an irregular shape. However, we need a smooth join at o=0 > and o=2Pi. So we need a partition function. I am going to make a > function that is a over most of the domain 0 to 2 , but smoothly > transistions to zero at the end points and has zero slope at the end > points. The following was just used to calculate arguments for the > function. > > In[43]:= > a*o + b /. o -> 2*Pi > Out[43]= > b + 2*a*Pi > > In[45]:= > a*o + b /. o -> 2*Pi - d > Out[45]= > b + a*(-d + 2*Pi) > > In[46]:= > Solve[{b + 2*a*Pi == -(Pi/2), b + a*(-d + 2*Pi) == Pi/2}, {a, b}] > Out[46]= > {{a -> -(Pi/d), b -> -((d*Pi - 4*Pi^2)/(2*d))}} > > In[49]:= > 1/2 + (1/2)*Sin[(-o)*(Pi/d) - (d*Pi - 4*Pi^2)/(2*d)] > FullSimplify[%] > > Out[49]= > 1/2 - (1/2)*Sin[(o*Pi)/d + (d*Pi - 4*Pi^2)/(2*d)] > Out[50]= > Sin[((o - 2*Pi)*Pi)/(2*d)]^2 > > So this gives us a partition function. d gives the width of the > transistion region at each end of the o domain. > > In[51]:= > partitionfunction[d_][o_] := Piecewise[{{Sin[(Pi*o)/(2*d)]^2, > Inequality[0, LessEqual, o, Less, d]}, > {1, Inequality[d, LessEqual, o, Less, 2*Pi - d]}, {Sin[(Pi*(2*Pi - > o))/(2*d)]^2, 2*Pi - d <= o <= 2*Pi}}] > > Let's use a piece of a Bessel function to modulate the radius. > > In[52]:= > Plot[BesselJ[5, x], {x, 5, 18}, Frame -> True]; > > In[53]:= > Solve[{(a*o + b /. o -> 0) == 5, (a*o + b /. o -> 2*Pi) == 18}] > Out[53]= > {{a -> 13/(2*Pi), b -> 5}} > > In[54]:= > radius[d_][o_] := 1 + 1.5*partitionfunction[d][o]*BesselJ[5, (13/ > (2*Pi))*o + 5] > > In[55]:= > Plot[radius[1][o], {o, 0, 2*Pi}, Frame -> True, PlotRange -> All, Axes > -> False]; > > Now we can parametrize the curve. > > In[58]:= > curve[d_][o_] := radius[d][o]*{Cos[o], Sin[o]} > > For d=1 and o=45=B0 we can calculate the tangent line and normal line. > > In[59]:= > tangent[t_] = N[curve[1][45*Degree] + t*Derivative[1][curve[1]] > [45*Degree]] > Out[59]= > {1.057382730502271 - 0.7335911589691905*t, 1.057382730502271 + > 1=2E3811743020353515*t} > > In[61]:= > normal[t_] = N[curve[1][45*Degree] + t*Reverse[Derivative[1][curve[1]] > [45*Degree]]*{1, -1}] > Out[61]= > {1.057382730502271 + 1.3811743020353515*t, 1.057382730502271 + > 0=2E7335911589691905*t} > > In[83]:= > n = {1.127382730502271, 1.037382730502271}; > > Finnally > > In[81]:= > Block[{$DisplayFunction = Identity}, g = ParametricPlot[curve[1][o1], > {o1, 0, 2*Pi}, Axes -> False, PlotPoints -> 50, > PlotStyle -> Thickness[0.007]]; g1 = g /. Line[x_] -> > {GrayLevel[0.8], Polygon[x]}; > g2 = ParametricPlot[tangent[t], {t, -0.2, 0.2}, PlotStyle -> > Thickness[0.006], PlotPoints -> 50]; > g3 = Graphics[{Thickness[0.007], Arrow[normal[0], normal[0.3], > HeadLength -> 0.06, HeadCenter -> 0.7]}]; > cir = Graphics[{Circle[normal[0], 0.1, {3.3*(Pi/2), 2.15*Pi}]}]; po > = Graphics[{PointSize[0.01], Point[n]}]; > tex1 = Graphics[Text["V", {0.0532359, -0.0138103}]]; tex2 = > Graphics[Text["S", {0.470751, -1.08655}]]; > tex3 = Graphics[Text[StyleForm["n", FontSize -> 17, FontFamily -> > "Times", FontColor -> Black, > FontWeight -> "Bold"], {1.7, 1.2}]]; ] > > Show[g, g1, g2, g3, tex1, tex2, tex3, cir, po, AspectRatio -> > Automatic, > TextStyle -> {FontSize -> 17, FontFamily -> "Times", FontWeight -> > "Bold"}]; > > ---------------------------------------------------------------------------= > ------------------------------------------------------------------------- > > If everything works ok during the Copy/Paste process then it will > appear a really nice > drawing. > > Who sent that Mathematica cannot be used as a drawing environement? > Show them this drawing in order to change their mind! > I did to my supervisor! With a little success I must admit! But this > is > another issue! > > Using David Park's well known package previous drawing appears much > nicer in the > sense of aesthetic issues! I have seen it with my own eyes! > > All acknowledgents regarding the process of modulation of the region > must > be given to the one and only Mr. David Park! I spent much time to > figure out what > is going! Simply amazing (the idea and David as well!). > > I don't know about you, but speaking on behalf of myself and with all > of my respect to the other forumists, > I sadly missed his presence and contribution to the forum. > > Dimtris > > -- Murray Eisenberg murray at math.umass.edu Mathematics & Statistics Dept. Lederle Graduate Research Tower phone 413 549-1020 (H) University of Massachusetts 413 545-2859 (W) 710 North Pleasant Street fax 413 545-1801 Amherst, MA 01003-9305
- References:
- Drawing a bounded smooth region with Mathematica
- From: dimitris <dimmechan@yahoo.com>
- Drawing a bounded smooth region with Mathematica