Tag Info

Hot answers tagged

16

It seems to me that the logo has three semitransparent layers of triangle meshes. One can start with discretized sphere reg = DiscretizeGraphics[Sphere[], MaxCellMeasure -> {"Length" -> 0.8}] Or with Simon's Geodesate. Then the function for disks in 3D is helpful disk[pos_, {nx_, ny_, nz_}, r_, n_: 16] := With[{θ = ArcTan[Sqrt[nx^2 + ny^2], nz], ...


12

I have to admit, that I only copied your code and tried it without actually reading what you have done, but I guess I can help to fix at least the second image. What you are after is the "DepthPeelingLayers" settings that you can access with the option inspector: When you raise this number to e.g. 32, the output looks like this This can also be done ...


10

In spirit of djp's answer: one can put a point lighting source at the camera position to distinguish distances to spheres. With the option Lighting -> {{"Point", White, ImageScaled@{0, 0, 0}, {0, 0, 5}}} I obtain


10

Quite long since there are arcs not lines, here is the code for them: An efficient circular arc primitive for Graphics3D disk = Scale[Sphere[{0, 0, 1.02}, .05], {1, 1, .2}]; Composition[ Graphics3D[{#, Opacity@.2, Sphere[{0, 0, 0}, 1]}, ImageSize -> 500, Lighting -> "Neutral"] & , { Green, GeometricTransformation[disk, ...


9

Well, it was fairly quick for such a simple figure. David Carraher's solution is simpler, except that the envelope is not drawn. DynamicModule[{vv = {0, 0, 1}, vp = {3.2, 2., 4.}}, Graphics3D[{{Opacity[.5], EdgeForm[], Yellow, Cylinder[{{0, 0, 0}, {0, 0, 1}}, 1]}, {Directive[Thick, Dashed, Red], Line[Table[{Cos[t], Sin[t], 0}, {t, 0, 2 Pi, 2 ...


7

I suppose MeshRegion and Graphics3D have similar methods of the visualization. However, Graphics3D is more convenient and GraphicsComplex can increase the performance: mesh = ReadFSMesh@"fsmesh.bin"; brain = GraphicsComplex[MeshCoordinates@#, MeshCells[#, 2]] &@mesh; Graphics3D[{EdgeForm[], Gray, brain}, Lighting -> "Neutral", Boxed -> False] ...


6

Not quite what you asked for, but here is a non-random approximation: Needs["PolyhedronOperations`"] Graphics3D[{ Style[Sphere[{0, 0, 0}, 0.95], Opacity[0.5], Lighting -> None, Glow[White]], FaceForm[], EdgeForm[Darker@Green], PointSize[Large], Darker@Green, N[Geodesate[PolyhedronData["Icosahedron", "Faces"], 2]] /. p_Polygon :> {p, ...


6

A quick hack: With[{mesh = DiscretizeGraphics@PolyhedronData["TruncatedIcosahedron", "Edges"]}, Show[ Graphics3D[{Opacity[1/2], Sphere[{0, 0, 0}, 0.999]}, Lighting -> {{"Ambient", White}}, Boxed -> False], MeshPrimitives[mesh, 0] /. Point[p_] :> Graphics3D[{Green, EdgeForm[None], MeshPrimitives[ DiscretizeRegion@ ...


5

Not just what you requested but perhaps a bit closer to the tikz rendering. g1 = Graphics3D[{Opacity[.8], EdgeForm[{Thick}], Glow[Pink], Black, Cylinder[]}, Boxed -> False]; g2 = Graphics3D[{Opacity[.8], EdgeForm[{Thick}], Glow[Pink], Black, Cylinder[]}]; GraphicsGrid[{{g1, g2}}]


5

spheres = { Sphere[{50, 50, 50}, 25], Sphere[{70, 70, 70}, 25]}; rgn = RegionUnion @@ (spheres /. Sphere -> Ball); RegionMeasure[rgn // N] 122585. Volume[rgn // N] 122585. EDIT: Example with more elements rgn2 = RegionUnion[ Ball[{100., 100., 100.}, 30.], Ball[{120., 120., 120.}, 30.], Ball[{130., 130., 130.}, 30.], ...


5

How about something Image3D-based? grid = First@ ParametricPlot3D[{Cos[u] Cos[v], Sin[u] Cos[v], Sin[v]}, {u, 0, 2 Pi}, {v, -Pi/2, Pi/2}, PlotStyle -> None]; Graphics3D[ {grid, {Red, Thick, Line[1.2 {{-1, 0, 0}, {1, 0, 0}}]}, {Blue, Thick, Line[1.2 {{0, -1, 0}, {0, 1, 0}}]}, {Green, Thick, Line[1.2 {{0, 0, -1}, {0, 0, 1}}]}, ...


5

You just need to change the parameters before and after your Sphere[] like this: {Graphics3D[{Opacity[0.6], GrayLevel[1], Sphere[], GrayLevel[0], Opacity[1.0], globeGrid[6, figure]}]} Opacity[0.6] is about right to partly hide the lines around the back. GrayLevel[1] because you want the sphere to be coloured white/light. GrayLevel[0] because you want ...


5

You can also use RegionPlot3D: RegionPlot3D[ reg = (2 x^3 + y^2 + z^2 - 1)^3 - (1/10) x^2 z^3 - y^2 z^3 <= 0 && x >= 0, {x, -2, 2}, {y, -2, 2}, {z, -2, 2}, Mesh -> None, Boxed -> False, Axes -> None, PlotPoints -> 40, PlotStyle -> Red, Background -> Black] Implicit regions could be refined but is not as pleasing ...


5

Show the spheres together with a black semi-opaque bitmap. It gives "fog", but not blur. spheres = Table[Sphere[ RandomVariate[UniformDistribution[{0.2, 0.8}], 3], .01], {100}]; cube = {{{RGBColor[0, 0, 0, 0.07]}}}; c = Image3D[cube]; s = Graphics3D[spheres, Background -> Black, ImageSize -> Large]; Show[s, c] It gives distance, but not ...


4

Try this. You had problem with too few { in the Arrow calls Show[ParametricPlot3D[{Cos[s], Sqrt[3] Sin[s]/2, Sin[s]/2}, {s, 0, 3 π/2}, PlotStyle -> Red], Plot3D[y/Sqrt[3], {x, -4, 4}, {y, -4, 4}, Mesh -> Automatic, MeshStyle -> Directive[RGBColor[0.3`, 0.32`, 0.`], Opacity[0.1`], AbsoluteThickness[0.755`], DotDashed], PlotStyle -> ...


4

m = {{{0}}}; m = Fold[ ArrayPad[#, {{0, 1}, {0, 1}, {0, 1}}, #2] &, m, Range[9] ]; Graphics3D@Raster3D[m, ColorFunction -> (Blend["Rainbow", #/10.] &)]


4

cd = ColorData[3, "ColorList"]; cubes[iter_] := Graphics3D[ Table[{cd[[Mod[Max[i, j, k], Length@cd, 1]]], Cuboid[{i, j, k}]}, {i, iter}, {j, iter}, {k, iter}], Boxed -> False, Axes -> False, Lighting -> {{"Ambient", White}}] cubes[25] Alternatively: cubes[i_] := ...


4

Graphics3D[Table[{Hue[RandomReal[]], Cuboid[{i, j, k}]}, {i, 3}, {j, 3}, {k, 3}]] Or if you wish to specify colors: mycolors = { {{Red, Green, Blue}, {Yellow, Orange, Black}, {Purple, Pink, Green}}, {{White, Blue, Yellow}, {Red, Black, Red}, {Pink, Pink, Black}}, {{Yellow, Green, Yellow}, {Purple, Orange, White}, {Green, Pink, Green}} }; ...


3

Will this help you? c1 = ContourPlot3D[{heart == 0}, {x, -1.5, 1.5}, {y, -1.5, 1.5}, {z, -1.5, 1.5}, Mesh -> None, ContourStyle -> Opacity[0.8, Red], RegionFunction -> Function[{x, y, z}, x > -0.3]]; c2 = ContourPlot3D[x == -.3, {x, -1.5, 1.5}, {y, -1.5, 1.5}, {z, -1.5, 1.5}, Mesh -> None, ContourStyle -> Opacity[0.8, Blue], ...


3

A concise refactor of David's code: Graphics3D[{ Opacity[0.5], Array[ {Switch[Max[##], 1, Purple, 2, Red, 3, Green, 4, Yellow], Cuboid[{##}]} &, {4, 4, 4} ] }]


3

Let the spheres have radius $r1$ and $r2$ and their centers be separated by distance $d$. There are four cases: $r1+r2 < d$ (separate spheres): $V = {4 \pi \over 3} (r1^3 + r2^3)$ $r1 > r2 \wedge d + r2 < r1$ (sphere 2 within sphere 1): $V = {4 \pi \over 3} r1^3$ $r2 > r1 \wedge d + r1 < r2$ (sphere 1 within sphere 2): $V = {4 \pi \over ...


3

Given the figure as a Mathematica object, you can obtain the code that produced it by using, % // InputForm Better, as suggested by Kuba, is ReleaseHold[Cases[Normal[ans2 // InputForm], Sphere[z__, _] -> HoldForm[z], Infinity]] which give just a List of the locations without other information. A part of the rather long output is {{1, -Sqrt[3], ...


2

I am unsure what you are after, but I'll give it a try: Given your vectors dirVector[θ_, ϕ_] := {Sin[θ]*Cos[ϕ], Sin[θ]*Sin[ϕ], Cos[θ]}; dirVector2[θ_, ϕ_, χ_] := {Cos[θ]*Cos[ϕ]*Cos[χ]-Sin[ϕ]*Sin[χ], Cos[θ]*Sin[ϕ]*Cos[χ]+Cos[ϕ]*Sin[χ], -Sin[θ]*Cos[χ]}; only the second one has, when χ is varied, a ...


2

You can replace the boundary Line with a Polygon: heart = (2 x^3 + y^2 + z^2 - 1)^3 - (1/10) x^2 z^3 - y^2 z^3; g = Show[ ContourPlot3D[heart == 0, {x, 0., 1.5}, {y, -1.5, 1.5}, {z, -1.5, 1.5}, Mesh -> None, PlotPoints -> 40, ContourStyle -> Opacity[0.8, Red], AxesLabel -> Automatic] /. Line[p_] :> {Opacity[0.8, Red], ...


2

As noted in my comment, replacing the third line of code by t1 = Table[t[[i]], {i, 2, tp}]; allows the code to run. With made-up data t = {4, {2, 3, 4}, {5, 6, 7}, {4, 3, 2}, {7, 6, 5}}; it produces Is this what you had in mind? Further progress requires actual data. Update Now that the data is available, I see that it does not have a ...


2

Unfortunately as of 10.0.2, RegionIntersection is not implemented for MeshRegion nor BoundaryMeshRegion objects embedded in 3D. But you could use ImplicitRegion[] as follows: r1 = ImplicitRegion[(x - 50)^2 + (y - 50)^2 + (z - 50)^2 <= 25^2, {x, y, z}]; r2 = ImplicitRegion[(x - 70)^2 + (y - 70)^2 + (z - 70)^2 <= 25^2, {x, y, z}]; ...


1

p4D = {{0, 0, 0, -2000}, {0, 0, .5, -1800}, {0, 0, 1, -1500}, {0, .5, 0, -2005}, {0, .5, .5, -1795}, {0, .5, .1, -1508}}; Rescale the fourth column to {-.5,.5}: p4Db = Transpose[ MapAt[Rescale[#, Through@{Min, Max}@#, {-.5, .5}] &, Transpose[p4D], {-1}]]; Legended[Graphics3D[{Hue[#4], Sphere[{#, #2, #3}, .05]} & @@@ p4Db, PlotRange ...



Only top voted, non community-wiki answers of a minimum length are eligible