Is it possible to automate the addition of any text to the faces of a polyhedron, like this manually-drawn graphic shows (the example's odd numbering scheme isn't relevant):
It was easy enough to label the vertices:
c = 1;
Show[{Graphics3D[
Text[c++, #] & /# PolyhedronData["Dodecahedron", "VertexCoordinates"]],
PolyhedronData["Dodecahedron"]},
Boxed -> False]
(even though some of the text is placed in front of the shape for vertices that are hidden. That's probably soluble.)
But when I tried to do the same thing for faces, nothing worked. PolyhedronData["Dodecahedron", "Faces"] returns a GraphicsComplex, rather than coordinates.
Am I overlooking an easy solution/option?
Edit: thanks for these answers, they're all brilliant. If I could combine the text placing of szabolcs' answer with the text quality of belisarius', the perfect solution is in sight!
Here's a funky approach:
(* this function just transforms the polygon onto the [0,1] 2D square *)
vtc[face_, up_:{0,0,1}] := Module[{pts, pts2, centre, r, r2, topmost},
pts = N#face;
centre = Mean[pts];
pts = (# - centre & /# pts);
r = SingularValueDecomposition[pts][[3]];
(* these two lines ensure that the text on the outer face
of a convex polyhedron is not mirrored *)
If[Det[r] < 0, r = -r];
If[Last[centre.r] < 0, r = r.RotationMatrix[\[Pi], {1, 0, 0}]];
pts2 = Most /# (pts.r);
topmost = Part[pts2, First#Ordering[up.# & /# pts, -1]];
r2 = Transpose[{{#2, -#1} & ## topmost, topmost}];
r2 /= Norm[r2];
Rescale[pts2.r2]
]
faces = First /# First#Normal#PolyhedronData["Dodecahedron", "Faces"];
numbers =
Graphics[Text[
Style[#, Underlined, FontFamily -> "Georgia",
FontSize -> Scaled[.3]]]] & /# Range#Length[faces];
Graphics3D[
MapThread[{Texture[#1],
Polygon[#2, VertexTextureCoordinates -> vtc[#2]]} &, {numbers,
faces}],
Boxed -> False
]
Demoing a "SmallRhombicosidodecahedron":
a = PolyhedronData["Dodecahedron", "Faces"] /. GraphicsComplex -> List;
c = 1;
Show[{Graphics3D[
Text[c++, #] & /# (Mean /# (a[[1, #]] & /# a[[2, 1]]))],
PolyhedronData["Dodecahedron"]}, Boxed -> False]
Edit
Perhaps better:
Show[{Graphics3D[
MapIndexed[Text[#2, #1] &,
Mean /# (PolyhedronData["Dodecahedron", "VertexCoordinates"][[#]] & /#
PolyhedronData["Dodecahedron", "FaceIndices"])]],
PolyhedronData["Dodecahedron"]}, Boxed -> False]
Edit
Or
text = Style[#, 128] & /# Range[12]
Graphics3D#
Riffle[Texture /# text,
(Append[#1, {VertexTextureCoordinates ->
With[{n = Length[First[#1]]}, Table[1/2 {Cos[2 Pi i/n], Sin[2 Pi i/n]}+
{1/2, 1/2}, {i, 0, n - 1}]]}] &) /#
Flatten[Normal[PolyhedronData["Dodecahedron", "Faces"]]]]
Related
I have a list of 69 point X= {x1,x2,....x69}. How i can interpolate the points and create a new list X1 from the interpolation of the curve but with 2059 point?
Can i Interpolate the points, than make a Table for the obtained function?
one way:
to = 10;
oldData = {#, RandomReal[]} & /# Range[to];
f = Interpolation[oldData, InterpolationOrder -> 3];
newData = {#, f[#]} & /# FindDivisions[{1, to}, 40];
ListPlot[{newData, oldData},
PlotStyle -> {{Directive[PointSize[Medium]], Red}, Blue},
Joined -> True, Mesh -> All, AxesOrigin -> {0, 0},
PlotLegends -> {"new data", "old data"}]
gives
(ps. using V9 with new PlotLegend option)
I have a question with labeling a plot in Mathematica. I will describe my problem.
I have a function like this.
y = 4 x / L + 2
I want to draw a graph of y vs. x. And also,I have
L={10,20,30,40}
When I write a code like below,
Plot[y, {x, 0, 100},
ImageSize -> Scaled[1.0], PlotLabel -> Style["y vs X ", FontSize -> 18]]
I have four different plots in the same graph. I want to know how to label each plot with their relavant L value.
You can label the lines as you like using this method, based on my earlier post here. After labelling, the plot without dynamic content can be found set to plainplot.
It works by turning each line into a self-labelling button. You can modify labels for different labels.
l = {10, 20, 30, 40};
y[x_, s_] := 4 x/s + 2
plot = Plot[Evaluate#Table[y[x, u], {u, l}], {x, 0, 100},
PlotLabel -> Style["y vs X ", FontSize -> 18]];
pos = Position[plot, _Line];
Array[(line[#] = plot[[Sequence ## pos[[#]]]]) &, Length#l];
AddLabel[label_] := Module[{},
AppendTo[plot[[1]], Inset[Framed[label, Background -> White], pt]];
(* Removing buttons for final plot *)
plainplot = plot;
Array[
(plainplot[[Sequence ## pos[[#]]]] =
plainplot[[Sequence ## Append[pos[[#]], 1]]]) &, Length#l]]
labels = ToString /# l;
Array[
(plot[[Sequence ## pos[[#]]]] =
Button[line[#], AddLabel[labels[[#]]]]) &, Length#l];
Dynamic[EventHandler[plot,
"MouseDown" :> (pt = MousePosition["Graphics"])]]
l = {10, 20, 30, 40}
y[x_, s_] := 4 x/s + 2
<< PlotLegends`
Plot[Evaluate#Table[y[x, u], {u, l}], {x, 0, 100},
ImageSize -> Scaled[1.0],
PlotLabel -> Style["y vs X ", FontSize -> 18],
PlotLegend -> ("L = " <> ToString## & /# l)]
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 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.
How do you generate a 3x3x3 lattice in Mathematica? Is it possible to color some of the lattice points? It seems that it is possible but I cannot get it to work so far
http://reference.wolfram.com/mathematica/ref/LatticeData.html
What I mean by 3x3x3 is something like figure (c) on the right:http://physics.ucsd.edu/was-sdphul/labs/2dl/exp6/exp63.gif
Must agree with Mark that it is not quite clear what you are asking for -- I'll assume it is the figures you are after. Even then, I can't really tell if there are any obvious generalizations from the FCC/BCC stuff.
Anyways, to just replicate the figures, create the lines and points yourself with something like
Gridlines[n_] := With[{s = Range[0, n - 1]},
Join ## (Flatten[#, 1] & /#
NestList[Transpose[#, {3, 1, 2}] &, Outer[List, s, s, s], 2])]
LatticePoints[name_, n_] := Select[
Tuples[Range[-n, n], 3].LatticeData[name, "Basis"],
(And ## ((# >= 0 && # < n) & /# #) &)]
This works for FCC and BCC:
Graphics3D[{
{Red, Sphere[#, 0.1] & /# LatticePoints["FaceCenteredCubic", 3]},
Line[Gridlines[3]]
}, Boxed -> False]