Related
I have written code which draws the Sierpinski fractal. It is really slow since it uses recursion. Do any of you know how I could write the same code without recursion in order for it to be quicker? Here is my code:
midpoint[p1_, p2_] := Mean[{p1, p2}]
trianglesurface[A_, B_, C_] := Graphics[Polygon[{A, B, C}]]
sierpinski[A_, B_, C_, 0] := trianglesurface[A, B, C]
sierpinski[A_, B_, C_, n_Integer] :=
Show[
sierpinski[A, midpoint[A, B], midpoint[C, A], n - 1],
sierpinski[B, midpoint[A, B], midpoint[B, C], n - 1],
sierpinski[C, midpoint[C, A], midpoint[C, B], n - 1]
]
edit:
I have written it with the Chaos Game approach in case someone is interested. Thank you for your great answers!
Here is the code:
random[A_, B_, C_] := Module[{a, result},
a = RandomInteger[2];
Which[a == 0, result = A,
a == 1, result = B,
a == 2, result = C]]
Chaos[A_List, B_List, C_List, S_List, n_Integer] :=
Module[{list},
list = NestList[Mean[{random[A, B, C], #}] &,
Mean[{random[A, B, C], S}], n];
ListPlot[list, Axes -> False, PlotStyle -> PointSize[0.001]]]
This uses Scale and Translate in combination with Nest to create the list of triangles.
Manipulate[
Graphics[{Nest[
Translate[Scale[#, 1/2, {0, 0}], pts/2] &, {Polygon[pts]}, depth]},
PlotRange -> {{0, 1}, {0, 1}}, PlotRangePadding -> .2],
{{pts, {{0, 0}, {1, 0}, {1/2, 1}}}, Locator},
{{depth, 4}, Range[7]}]
If you would like a high-quality approximation of the Sierpinski triangle, you can use an approach called the chaos game. The idea is as follows - pick three points that you wish to define as the vertices of the Sierpinski triangle and choose one of those points randomly. Then, repeat the following procedure as long as you'd like:
Choose a random vertex of the trangle.
Move from the current point to the halfway point between its current location and that vertex of the triangle.
Plot a pixel at that point.
As you can see at this animation, this procedure will eventually trace out a high-resolution version of the triangle. If you'd like, you can multithread it to have multiple processes plotting pixels at once, which will end up drawing the triangle more quickly.
Alternatively, if you just want to translate your recursive code into iterative code, one option would be to use a worklist approach. Maintain a stack (or queue) that contains a collection of records, each of which holds the vertices of the triangle and the number n. Initially put into this worklist the vertices of the main triangle and the fractal depth. Then:
While the worklist is not empty:
Remove the first element from the worklist.
If its n value is not zero:
Draw the triangle connecting the midpoints of the triangle.
For each subtriangle, add that triangle with n-value n - 1 to the worklist.
This essentially simulates the recursion iteratively.
Hope this helps!
You may try
l = {{{{0, 1}, {1, 0}, {0, 0}}, 8}};
g = {};
While [l != {},
k = l[[1, 1]];
n = l[[1, 2]];
l = Rest[l];
If[n != 0,
AppendTo[g, k];
(AppendTo[l, {{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1}] & ## #) & /#
NestList[RotateLeft, k, 2]
]]
Show#Graphics[{EdgeForm[Thin], Pink,Polygon#g}]
And then replace the AppendTo by something more efficient. See for example https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile
Edit
Faster:
f[1] = {{{0, 1}, {1, 0}, {0, 0}}, 8};
i = 1;
g = {};
While[i != 0,
k = f[i][[1]];
n = f[i][[2]];
i--;
If[n != 0,
g = Join[g, k];
{f[i + 1], f[i + 2], f[i + 3]} =
({{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1} & ## #) & /#
NestList[RotateLeft, k, 2];
i = i + 3
]]
Show#Graphics[{EdgeForm[Thin], Pink, Polygon#g}]
Since the triangle-based functions have already been well covered, here is a raster based approach.
This iteratively constructs pascal's triangle, then takes modulo 2 and plots the result.
NestList[{0, ##} + {##, 0} & ## # &, {1}, 511] ~Mod~ 2 // ArrayPlot
Clear["`*"];
sierpinski[{a_, b_, c_}] :=
With[{ab = (a + b)/2, bc = (b + c)/2, ca = (a + c)/2},
{{a, ab, ca}, {ab, b, bc}, {ca, bc, c}}];
pts = {{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}} // N;
n = 5;
d = Nest[Join ## sierpinski /# # &, {pts}, n]; // AbsoluteTiming
Graphics[{EdgeForm#Black, Polygon#d}]
(*sierpinski=Map[Mean, Tuples[#,2]~Partition~3 ,{2}]&;*)
Here is a 3D version,https://mathematica.stackexchange.com/questions/22256/how-can-i-compile-this-function
ListPlot#NestList[(# + RandomChoice[{{0, 0}, {2, 0}, {1, 2}}])/2 &,
N#{0, 0}, 10^4]
With[{data =
NestList[(# + RandomChoice#{{0, 0}, {1, 0}, {.5, .8}})/2 &,
N#{0, 0}, 10^4]},
Graphics[Point[data,
VertexColors -> ({1, #[[1]], #[[2]]} & /# Rescale#data)]]
]
With[{v = {{0, 0, 0.6}, {-0.3, -0.5, -0.2}, {-0.3, 0.5, -0.2}, {0.6,
0, -0.2}}},
ListPointPlot3D[
NestList[(# + RandomChoice[v])/2 &, N#{0, 0, 0}, 10^4],
BoxRatios -> 1, ColorFunction -> "Pastel"]
]
I am wondering if anyone can help me to plot the Cantor dust on the plane in Mathematica. This is linked to the Cantor set.
Thanks a lot.
EDIT
I actually wanted to have something like this:
Here's a naive and probably not very optimized way of reproducing the graphics for the ternary Cantor set construction:
cantorRule = Line[{{a_, n_}, {b_, n_}}] :>
With[{d = b - a, np = n - .1},
{Line[{{a, np}, {a + d/3, np}}], Line[{{b - d/3, np}, {b, np}}]}]
Graphics[{CapForm["Butt"], Thickness[.05],
Flatten#NestList[#/.cantorRule&, Line[{{0., 0}, {1., 0}}], 6]}]
To make Cantor dust using the same replacement rules, we take the result at a particular level, e.g. 4:
dust4=Flatten#Nest[#/.cantorRule&,Line[{{0.,0},{1.,0}}],4]/.Line[{{a_,_},{b_,_}}]:>{a,b}
and take tuples of it
dust4 = Transpose /# Tuples[dust4, 2];
Then we just plot the rectangles
Graphics[Rectangle ### dust4]
Edit: Cantor dust + squares
Changed specs -> New, but similar, solution (still not optimized).
Set n to be a positive integer and choice any subset of 1,...,n then
n = 3; choice = {1, 3};
CanDChoice = c:CanD[__]/;Length[c]===n :> CanD[c[[choice]]];
splitRange = {a_, b_} :> With[{d = (b - a + 0.)/n},
CanD##NestList[# + d &, {a, a + d}, n - 1]];
cantLevToRect[lev_]:=Rectangle###(Transpose/#Tuples[{lev}/.CanD->Sequence,2])
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 4] // Rest;
Graphics[{FaceForm[LightGray], EdgeForm[Black],
Table[cantLevToRect[lev], {lev, Most#dust}],
FaceForm[Black], cantLevToRect[Last#dust /. CanDChoice]}]
Here's the graphics for
n = 7; choice = {1, 2, 4, 6, 7};
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 2] // Rest;
and everything else the same:
Once can use the following approach. Define cantor function:
cantorF[r:(0|1)] = r;
cantorF[r_Rational /; 0 < r < 1] :=
Module[{digs, scale}, {digs, scale} = RealDigits[r, 3];
If[! FreeQ[digs, 1],
digs = Append[TakeWhile[Most[digs]~Join~Last[digs], # != 1 &], 1];];
FromDigits[{digs, scale}, 2]]
Then form the dust by computing differences of F[n/3^k]-F[(n+1/2)/3^k]:
With[{k = 4},
Outer[Times, #, #] &[
Table[(cantorF[(n + 1/2)/3^k] - cantorF[(n)/3^k]), {n, 0,
3^k - 1}]]] // ArrayPlot
I like recursive functions, so
cantor[size_, n_][pt_] :=
With[{s = size/3, ct = cantor[size/3, n - 1]},
{ct[pt], ct[pt + {2 s, 0}], ct[pt + {0, 2 s}], ct[pt + {2 s, 2 s}]}
]
cantor[size_, 0][pt_] := Rectangle[pt, pt + {size, size}]
drawCantor[n_] := Graphics[cantor[1, n][{0, 0}]]
drawCantor[5]
Explanation: size is the edge length of the square the set fits into. pt is the {x,y} coordinates of it lower left corner.
I have a function f(x,y) of two variables, of which I need to know the location of the curves at which it crosses zero. ContourPlot does that very efficiently (that is: it uses clever multi-grid methods, not just a brute force fine-grained scan) but just gives me a plot. I would like to have a set of values {x,y} (with some specified resolution) or perhaps some interpolating function which allows me to get access to the location of these contours.
Have thought of extracting this from the FullForm of ContourPlot but this seems to be a bit of a hack. Any better way to do this?
If you end up extracting points from ContourPlot, this is one easy way to do it:
points = Cases[
Normal#ContourPlot[Sin[x] Sin[y] == 1/2, {x, -3, 3}, {y, -3, 3}],
Line[pts_] -> pts,
Infinity
]
Join ## points (* if you don't want disjoint components to be separate *)
EDIT
It appears that ContourPlot does not produce very precise contours. They're of course meant for plotting and are good enough for that, but the points don't lie precisely on the contours:
In[78]:= Take[Join ## points /. {x_, y_} -> Sin[x] Sin[y] - 1/2, 10]
Out[78]= {0.000163608, 0.0000781187, 0.000522698, 0.000516078,
0.000282781, 0.000659909, 0.000626086, 0.0000917416, 0.000470424,
0.0000545409}
We can try to come up with our own method to trace the contour, but it's a lot of trouble to do it in a general way. Here's a concept that works for smoothly varying functions that have smooth contours:
Start from some point (pt0), and find the intersection with the contour along the gradient of f.
Now we have a point on the contour. Move along the tangent of the contour by a fixed step (resolution), then repeat from step 1.
Here's a basic implementation that only works with functions that can be differentiated symbolically:
rot90[{x_, y_}] := {y, -x}
step[f_, pt : {x_, y_}, pt0 : {x0_, y0_}, resolution_] :=
Module[
{grad, grad0, t, contourPoint},
grad = D[f, {pt}];
grad0 = grad /. Thread[pt -> pt0];
contourPoint =
grad0 t + pt0 /. First#FindRoot[f /. Thread[pt -> grad0 t + pt0], {t, 0}];
Sow[contourPoint];
grad = grad /. Thread[pt -> contourPoint];
contourPoint + rot90[grad] resolution
]
result = Reap[
NestList[step[Sin[x] Sin[y] - 1/2, {x, y}, #, .5] &, {1, 1}, 20]
];
ListPlot[{result[[1]], result[[-1, 1]]}, PlotStyle -> {Red, Black},
Joined -> True, AspectRatio -> Automatic, PlotMarkers -> Automatic]
The red points are the "starting points", while the black points are the trace of the contour.
EDIT 2
Perhaps it's an easier and better solution to use a similar technique to make the points that we get from ContourPlot more precise. Start from the initial point, then move along the gradient until we intersect the contour.
Note that this implementation will also work with functions that can't be differentiated symbolically. Just define the function as f[x_?NumericQ, y_?NumericQ] := ... if this is the case.
f[x_, y_] := Sin[x] Sin[y] - 1/2
refine[f_, pt0 : {x_, y_}] :=
Module[{grad, t},
grad = N[{Derivative[1, 0][f][x, y], Derivative[0, 1][f][x, y]}];
pt0 + grad*t /. FindRoot[f ## (pt0 + grad*t), {t, 0}]
]
points = Join ## Cases[
Normal#ContourPlot[f[x, y] == 0, {x, -3, 3}, {y, -3, 3}],
Line[pts_] -> pts,
Infinity
]
refine[f, #] & /# points
A slight variation for extracting points from ContourPlot (possibly due to David Park):
pts = Cases[
ContourPlot[Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}],
x_GraphicsComplex :> First#x, Infinity];
or (as a list of {x,y} points)
ptsXY = Cases[
Cases[ContourPlot[
Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}],
x_GraphicsComplex :> First#x, Infinity], {x_, y_}, Infinity];
Edit
As discussed here, an article by Paul Abbott in the Mathematica Journal (Finding Roots in an Interval) gives the following two alternative methods for obtaining a list of {x,y} values from ContourPlot, including (!)
ContourPlot[...][[1, 1]]
For the above example
ptsXY2 = ContourPlot[
Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}][[1, 1]];
and
ptsXY3 = Cases[
Normal#ContourPlot[
Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}],
Line[{x__}] :> x, Infinity];
where
ptsXY2 == ptsXY == ptsXY3
In the following bit of mathematica code
a1 = {{0, -I}, {I, 0}}
a2 = {{0, 1}, {1, 0}}
a3 = {{1, 0}, {0, -1}}
c = I*a1*a2 // MatrixForm
d = c*a3 // MatrixForm
The display of d shows up as a two by two matrix, where the 1,1 and 2,2 elements are themselves 2x2 matrixes, whereas I expect it to be a plain old 2x2 matrix of scalars?
use () to protect expression from MatrixFrom which is a wrapper.
use '.' for matrix multiplication. Not '*'
a1 = {{0, -I}, {I, 0}}
a2 = {{0, 1}, {1, 0}}
a3 = {{1, 0}, {0, -1}}
(c = I a1.a2) // MatrixForm
(d = c.a3) // MatrixForm
This is the output I get for d:
(1 0
0 1)
This is one of the classic gotchas in Mathematica.
The MatrixForm display wrapper has a higher precedence than the Set operator (=).
Assuming (based on your tag selection) that you meant to use matrix multiplication Dot (.) instead of Times (*), I would write
a1 = {{0, -I}, {I, 0}}
a2 = {{0, 1}, {1, 0}}
a3 = {{1, 0}, {0, -1}}
(c = I a1.a2) // MatrixForm
(d = c.a3) // MatrixForm
which returns for c and d respectively:
(1 0
0 -1)
(1 0
0 1)
Edit:
I forgot to mention if you do enter
c = I a1.a2 // MatrixForm
Then a quick look at the FullForm of c will show you what the problem is:
In[6]:= FullForm[c]
Out[6]//FullForm= MatrixForm[List[List[1,0],List[0,-1]]]
You can see that it has the Head[c] == MatrixForm and so it won't play nice with the other matrices.
I am looking to plot something like the whispering gallery modes -- a 2D cylindrically symmetric plot in polar coordinates. Something like this:
I found the following code snippet in Trott's symbolics guidebook. Tried running it on a very small data set; it ate 4 GB of memory and hosed my kernel:
(* add points to get smooth curves *)
addPoints[lp_][points_, \[Delta]\[CurlyEpsilon]_] :=
Module[{n, l}, Join ## (Function[pair,
If[(* additional points needed? *)
(l = Sqrt[#. #]&[Subtract ## pair]) < \[Delta]\[CurlyEpsilon], pair,
n = Floor[l/\[Delta]\[CurlyEpsilon]] + 1;
Table[# + i/n (#2 - #1), {i, 0, n - 1}]& ## pair]] /#
Partition[If[lp === Polygon,
Append[#, First[#]], #]&[points], 2, 1])]
(* Make the plot circular *)
With[{\[Delta]\[CurlyEpsilon] = 0.1, R = 10},
Show[{gr /. (lp : (Polygon | Line))[l_] :>
lp[{#2 Cos[#1], #2 Sin[#1]} & ###(* add points *)
addPoints[lp][l, \[Delta]\[CurlyEpsilon]]],
Graphics[{Thickness[0.01], GrayLevel[0], Circle[{0, 0}, R]}]},
DisplayFunction -> $DisplayFunction, Frame -> False]]
Here, gr is a rectangular 2D ListContourPlot, generated using something like this (for example):
data = With[{eth = 2, er = 2, wc = 1, m = 4},
Table[Re[
BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[
I m phi]], {r, 0, 10, .2}, {phi, 0, 2 Pi, 0.1}]];
gr = ListContourPlot[data, Contours -> 50, ContourLines -> False,
DataRange -> {{0, 2 Pi}, {0, 10}}, DisplayFunction -> Identity,
ContourStyle -> {Thickness[0.002]}, PlotRange -> All,
ColorFunctionScaling -> False]
Is there a straightforward way to do cylindrical plots like this?.. I find it hard to believe that I would have to turn to Matlab for my curvilinear coordinate needs :)
Previous snippets deleted, since this is clearly the best answer I came up with:
With[{eth = 2, er = 2, wc = 1, m = 4},
ContourPlot[
Re[BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[I phi m]]/.
{r ->Norm[{x, y}], phi ->ArcTan[x, y]},
{x, -10, 10}, {y, -10, 10},
Contours -> 50, ContourLines -> False,
RegionFunction -> (#1^2 + #2^2 < 100 &),
ColorFunction -> "SunsetColors"
]
]
Edit
Replacing ContourPlot by Plot3D and removing the unsupported options you get:
This is a relatively straightforward problem. The key is that if you can parametrize it, you can plot it. According to the documentation both ListContourPlot and ListDensityPlot accept data in two forms: an array of height values or a list of coordinates plus function value ({{x, y, f} ..}). The second form is easier to deal with, such that even if your data is in the first form, we'll transform it into the second form.
Simply, to transform data of the form {{r, t, f} ..} into data of the form {{x, y, f} ..} you doN[{#[[1]] Cos[ #[[2]] ], #[[1]] Sin[ #[[2]] ], #[[3]]}]& /# data, when applied to data taken from BesselJ[1, r/2] Cos[3 t] you get
What about when you just have an array of data, like this guy? In that case, you have a 2D array where each point in the array has known location, and in order to plot it, you have to turn it into the second form. I'm partial to MapIndexed, but there are other ways of doing it. Let's say your data is stored in an array where the rows correspond to the radial coordinate and the columns are the angular coordinate. Then to transform it, I'd use
R = 0.01; (*radial increment*)
T = 0.05 Pi; (*angular increment*)
xformed = MapIndexed[
With[{r = #2[[1]]*R, t = #2[[1]]*t, f = #1},
{r Cos[t], r Sin[t], f}]&, data, {2}]//Flatten[#,1]&
which gives the same result.
If you have an analytic solution, then you need to transform it to Cartesian coordinates, like above, but you use replacement rules, instead. For instance,
ContourPlot[ Evaluate[
BesselJ[1, r/2]*Cos[3 t ] /. {r -> Sqrt[x^2 + y^2], t -> ArcTan[x, y]}],
{x, -5, 5}, {y, -5, 5}, PlotPoints -> 50,
ColorFunction -> ColorData["DarkRainbow"], Contours -> 25]
gives
Two things to note: 1) Evaluate is needed to ensure that the replacement is performed correctly, and 2) ArcTan[x, y] takes into account the quadrant that the point {x,y} is found in.