Tag Info

Hot answers tagged

46

Yes we can. The following DashedGraphics3D[ ] function is designed to convert ordinary Graphics3D object to the "line-drawing" style raster image. Clear[DashedGraphics3D] DashedGraphics3D::optx = "Invalid options for Graphics3D are omitted: `1`."; Off[OptionValue::nodef]; Options[DashedGraphics3D] = {ViewAngle -> 0.4, ViewPoint ...


40

We can do this by building a regular hexagon tile and wrapping it onto a torus: hexTile[n_, m_] := With[{hex = Polygon[Table[{Cos[2 Pi k/6] + #, Sin[2 Pi k/6] + #2}, {k, 6}]] &}, Table[hex[3 i + 3 ((-1)^j + 1)/4, Sqrt[3]/2 j], {i, n}, {j, m}] /. {x_?NumericQ, y_?NumericQ} :> 2 π {x/(3 m), 2 y/(n Sqrt[3])} ] ht = ...


25

Yet another method: Let us calculate values of function on appropriate rectangular grids, which we will convert to textures (1 pixel = 1 value). Interpolation between pixels is built-in. f = 2 #1^2 + 2 #2^2 + #3^2 + #1 #2 &; PolyhedronData["Cube"] // N // Normal // toTriangles // texturize[f, 50, Hue, Lighting -> "Neutral", Axes -> True] ...


24

A major point behind the video is that Mobius transformations are simplest when viewed on the sphere. Thus, we'll never actually define a Mobius transformation - we'll do that part on the sphere. Of course, we will need to project back and forth. Here are the stereo graphic projection and it's inverse implemented as compiled functions for speed. This is ...


23

One can also use MeshFunctions: Clear[f]; f = {x, y, z} \[Function] x + Sin[5 z] + y^2; cube = PolyhedronData["Cube", "RegionFunction"]; mesh = 15; RegionPlot3D[cube[x/2, y/2, z/2], {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, MeshFunctions -> {f}, Mesh -> mesh, MeshShading -> ColorData["Rainbow"] /@ Range[0, 1, 1/(mesh + 1)], PlotPoints -> 50, ...


21

I propose a small modification to the parametrization for the torus that addresses issues with conformality. Try F[t_, u_, r_] := {Cos[t] (r + Cos[u + Sin[u]/r]), Sin[t] (r + Cos[u + Sin[u]/r]), Sin[u + Sin[u]/r]} instead. Next, we wish to choose suitable values for $m, n$ for a given $r$ such that the mapping of the ...


19

Edit I had some time so I've added full surface torus. Old code in edit history. DynamicModule[{x = 2., l = 100., x2 = 2., l2 = 100., grid, fast, slow}, Grid[{{ Graphics3D[{ Dynamic[Map[{Blue, Polygon[#[[{1, 2, 4, 3}]]]} &, Join @@@ (Join @@ Partition[#, {2, 2}, 1]) ]&[ ...


17

Something to get you started? f[{x_, y_}] := -Cos[x] x^2 - y^2 xy = First[ ContourPlot[f[{x, y}], {x, -1, 1}, {y, -1, 1}]] /. {x_?AtomQ, y_?AtomQ} :> {x, y, 1}; xz = First[ ContourPlot[f[{x, y}], {x, -1, 1}, {y, -1, 1}]] /. {x_?AtomQ, y_?AtomQ} :> {x, -1, y}; yz = First[ ContourPlot[f[{x, y}], {x, -1, 1}, {y, -1, 1}]] /. ...


17

body[t_] = Integrate[#[u^2], {u, 0, t}] & /@ {Cos, Sin} ParametricPlot3D[body[t]~Join~{t}, {t, -2 Pi, 2 Pi}, BoxRatios -> 1, SphericalRegion -> True]


16

There is an explicit formula n = 30; m = 10; f[t_, u_] := {Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]), Sin[u]}; Graphics3D[Polygon /@ Table[ f[(4 π)/(3 n) (Cos[π k/3] + i 3/2), (2 π)/(Sqrt[3] m) (Sin[π k/3] + (j + i/2) Sqrt[3])], {i, n}, {j, m}, {k, 6}]] % /. Polygon -> Tube I find it a bit simpler than rm -rf's solution. Here f ...


16

Let's get a black torus: torus = First@ParametricPlot3D[{Cos[u] (3 + Cos[t]), Sin[u] (3 + Cos[t]), Sin[t]}, {u, 0, 2 Pi}, {t, 0, 2 Pi}, PlotStyle -> Black, Mesh -> None, PlotPoints -> 10] and now, this is a way to go: DynamicModule[{d1 = 0, d2 = 0}, Column[{ Graphics3D[{ ...


15

To long for a comment, but here's one approach, using information readily available in the docs and on this site: First, make a map that wraps a globe changing the Geoprojection to something a bit more useful. img = With[{Δ = 30}, Row[Table[ GeoGraphics[GeoBackground -> GeoStyling["ReliefMap"], GeoRange -> {{-90, 90}, {λ, λ + Δ}}, ...


15

plot = StreamPlot[{y, -Sin[x]}, {x, -Pi, Pi}, {y, -3, 3}, Frame -> None, Epilog -> {PointSize -> Large, Point[{{0, 0}, {π, 0}, {-π, 0}}]}, StreamPoints -> Fine, AspectRatio -> 0.8] Try this: First[Normal@plot] /. a_Arrow :> ( a /. {x_Real, y_Real} :> {Cos[x], Sin[x], y} ...


14

Something like this perhaps: model = ExampleData[{"Geometry3D", "StanfordBunny"}]; region = BoundaryDiscretizeGraphics[model]; Rasterize @ RegionPlot3D[region, ColorFunction -> (Glow[GrayLevel[#3]] &), ViewPoint -> {0, 0, 10}, Background -> Black, Boxed -> False, Lighting -> None]


14

Bob Hanlon's answer works very well, but in some ways it is the hard way of doing things. If you have v9 or v10, then it is arguably easier to use the legend constructs within it. Similar to his answer, we get the image and element names: img = Import["ExampleData/1PPT.pdb", "Rendering" -> "BallAndStick", ImageSize -> 500]; elements = ...


13

Nasser gives good standard ControlActive approach. But that by definition looses quality during motion. I just would like to share a trick that avoids that. Most of the time is spent on rendering your bell shape. But it is static. Plane moves but it is simple, so it should not all the time trigger recomputing of static bell shape. You can separate motion of ...


13

ClearAll[roundedCuboidF] roundedCuboidF[hprof_: 10, vprof_: 10, taper_: 1][box_] := ChartElementDataFunction["DoubleProfileCube", "HorizontalProfile" -> hprof, "VerticalProfile" -> vprof, "TaperRatio" -> taper][box] Graphics3D[roundedCuboidF[][{{0, 1}, {0, 1}, {0, 1}}], Boxed -> False] or ...


13

One of the main bottlenecks in your code are the texture you apply on each surface. Try to use texture = {}; in your drawTile function and the graphics should be faster by magnitudes. Additionally, as Yves mentioned, Tubes are a performance killer too. Therefore, a workaround for your problem might be to Rasterize the texture graphics by yourself and use ...


13

You can fix this problem by using the following Option in Graphics3D: Method -> {"CylinderPoints" -> {200, 1}} Adjust 200 to match your requirements. (Indeed the default is 40.) Edit: I don't know exactly what the second parameter does, but using the single parameter form shown in the documentation linked below results in a big slow-down. I ...


13

Here is a bit clumsy (had very little time) approach виа combination of new functionality Entity and regions. (* get the states *) divisions = EntityValue[Entity["AdministrativeDivision", {_, "UnitedStates"}], "Entities"]; (* get polygons of borders *) dat = EntityValue[ divisions, {"Population", "Polygon"}] /. {GeoPosition -> Identity, ...


13

I tried to generalize for (almost) any reasonable closed path without using the fact that your current path is contained in a known plane. r = 1; R = 2.5*r; a = .8; b = .4; torusF[R_, r_, u_, v_] := {(R + r Cos@v) Cos@u, (R + r Cos@v) Sin@u, r Sin@v} pathF[R_, r_, aa_, bb_, w_] := torusF[R, r, u, v] /. {u -> bb Cos@w, v -> aa Sin@w} t = ...


12

Mostly the same as @SimonWoods, but it runs on V9: data = ExampleData[{"Geometry3D", "StanfordBunny"}, "VertexData"]; ListSurfacePlot3D[data, MaxPlotPoints -> 50, ColorFunction -> (Glow[GrayLevel[#3]] &), Mesh -> None, Background -> Black, Boxed -> False, ViewPoint -> {0, 0, 10}, Axes -> False]


12

You may try this eq = And @@ (Total[({x, y, z} - #)^2] > 1/2 & /@ Select[Tuples[{-1, 0, 1}, 3], Mod[Total[#], 2] == 0 &]) RegionPlot3D[eq, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, Mesh -> None, PlotPoints -> 150] Notice there are small holes at points of contact between the spheres. You can also "bound" by a sphere instead of a ...


12

Another way using textures: v = {{-1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {-1, 1, -1}, {-1, -1, 1}, {1, -1, 1}, {1, 1, 1}, {-1, 1, 1}}; idx = {{1, 2, 3, 4}, {1, 2, 6, 5}, {2, 3, 7, 6}, {3, 4, 8, 7}, {4, 1, 5, 8}, {5, 6, 7, 8}}; vtc = {{0, 0}, {1, 0}, {1, 1}, {0, 1}}; f[{x_, y_, z_}] := x^2 - y^2 - z^2 q[j_] := MapThread[ Prepend, {{Min@#, Max@#} & ...


12

MeshFunctions are generally quite useful for making such demarcations: With[{d = {Thick, Yellow}}, Plot3D[1/(1 + E^(-a - c)), {a, -8, 8}, {c, -8, 8}, PlotPoints -> 50, MeshStyle -> {Black, Black, d, d, d}, Mesh -> {10, 10, {0}, {0}, {0}}, MeshFunctions -> {# &, #2 &, # &, If[# <= 0, # + #2] &, If[# <= ...


12

Seeing Silvia's phenomenal answer I've been inspired to take a crack at this. My method requires the use of ColorFunction so it only works for plots rather than general Graphics3D geometry. However, it does find silhouette edges in the interior of the image, as well as those hidden behind other surfaces (such as the missing side walls of the internal ...


11

There is a brute-force method: f = 2 #1^2 + 2 #2^2 + #3^2 + #1 #2 &; surface = PolyhedronData["Cube", "RegionFunction"][x, y, z]; r = 0.6; RegionPlot3D[surface, {x, -r, r}, {y, -r, r}, {z, -r, r}, PlotPoints -> 35, NormalsFunction -> None, Mesh -> None, ColorFunction -> (Hue@f[##] &), ColorFunctionScaling -> False] surface ...


11

Using Composition I can apply RotationTransform, TranslationTransform , ShearingTransform one after the other. Graphics3D[{ Opacity[1] , Red , Arrow[{{0, 0, 0}, {1, 0, 0}}] , Green , Arrow[{{0, 0, 0}, {0, 1, 0}}] , Blue , Arrow[{{0, 0, 0}, {0, 0, 1}}] , Opacity[0.2] , GeometricTransformation[Cuboid[-{1, 1, 1}/4, {1, 1, 1}/4], ...


10

lpdata = Table[(4 Pi - t) {Cos[t + Pi/2], Sin[t + Pi/2], 0} + {0, 0, t}, {t, 0, 4 Pi, .1}]; lpp1 = ListPointPlot3D[lpdata, Filling -> Bottom, ColorFunction -> "Rainbow", BoxRatios -> 1, FillingStyle -> Directive[LightGreen, Thick, Opacity[.5]], ImageSize -> 400]; ListPointPlot3D: Post-process Point into Cone lpp2 = lpp1 ...


10

You need to use Normal to explicitly apply the various transformations, resulting in an ordinary collection of polygons which Export can translate to STL. Unfortunately, it looks like Normal has a problem when multiple transformations are supplied to GeometricTransformation. We need to handle this with a specific rule. Assuming g is your Graphics3D: gn = ...



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