Related
I'm trying to write a program in Mathematica that will simulate the way charged ball bearings spread out when they are charged with like charges (they repel each other). My program so far keeps the ball bearings from moving off the screen, and counts the number of times they hit the side of the box. I have the ball bearings moving randomly around the box so far, but I need to know how to make them repel each other.
Here's my code so far:
Manipulate[
(*If the number of points has been reduced, discard points*)
If[ballcount < Length[contents],
contents = Take[contents, ballcount]];
(*If the number of points has been increased, generate some random points*)
If[ballcount > Length[contents],
contents =
Join[contents,
Table[{RandomReal[{-size, size}, {2}], {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}, {ballcount - Length[contents]}]]];
Grid[{{Graphics[{PointSize[0.02],
(*Draw the container*)
Line[size {{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}],
Blend[{Blue, Red}, charge/0.3],
Point[
(*Start the main dynamic actions*)
Dynamic[
(*Reset the collision counter*)
collision = 0;
(*Check for mouse interaction and add points if there has been one*)
Refresh[
If[pt =!= lastpt, If[ballcount =!= 50, ballcount++];
AppendTo[
contents, {pt, {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}]; lastpt = pt],
TrackedSymbols -> {pt}];
(*Update the position of the points using their velocity values*)
contents = Map[{#[[1]] + #[[2]] charge, #[[2]]} &, contents];
(*Check for and fix points that have exceeded the box in Y
direction, incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 2]]] > size,
collision++; {{#[[1, 1]],
2 size Sign[#[[1, 2]]] - #[[1, 2]]}, {1, -1} #[[
2]]}, #] &,
contents];
(*Check for and fix points that have exceeded the box in X
direction, incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 1]]] > size,
collision++; {{2 size Sign[#[[1, 1]]] - #[[1, 1]], #[[1,
2]]}, {-1, 1} #[[2]]}, #] &,
contents];
hits = Take[PadLeft[Append[hits, collision/size], 200], 200];
Map[First, contents]]]},
PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}},
ImageSize -> {250, 250}],
(*Show the hits*)
Dynamic#Show
[
ListPlot
[
Take[MovingAverage[hits, smooth], -100
]
,
Joined -> True, ImageSize -> {250, 250}, AspectRatio -> 1,
PlotLabel -> "number of hits", AxesLabel -> {"time", "hits"},
PlotRange -> {0, Max[Max[hits], 1]}], Graphics[]
]
}}
]
,
{{pt, {0, 1}}, {-1, -1}, {1, 1}, Locator, Appearance -> None},
{{ballcount, 5, "number of ball bearings"}, 1, 50, 1},
{{charge, 0.05, "charge"}, 0.002, 0.3},
{smooth, 1, ControlType -> None, Appearance -> None},
{size, 1, ControlType -> None, Appearance -> None},
{hits, {{}}, ControlType -> None},
{contents, {{}}, ControlType -> None},
{lastpt, {{0, 0}}, ControlType -> None}
]
What you need for your simulation is a "collision detection algorithm". The field of those algorithms is widespread since it is as old as computer games (Pong) are and it is impossible to give a complete answer here.
Your simulation as it is now is very basic because you advance your charged balls every time step which makes them "jump" from position to position. If the movement is as simple as it is with the constant velocity and zero acceleration, you know the exact equation of the movement and could calculate all positions by simply putting the time into the equations. When a ball bounces off the wall, it gets a new equation.
With this, you could predict, when two balls will collide. You simply solve for two balls, whether they have at the same time the same position. This is called A Priori detection. When you take your simulation as it is now, you would have to check at every timestep, whether or not two balls are so close together, that they may collide.
The problem there is, that your simulation speed is not infinitely high and the faster your balls are, the bigger the jumps in your simulation. It is then not unlikely, that two balls over-jump each other and you miss a collision.
With this in mind, you could start by reading the Wikipedia article to that topic, to get an overview. Next, you could read some scientific articles about it or check out, how the cracks do it. The Chipmunk physics engine for instance is an amazing 2d-physics engine. To ensure that such stuff works, I'm pretty sure they had to put a lot thoughts in their collision detection.
I can't do the detection part since that is a project on its own. But it seems now the interaction is faster, you had few Dynamics which were not needed. (if you see the side of the cell busy all the time, this always mean a Dynamic is busy where it should not be).
I also added a STOP/START button. I could not understand everything you were doing, but enough to make the changes I made. You are also using AppendTo everything. You should try to allocate contents before hand, and use Part[] to access it, would be much faster, since you seem to know the maximum points allowed?
I like to spread the code out more, this helps me see the logic more.
Here is a screen shot, and the updated version code is below. Hope you find it faster.
Please see code below, in update (1)
Update (1)
(*updated version 12/30/11 9:40 AM*)
Manipulate[(*If the number of points has been reduced,discard points*)
\
Module[{tbl, rand, npt, ballsToAdd},
If[running,
(
tick += $MachineEpsilon;
If[ballcount < Length[contents],
contents = Take[contents, ballcount]];
(*If the number of points has been increased,
generate some random points*)
If[ballcount > Length[contents],
(
ballsToAdd = ballcount - Length[contents];
tbl =
Table[{RandomReal[{-size, size}, {2}], {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}, {ballsToAdd}];
contents = Join[contents, tbl]
)
];
image = Grid[{
{LocatorPane[Dynamic[pt], Graphics[{
PointSize[0.02],(*Draw the container*)
Line[size {{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}],
Blend[{Blue, Red}, charge/0.3],
Point[(*Start the main dynamic actions*)
(*Reset the collision counter*)
collision = 0;
(*Check for mouse interaction and add points if there has \
been one*)
If[EuclideanDistance[pt, lastpt] > 0.001, (*adjust*)
(
If[ballcount < MAXPOINTS,
ballcount++
];
rand = RandomReal[{0, 2 \[Pi]}];
npt = {Cos[rand], Sin[rand]};
AppendTo[contents, {pt, npt} ];
lastpt = pt
)
];
(*Update the position of the points using their velocity \
values*)
contents =
Map[{#[[1]] + #[[2]] charge, #[[2]]} &, contents];
(*Check for and fix points that have exceeded the box in \
Y direction,incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 2]]] > size,
(
collision++;
{{#[[1, 1]],
2 size Sign[#[[1, 2]]] - #[[1, 2]]}, {1, -1} #[[2]]}
),
(
#
)
] &, contents
];
(*Check for and fix points that have exceeded the box in \
X direction,
incrementing the collision counter for each one*)
contents =
Map[If[Abs[#[[1, 1]]] > size,
collision++; {{2 size Sign[#[[1, 1]]] - #[[1, 1]], #[[
1, 2]]}, {-1, 1} #[[2]]}, #] &, contents
];
hits = Take[PadLeft[Append[hits, collision/size], 200],
200];
Map[First, contents]
]
},
PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}},
ImageSize -> {250, 250}
], Appearance -> None
],(*Show the hits*)
Show[ListPlot[Take[MovingAverage[hits, smooth], -100],
Joined -> True, ImageSize -> {250, 250}, AspectRatio -> 1,
PlotLabel -> "number of hits", AxesLabel -> {"time", "hits"},
PlotRange -> {0, Max[Max[hits], 1]}
]
]
}
}
]
)
];
image
],
{{MAXPOINTS, 50}, None},
{pt, {{0, 1}}, None},
{{ballcount, 5, "number of ball bearings"}, 1, MAXPOINTS, 1,
Appearance -> "Labeled", ImageSize -> Small},
{{charge, 0.05, "charge"}, 0.002, 0.3, Appearance -> "Labeled",
ImageSize -> Small},
Row[{Button["START", {running = True; tick += $MachineEpsilon}],
Button["STOP", running = False]}],
{{tick, 0}, None},
{smooth, 1, None},
{size, 1, None},
{hits, {{}}, None},
{{contents, {}}, None},
{lastpt, {{0, 0}}, None},
{{collision, 0}, None},
{image, None},
{{running, True}, None},
TrackedSymbols -> { tick},
ContinuousAction -> False,
SynchronousUpdating -> True
]
Given that g is a graphics object with primitives such as Lines and Polygons, how do you remove some of them? To add more primitives to an existing graphics object we can use Show, for instance: Show[g, g2] where g2 is another graphics object with other primitives. But how do you remove unwanted primitive objects? Take a look at the following
ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
Now, for the input form:
InputForm[
ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
]
To create a wire frame from this object all we have to do is remove the polygons. As an extra we can also remove the vertex normals since they don't contribute to the wireframe.
Notice that to make a wireframe we can simply set PlotStyle -> None as an option in ListPlot3D. This gets rid of the Polygons but doesn't remove the VertexNormals.
To clarify the question. Given that
g = ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
How do you remove some of the of the graphics primitives from g and how do you remove some of the options, i.e. VertexNormals? Note: option VertexNormals is an option of GraphicsComplex.
If this is not possible then maybe the next question would be, how do you obtain the data used to generate g to generate a new graphics object with some of the data obtained from g.
One way is to use transformation rules. Given your
im = ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
You can do
newim = im /. {_Polygon :> Sequence[], (VertexNormals -> _) :> Sequence[]}
or, more compactly using Alternatives:
newim = im /. _Polygon | (VertexNormals -> _) :> Sequence[]
You could also use DeleteCases to get a similar effect:
newim = DeleteCases[im, (_Polygon | (VertexNormals -> _)), Infinity]
What is the simplest way to create a row/column/grid of plots, with the whole grid having a single FrameLabel?
I need something similar to this:
p := ListPlot[RandomInteger[10, 5], Joined -> True, Axes -> False,
Frame -> True, PlotRange -> {0, 11},
FrameLabel -> {"horizontal", None}, AspectRatio -> 1]
GraphicsRow[{Show[p, FrameLabel -> {"horizontal", "vertical"}], p, p}]
For a row format, it could have one or multiple horizontal labels, but only one vertical one.
Issues to consider:
Vertical scale must match for all plots, and must not be ruined by e.g. a too long label or automatic PlotRangePadding.
Good (and resize-tolerant!) control of inter-plot spacing is needed (after all, this is one of the motivations behind removing the redundant labels)
General space-efficiency of the arrangement. Maximum content, minimum (unnecessary) whitespace.
EDIT
I'm trying to be able to robustly create print ready figures, which involves a lot of resizing. (Because the exported PDFs will usually not have the same proportions as what I see in the notebook, and must have readable but not oversized fonts)
You can use LevelScheme to achieve what you want. Here's an example:
<< "LevelScheme`"
Figure[{
Multipanel[{{0, 1}, {0, 1}}, {1, 3},
XFrameLabels -> textit["x"], BufferB -> 3,
YFrameLabels -> textit["Sinc(x)"], BufferL -> 3,
TickFontSize -> 9,
XGapSizes -> {0.1, 0.1},
PanelLetterCorner -> {1, 1}
],
FigurePanel[{1, 1}, PlotRange -> {{-1.6, -0.6}, {-0.5, 1}}],
RawGraphics[Plot[Sinc[20 x], {x, -1.6, -0.6}]],
FigurePanel[{1, 2}, PlotRange -> {{-0.5, 0.5}, {-0.5, 1}}],
RawGraphics[Plot[Sinc[20 x], {x, -0.5, 0.5}]],
FigurePanel[{1, 3}, PlotRange -> {{0.6, 1.6}, {-0.5, 1}}],
RawGraphics[Plot[Sinc[20 x], {x, 0.6, 1.6}]]
},
PlotRange -> {{-0.1, 1.02}, {-0.12, 1.095}}]
LevelScheme offers you tremendous flexibility in the arrangement of your plot.
Instead of naming giving the plot common labels, you can move the definition inside the FigurePanel[] and control the labels for each one individually.
You can set inter-plot spacings both in the X and Y directions and also change the sizes of each panel, for e.g., the left one can take up 2/3 of the space and the next two just 1/6 of the space each.
You can set individual plot ranges, change the frame tick labels for each, control which side of the panel (top/bottom/l/r) the labels should be marked, change panel numberings, etc.
The only drawback is that you might have to wrestle with it in some cases, but in general, I've found it a pleasure to use.
EDIT
Here's one similar to your example:
Figure[{
Multipanel[{{0, 1}, {0, 1}}, {1, 3},
YFrameLabels -> textit["Vertical"], BufferL -> 3,
TickFontSize -> 9,
XGapSizes -> {0.1, 0.1},
PanelLetterCorner -> {1, 1}
],
FigurePanel[{1, 1}, PlotRange -> {{1, 10}, {0, 10}}],
RawGraphics[ListLinePlot[RandomInteger[10, 10]]],
FigurePanel[{1, 2}, PlotRange -> {{1, 10}, {0, 10}},
LabB -> textit["Horizontal"], BufferB -> 3],
RawGraphics[ListLinePlot[RandomInteger[10, 10]]],
FigurePanel[{1, 3}, PlotRange -> {{1, 10}, {0, 10}}],
RawGraphics[ListLinePlot[RandomInteger[10, 10]]]
},
PlotRange -> {{-0.1, 1.02}, {-0.2, 1.095}}]
EDIT 2
To answer Mr. Wizard's comment, here's a blank template for a 2x3 grid
Figure[{Multipanel[{{0, 1}, {0, 1}}, {2, 3},
XFrameTicks -> None,
YFrameTicks -> None,
XGapSizes -> {0.1, 0.1},
YGapSizes -> {0.1}],
FigurePanel[{1, 1}],
FigurePanel[{1, 2}],
FigurePanel[{1, 3}],
FigurePanel[{2, 1}],
FigurePanel[{2, 2}],
FigurePanel[{2, 3}]
}, PlotRange -> {{-0.01, 1.01}, {-0.01, 1.01}}]
And here's one with extended panels
Figure[{Multipanel[{{0, 1}, {0, 1}}, {2, 3},
XFrameTicks -> None,
YFrameTicks -> None,
XGapSizes -> {0.1, 0.1},
YGapSizes -> {0.1}],
FigurePanel[{1, 1}, PanelAdjustments -> {{0, 0}, {1.1, 0}}],
FigurePanel[{1, 2}],
FigurePanel[{1, 3}],
FigurePanel[{2, 2}, PanelAdjustments -> {{0, 1.1}, {0, 0}}]
}, PlotRange -> {{-0.01, 1.01}, {-0.01, 1.01}}]
You already know how to handle multiple horizontal labels through ListPlot.
You can get single labels by using Panel. For example...
p := ListPlot[RandomInteger[10, 5], Joined -> True, Axes -> False,
Frame -> True, PlotRange -> {0, 11}, AspectRatio -> 1]
Panel[GraphicsRow[{p, p, p}], {"horizontal",Rotate["vertical", Pi/2]},
{Bottom, Left}, Background -> White]
You can optionally include labels on Top and Right edges too.
Here is one option I just put together. Its advantage is that it is simple.
I like the look of yoda's LevelScheme plots better, assuming those can be done for a grid as well.
p := ListPlot[RandomInteger[10, 5], Joined -> True, Axes -> False,
Frame -> True, PlotRange -> {0, 11}, AspectRatio -> 1]
gg = GraphicsGrid[{{p, p, p}, {p, p, p}, Graphics /# Text /# {"Left", "Center", "Right"}},
Spacings -> 5, ItemAspectRatio -> {{1, 1, 0.15}}];
Labeled[gg, Rotate["vertical", Pi/2], Left]
When I run the following code
pMin = {-3, -3};
pMax = {3, 3};
range = {pMin, pMax};
Manipulate[
GraphicsGrid[
{
{Graphics[Locator[p], PlotRange -> range]},
{Graphics[Line[{{0, 0}, p}]]}
}, Frame -> All
],
{{p, {1, 1}}, Locator}
]
I expect the Locator control to be within the bounds of the first Graph, but instead it can be moved around the whole GraphicsGrid region. Is there an error in my code?
I also tried
{{p, {1, 1}}, pMin, pMax, Locator}
instead of
{{p, {1, 1}}, Locator}
But it behaves completely wrong.
UPDATE
Thanks to everyone, this is my final solution:
Manipulate[
distr1 = BinormalDistribution[p1, {1, 1}, \[Rho]1];
distr2 = BinormalDistribution[p2, {1, 1}, \[Rho]2];
Grid[
{
{Graphics[{Locator[p1], Locator[p2]},
PlotRange -> {{-5, 5}, {-5, 5}}]},
{Plot3D[{PDF[distr1, {x, y}], PDF[distr2, {x, y}]}, {x, -5, 5}, {y, -5, 5}, PlotRange -> All]}
}],
{{\[Rho]1, 0}, -0.9, 0.9}, {{\[Rho]2, 0}, -0.9, 0.9},
{{p1, {1, 1}}, Locator},
{{p2, {1, 1}}, Locator}
]
UPDATE
Now the problem is that I cannot resize and rotate the lower 3d graph. Does anyone know how to fix that?
I'm back to the solution with two Slider2D objects.
If you examine the InputForm you'll find that GraphicsGrid returns a Graphics object. Thus, the Locator indeed moves throughout the whole image.
GraphicsGrid[{{Graphics[Circle[]]}, {Graphics[Disk[]]}}] // InputForm
If you just change the GraphicsGrid to a Grid, the locator will be restricted to the first part but the result still looks a bit odd. Your PlotRange specification is a bit strange; it doesn't seem to correspond to any format specified in the Documentation center. Perhaps you want something like the following.
Manipulate[
Grid[{
{Graphics[Locator[p], Axes -> True,
PlotRange -> {{-3, 3}, {-3, 3}}]},
{Graphics[Line[{{0, 0}, p}], Axes -> True,
PlotRange -> {{-3, 3}, {-3, 3}}]}},
Frame -> All],
{{p, {1, 1}}, Locator}]
LocatorPane[] does a nice job of confining the locator to a region.
This is a variation on the method used by Mr. Wizard.
Column[{ LocatorPane[Dynamic[pt3],
Framed#Graphics[{}, ImageSize -> 150, PlotRange -> 3]],
Framed#Graphics[{Line[{{-1, 0}, Dynamic#pt3}]}, ImageSize -> {150, 150},
PlotRange -> 3]}]
I would have assumed that you'd want the locator to share the space with the line it controls. In fact, to be "attached" to the line. This turns out to be even easier to implement.
Column[{LocatorPane[Dynamic[pt3],Framed#Graphics[{Line[{{-1, 0}, Dynamic#pt3}]},
ImageSize -> 150, PlotRange -> 3]]}]
I am not sure what you are trying to achieve. There are a number of problems I see, but I don't know what to address. Perhaps you just want a simple Slider2D construction?
DynamicModule[{p = {1, 1}},
Column#{Slider2D[Dynamic[p], {{-3, -3}, {3, 3}},
ImageSize -> {200, 200}],
Graphics[Line[{{0, 0}, Dynamic[p]}],
PlotRange -> {{-3, 3}, {-3, 3}}, ImageSize -> {200, 200}]}]
This is a reply to the updated question about 3D graphic rotation.
I believe that LocatorPane as suggested by David is a good way to approach this. I just put in a generic function since your example would not run on Mathematica 7.
DynamicModule[{pt = {{-1, 3}, {1, 1}}},
Column[{
LocatorPane[Dynamic[pt],
Framed#Graphics[{}, PlotRange -> {{-5, 5}, {-5, 5}}]],
Dynamic#
Plot3D[{x^2 pt[[1, 1]] + y^2 pt[[1, 2]],
-x^2 pt[[2, 1]] - y^2 pt[[2, 1]]},
{x, -5, 5}, {y, -5, 5}]
}]
]
I have a graphical object which is moving along a trajectory. How can I make the camera follow the object?
Let's draw a planet and its satellite, with the camera following the moon from a view directed toward the Earth. For example:
a = {-3.5, 3.5};
Animate[
Show[
Graphics3D[
Sphere[3 {Cos#t, Sin#t, 0}, .5],
ViewPoint -> 3.5 {Cos#t, Sin#t, 0},
SphericalRegion -> True,
PlotRange -> {a, a, a}, Axes -> False, Boxed -> False],
myEarth],
{t, 0, 2 Pi}]
Where myEarth is another 3D Graphics (for reference).
Static vertical view:
a = {-3.5, 3.5};
Animate[
Show[
Graphics3D[
Sphere[3 {Cos#t, Sin#t, 0}, .5],
ViewPoint -> 3.5 {0,0,1},
SphericalRegion -> True,
PlotRange -> {a, a, a}, Axes -> False, Boxed -> False],
myEarth],
{t, 0, 2 Pi}]
The trick is SphericalRegion -> True, without it the image perspective "moves" from frame to frame.
Edit
With two static objects:
Since the question asks about 2D, here's how you can emulate a camera in 2D Graphics.
First, let's get the stackoverflow favicon.ico:
so = First#Import["http://sstatic.net/stackoverflow/img/favicon.ico"]
Well put this on top of some overlapping circles and make the "camera" follow the icon around by adjusting the PlotRange
Manipulate[Graphics[{
Table[Circle[{j, 0}, i], {i, 0, 1, .1}, {j, {-.5, .5}}],
Inset[so, pos, {0, 0}, .2]},
PlotRange -> {{-.5, .5}, {-.5, .5}} + pos],
{{pos, {0, 0}, ""}, {-1.4, -1}, {1.4, 1}, ControlPlacement -> Left}]
To show how it works (with out putting the above into Mathematica), we need to animate it.
Originally I chose a variable step random walk drunk = Accumulate[RandomReal[{-.1, .1}, {200, 2}]] but it was a unpredictable! So instead, we'll make the icon follow the ABC logo
drunk = Table[{1.5 Sin[t], Cos[3 t]}, {t, 0, 2 Pi, .1}];
Animate[Graphics[{
Table[Circle[{j, 0}, i], {i, 0, 1, .1}, {j, {-.5, .5}}],
Inset[so, drunk[[pos]], {0, 0}, .2]},
PlotRange -> {{-.5, .5}, {-.5, .5}} + drunk[[pos]]],
{pos, 1, Length[drunk], 1}]