Tag Info

Hot answers tagged

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], ...


7

Here is how it works. If you have a volume in 3d it is essential, that you use connected component labeling in 3d so that components that are connected over layers stick together and get the same label. Lucky for us that MorphologicalComponents can do this. Let's create a test volume data = With[{init = RandomChoice[{0, 0, 1}, {10, 10}]}, NestList[ ...


6

You can set Texture before each polygon t = ImageResize[ExampleData@#, {100, 100}] & /@ ExampleData["ColorTexture"][[;; 6]]; vtc = {{0, 0}, {1, 0}, {1, 1}, {0, 1}}; coords = {{{0, 0, 0}, {0, 1, 0}, {1, 1, 0}, {1, 0, 0}}, {{0, 0, 0}, {1, 0, 0}, {1, 0, 1}, {0, 0, 1}}, {{1, 0, 0}, {1, 1, 0}, {1, 1, 1}, {1, 0, 1}}, {{1, 1, 0}, {0, 1, 0}, ...


6

Using ComponentMeasurements twice, on the original matrix m and on Transpose/@m we can get all Neighbors: mat = RandomInteger[{0, 1}, {3, 3, 3}]; m = Module[{i = 1}, mat /. 1 :> i++]; v = ComponentMeasurements[m, "Label"][[All, 1]] (*{1,2,3,4,5,6,7,8,9,10,11,12,13,14}*) vcoords = ComponentMeasurements[m, "Centroid"][[All, -1]] ...


5

Use the Region functions in version 10 Update: Cube punctured by cylinder Let's tackle the first issue, the cube punctured by the cylinder. It's a matter of subtracting their regions. (*Find the region of the solid cube *) R5 = Cuboid[]; CubeRegion = ImplicitRegion[RegionMember[R5, {x, y, z}], {x, y, z}] cubePlot = RegionPlot3D[CubeRegion, PlotPoints ...


5

For a starter Manipulate[Graphics3D[{EdgeForm[None], Opacity[.3], Green, poly = Polygon[.5 {{-1, -1, 0}, {-1, 1, 0}, {1, 1, 0}, {1, -1, 0}}], Polygon[.5 {{-1, 0, -1}, {-1, 0, 1}, {1, 0, 1}, {1, 0, -1}}], Polygon[.5 {{0, -1, -1}, {0, -1, 1}, {0, 1, 1}, {0, 1, -1}}], EdgeForm[None], Opacity[0.7], {Red, GeometricTransformation[poly, ...


5

VectorPlot3D[{x, y, z}, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}] Now you can either use ViewPoint VectorPlot3D[{x, y, z}, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}, ViewPoint -> {0, 0, 200}] or define a very small z-range VectorPlot3D[{x, y, z}, {x, -1, 1}, {y, -1, 1}, {z, -0.001, 0.001}] Grid[{ VectorPlot3D[{x, y, z}, {x, -1, 1}, {y, -1, 1}, {z, ...


4

Just use MeshFunction. Manipulate[ParametricPlot3D[{Sin[\[Theta]] Cos[\[Phi]], Sin[\[Theta]] Sin[\[Phi]], Cos[\[Theta]]}, {\[Theta], 0, \[Pi]}, {\[Phi], 0, 2 \[Pi]}, PlotStyle -> Opacity[0.5], Mesh -> {{0.}}, MeshStyle -> {Red, Thick}, MeshFunctions -> {Sin[a] Cos[b] #1 + Sin[a] Sin[b] #2 + Cos[a] #3 &}], {a, 0, \[Pi]}, {b, 0, 2 \[Pi]}] ...


4

Scale does work in strange ways. I think it is a design flaw that some transformations are only carried out during rendering (or that Normal works on Translate, but not on Scale). This makes geometric computations very awkward at times. Ah, well. The following is a horrible frankenfix to make your example work. Essentially, you need to define your own ...


4

RegionPlot3D[x <= 5 && y + z <= 7 && x + y <= 8 && z <= 5, {x, 0, 10}, {y, 0, 10}, {z, 0, 10}, Mesh -> {{1, 2, 3, 4, 5}, {1, 2, 3, 4, 5}}] or RegionPlot3D[x <= 5 && y + z <= 7 && x + y <= 8 && z <= 5, {x, 0, 10}, {y, 0, 10}, {z, 0, 10}, Mesh -> 10, MeshFunctions -> ...


4

Just wrap ParametricPlot3D with Normal. The problem is that Mathematica starting from version 6 introduces more advanced data type GraphicsComplex. Normal converts to good old Graphics3D. Michael Trott's "Mathematica Guidebook for Graphics" was written for version 5. polys = Cases[ Normal[ ParametricPlot3D[#1, Evaluate[Sequence @@ #2], PlotPoints -> ...


4

With V10 you can use ClipPlanes Graphics3D[{Red, Opacity[0.5], Cuboid[]}, Axes -> True, ClipPlanes -> {{1, 1, -1, 0}}, ClipPlanesStyle -> {Directive[Opacity[0.2], Green]}] Show[Plot3D[Sin[x + y^2], {x, -3, 3}, {y, -2, 2}], ClipPlanes -> {{-1, 1, 0, 1}}, ClipPlanesStyle -> {Directive[Opacity[.3], Brown]}] Something like this? z = ...


4

Thanks to @shrx 's advise to use other coordinate. After some tuning, it finally works. Though a little ugly, but it's something I really want. The surface near equator still have some bugs which make it seems strange. Here is the code and renderings, which need further optimization. Here is the code and renderings, which need further optimization. elev1d ...


3

There are many mistakes which I believe come from the Copy/Paste: cCos[theta_, xi_] := .5 (E^(xi + I theta) + E^ (-xi - I theta)); cSin[theta_, xi_] := (-.5 I) (E^ (xi + I theta) - E^ (-xi - I theta)); z1[theta_, xi_, n_, k_] := E^ (k*2*Pi*I/n)*cCos[theta, xi] ^ (2.0/n); z2[theta_, xi_, n_, k_] := E^ (k*2*Pi*I/n)*cSin[theta, xi] ^ (2.0/n); pz1[theta_, xi_, ...


3

Keep a list of the locations you add - draw from a uniform distribution and only add to the list if it doesn't overlap. cube = {Opacity[0.3], Cuboid[{0, 0, 0}, {20, 20, 20}]}; newLocation[existing_]:= Module[{try,count=1}, While[ try=RandomReal[{1,19},3]; Min[EuclideanDistance[try,#[[1]]]&/@existing]<2, count++ ]; {try,count} ] ...


3

h[et_] := Graphics3D[{Glow[Yellow], EdgeForm[et], Yellow, Cylinder[]}, Boxed -> False] ImageMultiply[ h[Black], ColorNegate@EdgeDetect@h[None]]


3

Another approach: Manipulate[ Graphics3D[{GeometricTransformation[#, RotationTransform[ angle Degree, {b, c, d}]] & /@ {InfinitePlane[{{0, 0, 0}, {1, 0, 0}, {0, 1, 0}}], Arrow[{{0, 0, 0}, {0, 0, 1}}]}, InfiniteLine[{0, 0, 0}, {b, c, d}]}, PlotRange -> Table[{-3, 3}, {3}]], {angle, 0, 360, Appearance -> "Labeled"}, ...


2

Perhaps Reduce may be easier to work with: soln = Reduce[(n^2 + x^4)/(4 x^2) == z && 0 < n < 101 && 0 < x < 101 && 0 < z < 101111, {n, x, z}, Integers] /. Or | And -> List {{z == 2, n == 4, x == 2}, {z == 5, n == 8, x == 2}, {z == 5, n == 8, x == 4}, {z == 8, n == 16, x == 4}, {z == 10, n == 12, x == ...


2

With V10 we can use RandomColor Graphics3D[Table[{RandomColor[], Sphere[RandomReal[{.1, .9}, 3], RandomReal[{0.03, 0.08}]]}, {50}], Lighting -> "Neutral"] Graphics3D[Table[{RandomColor[1, ColorSpace -> "LUV"], Sphere[RandomReal[{.1, .9}, 3], RandomReal[{0.03, 0.08}]]}, {50}], Lighting -> "Neutral"]


1

I think you are looking for like this coloring face using GraphHighlight Clear[tri] d = 9; x = {}; y = {}; For[t = 1, t <= d, t++, If[t < d, AppendTo[x, tri[t, 1, 1] <-> tri[t + 1, 1, 1]]]; AppendTo[y, tri[t, 1, 1]]; For[r = 2, r <= d, r++, If[t < d, AppendTo[x, tri[t, r, 1] <-> tri[t + 1, r, 1]]]; AppendTo[y, tri[t, r, 1]]; ...


1

Use the option DataRange to specify the actual range of coordinates: ListPlot3D[Table[Sin[i/10 + j/100], {i, 0, 10, 1}, {j, 0, 100, 0.1}]] ListPlot3D[Table[Sin[i/10 + j/100], {i, 0, 10, 1}, {j, 0, 100, 0.1}], DataRange -> {{-5, 5}, {0, 10}}] Update: you can label the ticks the way you wish using the option Ticks: ListPlot3D[Table[Sin[i/10 + ...


1

My output looks a little bit different sphere = {Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}; MeanCurvature[f_] := With[{du = D[f, u], dv = D[f, v]}, Simplify[(Det[{D[du, u], du, dv}] * dv.dv - 2 Det[{D[f, u, v], du, dv}] * du.dv + Det[{D[dv, v], du, dv}] * du.du) / (2 Simplify[(du.du * dv.dv - (du.dv)^2)]^(3/2))]]; mean = ...



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