Related
I'm trying to solve a problem: I have to find the trajectory of an electron in a graphene lattice using Mathematica. I've tried to solve the Coulomb Force equation with NDSolve and to plot the result for each direction, but i obtain a white plot. Could someone help me please? Thank you in advance. Here's the code for the x direction:
coordx = {0.6327, 1.88058, 3.03927, 4.28716, 5.44584, 6.69373,
7.85241, 9.10029, 1.9728, 3.22069, 4.37937, 5.62726, 6.78594,
8.03382, 9.19251, 10.4404, 3.3129, 4.56079, 5.71947, 6.96736,
8.12604, 9.37393, 10.53261, 11.7805, 4.653, 5.90089, 7.05956,
8.30746, 9.46614, 10.71403, 11.87271, 13.1206};
me = 9.01*10^-31;
pi = 3.14159;
epsilon0 = 8.854*10^-12;
q = -1.6*10^-19;
Q = 1.6*10^-19;
step = 0.01;
Forzax[p_, r_] :=
Sum[(Q*q)/(4 pi*epsilon0*Norm[r - p[[i]]]^2), {i, Length[p]}]
Forzax[coordx, {x[t]}];
NDSolve[{x''[t] == Forzax[coordx, {x[t]}]/me , x[0] == 0,
x'[0] == 0}, {x[t]}, {t, 0, 1500}]
Show[ParametricPlot[Evaluate[{x[t]} /. %], {t, 0, 1500},
PlotRange -> All]]
I don't know what you're trying to plot, but these few modifications seem to plot your function.
sol = NDSolve[{x''[t] == Forzax[coordx, {x[t]}]/me,
x[0] == 0, x'[0] == 0}, {x}, {t, 0, 1500}];
f = sol[[1, 1, 2]];
Plot[f[t], {t, 0, 1500}, PlotRange -> All]
From what I can tell, your code is running fine but the plot is empty because you're calling ParametricPlot with just one function. From the documentation, this is how you call ParametricPlot:
ParametricPlot[{fx[t], fy[t]}, {t, tmin, tmax}]
Since you're still solving the 1D problem and only have x[t], ParametricPlot cannot draw anything; it's missing the y coordinate of the trajectory. Once you do a 2D calculation, ParamatricPlot should be able to give you to figure you want. If you want to do a 3D calculation, you should use ParamatricPlot3D.
A question though: how do you intend to to a 3D calculation of an electron in graphene? The motion of the electron in the 3rd dimension will not follow Newtonian mechanics at all because it is confined so much in that direction. In fact, I'd be kind of cautious about using Newton's 2nd law in graphene no matter what, since electrons in graphene behave like massless particles. I leave the interpretation of the results up to you, but the physicist in me cannot resist adding this word of caution.
Context: Two sets of data, one is the radius, r, and the other is the velocity, v. v can be positive and negative. The following code
p1=ListLogLogPlot[Table[{r[[i]],v[[i]]},{i,1,number_of_data}]];
p2=ListLogLogPlot[Table[{r[[i]],-v[[i]]},{i,1,number_of_data}],PlotStyle->{Red}];
Show[p1,p2]
is used to give a curve, with positive and negative v both plotted in log-log coordinates.
Question: How to draw a circular, contour-like plot, with Log[r] as the distance to the center of the circle, and the velocities (Log[v]) shown as different, but continuously varying colors, according to v's sign and magnitude?
You may use a DensityPlot function:
v[r_] := Sin[r]*r^2
DensityPlot[v[Norm[{x, y}]], {x, -5, 5}, {y, -5, 5}]
You can deal with the tabular data in two ways. You can either interpolate and use the interpolating function as above or you may use a ListDensityPlot function:
ListDensityPlot[Table[With[{r = RandomReal[{0, 4}], t = RandomReal[{0, 2 Pi}]},
{r Cos[t], r Sin[t], v[r]}], {10^4}]]
I hope this helps.
For an experiment, we generated in Matlab some images made out of 8 Disks. We constrained, the minimum distance between the disks and between the disks and the frame as well as the location of the Disks Center Of Gravity (COG). Bellow an example of a composition with the COG on the upper lift "third"
FraXYs = {{4.32, 3.23}, {35.68, 26.75}}
stiDisks = {{{8, 11}, 1}, {{10, 17}, 1}, {{16, 24}, 1}, {{25, 22},1},
{{31, 22}, 1}, {{7, 21}, 2}, {{16, 12}, 2}, {{19, 22}, 2}}
Graphics[{White, EdgeForm[Thick],
Rectangle ## FraXYs,
Red, Disk[{14.77, 18.91}, 1],
Blue, Opacity[.6], EdgeForm[Black],
Blue, Thickness[0.003],
Opacity[1],
Black,
Disk[#[[1]], #[[2]]] & /# stiDisks}, ImageSize -> {400, 300}]
I would like to generate those stimuli in Mathematica. Below are the element (features and constraints) I am dealing with. The measures are in Cm. The Center Of Gravity (COG) of the shapes is defined as the area weihtgted location of the disks.
The Features :
Stimuli Frame : {{xMin,xMin},{xMax,yMax}}
FraXYs = {{4.32, 3.23}, {35.68, 26.75}}
5 Small Disks : with radius
rSmall=1
3 Large Disks : with radius
rLarge=2
The Constraints :
Minimum distance between the shapes edges :
minDistSha=1
Minimum distance between the shapes edges and the frame border :
minDistFra=1
Distance of shapes COG from the center :
minDistCogCenter=2
Potentially, I will need to constraint the COG of the disks to be on a certain angle from the center (theta coordinate in a polar system?). So I could select the disks coordinates constraining their COGs to be located every 22.5 degree in a polar coordinate
angleBin=22.5
Is there useful Functions in Mathematica to achieve the selection under constraints aside of Selct.
I would be curious to know if a closed formula to generate 1 composition with a particular COG location is possible.
Indicatively, I will need to get a pool of 1000 compositions. Using the "theta constraints"of 36 degrees, I should extract 10*100 composition with their COG located on the 10 different theta bars at a minimum or fixed distance from the center.
Please tell me if clarifications are needed. Thank You for your attention.
This might get you started. It is a simple rejection method to generate circles at random, throwing away ensembles that do not meet requirements.
Arguments are the box size, numbers and radii of small and large circles, and a minimum separation. That last is used both for distances to boundary and distances between circles. I double it for the center of gravity to center of frame constraint. Clearly this usage could be generalized by adding more arguments.
For purposes of assessing how likely this is to find viable ensembles, I print the number of times through the loop. Also I use a Catch/Throw mechanism that is not really necessary (artifact of some experimentation that I did not bother to remove).
--- edit ---
The code below has modest changes from what I originally posted. It separates the center of gravity circle as the red one.
To handle the constraint that it lie at some specified angle, one might generate as below, rotate to put into the correct angular position, and recheck distances from circles to frame boundary. Possibly there is something smarter that will be less likely to give a rejection, while still maintaining uniformity. Actually I'm not at all certain that what I coded gives a uniform distribution from the space of allowable configurations. If it does, the influence of rotating will very likely destroy that property.
--- end edit ---
randomConfiguration[{xlo_, ylo_}, {xhi_, yhi_}, nsmall_, nlarge_,
rsmall_, rlarge_, minsep_] := Catch[Module[
{found = False, xsmall, ysmall, xlarge, ylarge, smallsep, largesep,
smallcircs, largecircs, cog, cen, indx = 0},
smallsep = {rsmall + minsep, -rsmall - minsep};
largesep = {rlarge + minsep, -rlarge - minsep};
cen = {xhi - xlo, yhi - ylo};
While[! found,
found = True;
indx++;
xsmall = RandomReal[{xlo, xhi} + smallsep, nsmall];
ysmall = RandomReal[{ylo, yhi} + smallsep, nsmall];
xlarge = RandomReal[{xlo, xhi} + largesep, nlarge];
ylarge = RandomReal[{ylo, yhi} + largesep, nlarge];
smallcircs = Transpose[{xsmall, ysmall}];
Do[If[
Norm[smallcircs[[i]] - smallcircs[[j]]] <= 2*rsmall + minsep,
found = False; Break[]], {i, nsmall - 1}, {j, i + 1, nsmall}];
largecircs = Transpose[{xlarge, ylarge}];
Do[If[
Norm[largecircs[[i]] - largecircs[[j]]] <= 2*rlarge + minsep,
found = False; Break[]], {i, nlarge - 1}, {j, i + 1, nlarge}];
Do[If[
Norm[smallcircs[[i]] - largecircs[[j]]] <=
rsmall + rlarge + minsep, found = False; Break[]], {i,
nsmall}, {j, nlarge}];
cog = (rsmall^2*Total[smallcircs] +
rlarge^2*Total[largecircs])/(nsmall*rsmall^2 +
nlarge*rlarge^2);
If[Norm[cog - cen] <= 2*minsep, found = False;];
];
Print[indx];
Throw[{{cog, rsmall},Map[{#, rsmall} &, smallcircs],
Map[{#, rlarge} &, largecircs]}]
]]
Example:
{smallc, largec} =
randomConfiguration[{4.32, 3.23}, {35.68, 26.75}, 5, 3, 1, 2, 1];
13
FraXYs = {{4.32, 3.23}, {35.68, 26.75}};
{cog, smallc, largec} =
randomConfiguration[{4.32, 3.23}, {35.68, 26.75}, 5, 3, 1, 2, 1];
Graphics[{White, EdgeForm[Thick], Rectangle ## FraXYs, Red,
Apply[Disk, cog], Blue, Opacity[.6], EdgeForm[Black], Blue,
Thickness[0.003], Opacity[1], Black,
Disk[#[[1]], #[[2]]] & /# Join[smallc, largec]},
ImageSize -> {400, 300}]
I am doing this:
ClearAll[matrix];
matrix[p_,q_,nu_:0]:=Module[{sigma},
sigma=p/q;
N#SparseArray[
{{m_,m_}\[Rule]2Cos[2\[Pi]*m*p/q+nu],{i_,j_}/;
Abs[i-j]\[Equal]1\[Rule]1},{q,q}]]
ClearAll[attachsigma]
attachsigma[sigma_,lst_]:={sigma,#}&/#lst
and then execute
fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates;
pq = {Numerator##, Denominator##} & /# fracs;
(ens = Eigenvalues[#] & /#
Normal /# (matrix[#[[1]], #[[2]]] & /# pq);) // Timing
pts = Flatten[#, 1] &#MapThread[attachsigma, {fracs, ens}];
and finally I plot the points as follows (here is the real point of the question):
plot = ListPlot[pts,
PlotMarkers \[Rule] Graphics[{PointSize[Tiny], Point[{0, 0}]}]]
Calculating all the points takes around around 2.6s on my machine, but the plot takes around 25s. If, on the other hand, I plot it like this
ListPlot[pts]
then it is almost instantaneous, as it should (it's just 5256 points). So, it seems PlotMarkers slows things down immensely.
Could anybody
a) explain why (this much I vaguely understand, in analogy with what happens to Sort if you give it custom ordering function) and, more importantly,
b) explain how to avoid this slowdown? I am trying to create plots with quite a bit more points than this so they're really slow; in addition, I am creating lots of them (a movie actually).
One solution would be to not plot all of them, but as I vary parameters it becomes nontrivial to find out which I should include and which not (this would of course work if I only needed this one frame). So, I'd like to speed up the plot creation without removing points.
EDIT: Answered after hints from Sjoerd:
ListPlot[pts] /. Point[List[x___]] \[RuleDelayed] {PointSize[Tiny], Point[List[x]]}
produces the right thing instantaneously. This simply replaces the Points inside the Graphics structure by smaller points by hand.
Now one can increase the upper limit in the table in fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates to 80 or so to get many more points (this thing is the Hofstadter butterfly, and it's a fractal):
PlotMarkers is meant for data plots that contain relatively few points. It is very useful in plots in which you use the markers to identify various conditions. Each individual marker is an Inset as follows:
Inset[Graphics[List[Hue[0.67`,0.6,0.6`],PointSize[Tiny],Point[List[0, 0]]]],10512].
You can imagine this takes up some time and memory.
I also found what seems to be a bug. The plot with PlotMarkers is structured as GraphicsComplex[pointlist,graphicsinstructions]. This point list seems to contain the points in the plot twice!
In[69]:= pts // Length
Out[69]= 5256
In[66]:= plot[[1, 1]] // Length
Out[66]= 10512
In[64]:= Union[plot[[1, 1]]] == Union[pts]
Out[64]= True
In[68]:= Tally[plot[[1, 1]]][[All, 2]] // Mean (*the average number each point occurs*)
Out[68]= 2
Personally, I prefer Graphics to ListPlot, especially when the number of points is large.
Graphics[{Hue[{2/3, 1, 1, .5}], AbsolutePointSize[1.5], Point#pts},
PlotRange -> {{0, 1}, {-4, 4}}, Axes -> False,
AspectRatio -> 1/GoldenRatio]
gives, for example:
Length#pts
102969
I believe the solution you appended to your question can be simplified:
ListPlot[pts] /. x_Point :> {PointSize[Tiny], x}
I voted for both prior answers, but I agree with TomD on the direct use of Graphics.
I am trying to use computer to show some planar geometry plots. I donot know what software can do this, or whether mathematica can produce such plots easily.
For example, I have the following plot to show.
Given any triangle ABC, let AD be the line bisecting angle BAC and intersecting BC at D. Let M be the midpoint of AD. Let the circle whose diameter is AB intersects CM at F.
How to produce these plots and show the relevant labeling of the points in mma? Is it easy to do? Could someone please give an example, or give some recommendation as to what software is best suited for this purposes?
Many thanks.
Here you have your graph done with Geometry Expressions in two minutes. It has many nice features, including elemental geometry calculations and an interface for exporting formulas to Mathematica.
The formula in the drawing was calculated by the program.
Free to use, $79 - $99 to be able to save.
Here's a very quick solution using GeoGebra to the problem you described.
It is the first time I've used GeoGebra and this took me about 20mins to make - so the program is quite well made and intuitive.
What's more, it can export to dynamic, java based, webpages. Here's the one for the problem you specified: TriangleCircle.
Edit
For Mathematica demonstrations, there are lots of good examples at Plane Geometry.
From this page, I found other software such as Cabri Geometry and The Geometer's Sketchpad.
I thought I'd show how one might approach this in Mathematica. While not the simplest thing to code, it does have flexibility. Also bear in mind that the author is fairly inept when it comes to graphics, so there might be easier and/or better ways to go about it.
offset[pt_, center_, eps_] := center + (1 + eps)*(pt - center);
pointfunc[{pt_List, center_List, ptname_String}, siz_,
eps_] := {PointSize[siz], Point[pt],
Inset[ptname, offset[pt, center, eps]]};
Manipulate[Module[
{plot1, plot2, plot3, siz = .02, ab = bb - aa, bc = cc - bb,
ac = cc - aa, cen = (aa + bb)/2., x, y, soln, dd, mm, ff, lens,
pts, eps = .15},
plot1 = ListLinePlot[{aa, bb, cc, aa}];
plot2 = Graphics[Circle[cen, Norm[ab]/2.]];
soln = NSolve[{Norm[ac]*({x, y} - aa).ab -
Norm[ab]*({x, y} - aa).ac ==
0, ({x, y} - cc).({-1, 1}*Reverse[bc]) == 0}, {x, y}];
dd = {x, y} /. soln[[1]];
mm = (dd + aa)/2;
soln = NSolve[{({x, y} - cen).({x, y} - cen) - ab.ab/4 ==
0, ({x, y} - cc).({-1, 1}*Reverse[mm - cc]) == 0}, {x, y}];
ff = {x, y} /. soln;
lens = Map[Norm[# - cc] &, ff];
ff = If[OrderedQ[lens], ff[[1]], ff[[2]]];
pts = {{aa, cen, "A"}, {bb, cen, "B"}, {cc, cen, "C"}, {dd, cen,
"D"}, {ff, cen, "F"}, {mm, cen, "M"}, {cen, ff, "O"}};
pts = Map[pointfunc[#, siz, eps] &, pts];
plot3 = Graphics[Join[pts, {Line[{aa, dd}], Line[{cc, mm}]}]];
Show[plot1, plot2, plot3, PlotRange -> {{-.2, 1.1}, {-.2, 1.2}},
AspectRatio -> Full, Axes -> False]],
{{aa, {0, 0}}, {0, 0}, {1, 1}, Locator},
{{bb, {.8, .7}}, {0, 0}, {1, 1}, Locator},
{{cc, {.1, 1}}, {0, 0}, {1, 1}, Locator},
TrackedSymbols :> None]
Here is a screen shot.
Daniel Lichtblau
Wolfram Research
Mathematica isn't the best software for this, although it will work out.
http://demonstrations.wolfram.com/DrawingATriangle/ has source code for a really nice triangle, and following that example you can add a bisecting line to the code.
As already stated, Mathematica is not the best software for this. There are several better options that you can use, depending on your exact purpose. To generate such figures programatically, there are several languages especially adapted for such tasks. I would recommend to try eukleides or GCLC. If you have any experience with TeX/LaTeX, you may want to look at metapost or asymptote, or even a LaTeX package such as tkz-euklide.
If you on the other hand prefer to create you drawings in an interactive way, there are number of programs available. Search the web for "dynamic geometry software", you should get a number of hits. Of those I would most recommend geogebra.
I thought that I should really attempt this problem in Mathematica (only once I finished did I see Daniel's solution). It took me about half an hour - which is longer than my GeoGebra solution, despite the fact that I'd never used GeoGebra before.
The code is not as fast as it could be. This is because I was too lazy to code up proper code for finding intersections of lines and circles, so I just used the slower but more general FindInstance.
A quite comprehensive plane geometry package can be found as part of Eric Weinstein's MathWorld packages. It includes all the intersection, bisection etc... code that you could possibly want, but it would take a little bit of time to learn it all.
angleBisector[A_,{B_,C_}]:=Module[{ba=Norm[B-A],ca=Norm[C-A],m},
m=A+((B-A)/ba+(C-A)/ca)]
intersect[Line[{A_,B_}],Line[{C_,D_}]]:=Module[{s,t},
A + s(B-A)/.First#FindInstance[A + s(B-A) == C + t(D-C), {s,t}]]
intersect[Line[{A_,B_}],Circle[p0:{x0_,y0_},r_]]:=Module[{s,x,y},
A + s(B-A)/.FindInstance[A + s(B-A) == {x,y}
&& Norm[p0-{x,y}] == r, {s,x,y}, Reals, 2]]
Manipulate[Module[{OO,circ,tri,angB,int,mid,FF},
OO=(AA+BB)/2;
circ=Circle[OO,Norm[AA-BB]/2];
tri=Line[{AA,BB,CC,AA}];
angB=angleBisector[AA,{BB,CC}];
int=intersect[Line[{BB,CC}],Line[{AA,angB}]];
mid=(AA+int)/2;
FF=intersect[Line[{CC,mid}],Circle[OO,Norm[AA-BB]/2]];
Graphics[{PointSize[Large],Point[{OO,int,mid}],Point[FF],tri,circ,
Line[{AA,AA+3(angB-AA)}],Line[{CC,CC+3(mid-CC)}],
Text["A",AA,{2,-2}],Text["B",BB,{-2,-2}],Text["C",CC,{2,2}],
Text["O",OO,{0,-2}],Text["D",int,{-2,-1}],Text["M",mid,{-2,-1}]},
PlotRange->{{-2,2},{-2,2}}]],
{{AA,{-1,1}},Locator},
{{BB,{1,1}},Locator},
{{CC,{0,-1}},Locator}]