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
]
Please consider :
colors = {Red, Green, Blue};
style = {Thickness[.01], Thickness[.01], Thickness[.01]};
cAxes = {{{0, 0, 0}, {0, 0, 1}}, {{0, 0, 0}, {0, 1, 0}}, {{0, 0,
0}, {1, 0, 0}}};
Graphics3D[{{#1, #2, Line##3} & ### Transpose#{colors, style, cAxes},
Blue, Specularity[White, 3], Sphere[{.5, .5, .5}, .1]},
Boxed -> False, FaceGrids -> All,
FaceGridsStyle -> Directive[Black, Dashed]]
Using Yoda`s solution on How to Style Lines
How could I color the Sphere using GrayLevel (I will manipulate it later).
And How could I have denser FaceGrids ? 10 Lines horizontally & Vertically. I also don`t understand why the Edges one are distant to one another.
It's always good practice to group the graphics object and its styles in a list, in case you need to quickly add another one with different styles. By that, I mean write it as {Blue, Specularity[White, 3], Sphere[{.5, .5, .5}, .1]}. Now you can easily add a GrayLevel term before Sphere and it'll work.
For the FaceGrids, I believe you'll have to manually define the lines at your desired spacing for each face. Here's an example for showing how to do it for one face.
Graphics3D[{{#1, #2, Line##3} & ###
Transpose#{colors, style, cAxes}, {Blue, GrayLevel[0.3], Lighting -> "Neutral",
Specularity[White, 3], Sphere[{.5, .5, .5}, .1]}}, Boxed -> False,
FaceGrids -> {{{0, 0, 1},
Transpose#({#, #} & /# Range[0, 1, 0.1])}},
FaceGridsStyle -> Directive[Black, Dashed]]
The faces are defined as ±1 for the corresponding plane and the other two are zero. So {0,0,1} in my example corresponds to the z=1 plane.
The list supplied to FaceGrids can be easily computed for each face, instead of manually entering them, but I'll leave that to you :)
EDIT:
Since you want a uniform mesh all around, define where you want the grid lines drawn as
gridList = Transpose#({#, #} & /# Range[0, 1, 0.1]);
Then, use the following for FaceGrids:
FaceGrids -> Join ## Table[{RotateLeft[j {0, 0, 1}, i], gridList},
{i, {0, 1, 2}}, {j, {-1, 1}}]
Here's how the result should look like with PlotRangePadding -> None:
In addition to Yoda's response:
Lighting -> "Neutral" will allow grayscale object to show up as gray instead of with various colors.
PlotRangePadding -> None will remove the spaces on the grid lines (depending on the setting for PlotRange.)
Yoda beat me to typing out the FaceGrids setting (see documentation). But here is an alternative.
Instead of setting the FaceGrids setting explicitly, youcould also try setting FrameTicks, since by default the FaceGrids follow these, and then style the FrameTicks to be invisible using Opacity.
I have already checked all the examples and settings in the Mathematica documentation center, but couldn't find any example on how to choose the numbers that will be shown on the axes.
How do I change plot axis numbering like 2,4,6,.. to PI,2PI,3PI,...?
Howard has already given the correct answer in the case where you want the labels Pi, 2 Pi etc to be at the values Pi, 2 Pi etc.
Sometimes you might want to use substitute tick labels at particular values, without rescaling data.
One of the other examples in the documentation shows how:
Plot[Sin[x], {x, 0, 10},
Ticks -> {{{Pi, 180 \[Degree]}, {2 Pi, 360 \[Degree]}, {3 Pi,
540 \[Degree]}}, {-1, 1}}]
I have a suite of small custom functions for formatting Ticks the way I want them. This is probably too much information if you are just starting out, but it is worth knowing that you can use any number format and substitute anything into your ticks if desired.
myTickGrid[min_, max_, seg_, units_String, len_?NumericQ,
opts : OptionsPattern[]] :=
With[{adj = OptionValue[UnitLabelShift], bls = OptionValue[BottomLabelShift]},
Table[{i,
If[i == max,
DisplayForm[AdjustmentBox[Style[units, LineSpacing -> {0, 12}],
BoxBaselineShift -> If[StringCount[units, "\n"] > 0, adj + 2, adj]]],
If[i == min,
DisplayForm#AdjustmentBox[Switch[i, _Integer,
NumberForm[i, DigitBlock -> 3,
NumberSeparator -> "\[ThinSpace]"], _, N[i]],
BoxBaselineShift -> bls],
Switch[i, _Integer, NumberForm[i, DigitBlock -> 3,
NumberSeparator -> "\[ThinSpace]"], _, N[i]]]], {len, 0}}, {i,
If[Head[seg] === List, Union[{min, max}, seg], Range[min, max, seg]]}]]
And setting:
Options[myTickGrid] = {UnitLabelShift -> 1.3, BottomLabelShift -> 0}
SetOptions[myTickGrid, UnitLabelShift -> 1.3, BottomLabelShift -> 0]
Example:
Plot[Erfc[x], {x, -2, 2}, Frame -> True,
FrameTicks -> {myTickGrid[-2, 2, 1, "x", 0.02, UnitLabelShift -> 0],
myTickGrid[0, 2, {0.25, .5, 1, 1.8}, "Erfc(x)", 0.02]}]
You can find an example here:
Ticks -> {{Pi, 2 Pi, 3 Pi}, {-1, 0, 1}}
Ticks also accepts a function, which will save you the trouble of listing the points manually or having to change the max value each time. Here's an example:
xTickFunc[min_, max_] :=
Table[{i, i, 0.02}, {i, Ceiling[min/Pi] Pi, Floor[max/Pi] Pi, Pi}]
Plot[Sinc[x], {x, -5 Pi, 5 Pi}, Ticks -> {xTickFunc, Automatic},
PlotRange -> All]
If you want more flexibility in customizing your ticks, you might want to look into LevelScheme.
If you run the following code snippet:
Manipulate[
Graphics3D[
{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0,0,0}
],
{a, 1, 100}
]
and move the viewpoint from (1,1,1) to (1,1,100) with the slider you will see that after a while the objects remain fixed in size.
Questions.
1. When I move the viewpoint further away from the scene I want the objects to become smaller. How should this be done in Mathematica?
( EDIT: )
2. What is the position of the 'camera' in relation to Viewpoint?
See ViewAngle. Under "More Information", note that the default setting ViewAngle -> Automatic is effectively equivalent to ViewAngle -> All when you zoom far enough out.
You just need to add an explicit setting for ViewAngle:
Manipulate[
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0, 0, 0},
ViewAngle -> 35 Degree], {a, 1, 100}]
As far as I know, the camera viewpoint really coincides with the position given by ViewPoint. Because Mathematica scales the result to fit in about the same image you don't see much changes but they are there. The perspective changes considerably. Try, for instance, to move away from a semi-transparant square and you'll see that the farther you go, the more the projection becomes an orthogonal projection:
If you want to scale your image according to distance you can use ImageSize. SphericalRegion is good to stabilize the image.
Manipulate[
vp = {1, 1, a};
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> vp,
AxesOrigin -> {0, 0, 0},
SphericalRegion -> True,
ImageSize -> 500/Norm[vp]],
{a, 1, 100}
]
[animation made with some ImagePadding to keep object in the center. I stopped the animation at a = 10, the image gets pretty small after that]
Reading this question on importing ColorData from matlab, I was wondering if there is a way to change the range of values over which the ColorFunction is scaled. That was probably not entirely clear, so let me show with a figure from matlab (the same example as in the previous question is used)
The plot on the left is the original, with the ColorData mapped to the data values between -1 and 1. Now, I can easily set it to be mapped to the data values between 0 and 1, the result being that all values less than 0 are assigned blue color (lowest in the colormap). PlotRange is the closest function, and using ClippingStyle in addition to that produces a similar figure. However, it doesn't re-scale the ColorData to map to the plot range.
How can I do this in Mathematica?
BTW, to insert colorbars using Mathematica, you can look at this function
Here's a function applied to a surface:
Plot3D[x + y, {x, -2, 2}, {y, -2, 2},
ColorFunction -> (ColorData["Rainbow", #3] &), Mesh -> {{1}, {1}}]
To look at the top-right corner, with the same color function and scaling, I set ColorFunctionScaling -> False, and manually scale the color function to map the (global) minimum to zero and the maximum to one using Rescale:
Plot3D[x + y, {x, 1, 2}, {y, 1, 2}, ColorFunctionScaling -> False,
ColorFunction -> (ColorData["Rainbow", Rescale[#3, {-4, 4}, {0, 1}]] &)]