New answers tagged graphics3d
2
Here is an attempt where you can specify the curvature and torsion.
The start point is chosen at random around the origin. The direction is also random.
With these data the Frenet-Serret formula is integrated by the following function:
randcurve[curvature_, torsion_] :=
Module[{ta, no, r, bi, tors, curv, inir, s, t},
eq = {ta'[s] == curv no[s], no'[s] =...
0
A long time ago, 25/04/1998, I wrote my own ConvexHull3D package. It returns the hull as:
{{1, 3, 10, 11, 7}, {1, 7, 9, 8, 2}, {2, 8, 13, 12, 4}, {3, 5, 14, 15,
10}, {4, 12, 17, 16, 6}, {5, 6, 16, 18, 14}, {7, 11, 20, 19,
9}, {8, 9, 19, 21, 13}, {10, 15, 22, 20, 11}, {12, 13, 21, 23,
17}, {14, 18, 24, 22, 15}, {16, 17, 23, 24, 18}, {1, 2, 4, 6, 5,
...
2
Perhaps
a = 1; pp = 50;
SeedRandom[1]
Enchevetrement = ParametricPlot3D[Evaluate@Cordes[s], {s, -20, 20},
PlotPoints -> pp, MaxRecursion -> 1];
Show[Enchevetrement /. Line[x_] :> BSplineCurve[RandomReal[{-a, a}, 3] + # & /@ x],
PlotRange -> {{-10, 10}, {-10, 10}, {-10, 10}}, Axes -> True,
Ticks -> None, AxesStyle -> ...
6
SeedRandom[1];
Graphics3D[{RandomColor[], JoinForm["Round"], CapForm["Round"],
AbsoluteThickness[3], BSplineCurve@#} & /@ RandomReal[{-10, 10}, {40, 10, 3}]]
Replace BSplineCurve@# with Tube @ BSplineCurve@# to get:
Update: Minimal modification of your code:
SeedRandom[123]
stringPack = ParametricPlot3D[randomStrings[s], {s, -...
4
It would be nice to be able to get the region boundary as a polygon or a (single) line in terms of the region. BoundaryMesh does not work on surface regions in 3D. In 2D, BoundaryMesh drops unused vertices, so you have to map the points in the boundary back to the points in original mesh to get the relation between them. This is needed if you project the ...
7
We can use the function Region`Mesh`MeshCellNormals to get face normals and group triangles by face normals:
ClearAll[combineCoplanarFaces]
combineCoplanarFaces[t_: 10^-3][bmr_ ] := Module[{faces = MeshPrimitives[bmr, 2],
normals = Round[Region`Mesh`MeshCellNormals[bmr, 2], t]},
Values @ GroupBy[Transpose[{normals, faces}], First -> Last,
...
7
We use FindShortestTour to order the coordinates for each group of co-planar polygons:
ClearAll[coPQ, triangleCombine]
coPQ[x_, y_, t_: 10^-4] := Max[RegionDistance[InfinitePlane[x[[1]]], #] & /@ y[[1]]] <= t
triangleCombine[t_: 10^-4] := Module[{mc = MeshCoordinates[RegionUnion@##] & @@@
Gather[MeshPrimitives[#, 2], coPQ[##, t] &]},
...
4
a = {1, 0, 0};
b = {0, 1, 0};
c = {0, 0, 1};
d = {0.5, 0.5, 0.75};
m = 1.38 d;
pts = {{a, a, a, a},
{2/3 a + 1/3 b, m, m, 2/3 a + 1/3 c},
{2/3 b + 1/3 a, m, m, 2/3 c + 1/3 a},
{b, 2/3 b + 1/3 c, 2/3 c + 1/3 b, c}};
f = BezierFunction[pts];
Show[Graphics3D[{PointSize[0.04], Point[{a, b, c, d}]}],
Graphics3D[{PointSize[Medium], Red, Map[...
9
[Update: combinepolys now works when face meshes have interior vertices.]
Start by getting the bounding polygons:
reg = DelaunayMesh[q]
bdypolys = Cases[Normal@Show[
BoundaryMesh[reg]
], _Polygon, Infinity]
We group coplanar polygons into faces (Tolerance may need adjustment in other cases):
coplanarQ[pts_?MatrixQ] :=
MatrixRank[Transpose@pts - ...
0
We can use the option PlotRangePadding instead of BoxRatios to get a box with desired proportions without distorting Tubes:
Grid[Partition[#, 2] &[Labeled[
Graphics3D[{Tube[pts]}, PlotRangePadding -> #, ImageSize -> 300],
Style[Row[{"PlotRangePadding -> ", #}], 14], Top] & /@
{Automatic, 5 {1, 1, 3}, 5 {1, 1, 10}, {5, ...
1
We can use Scale with parameters that depend on the BoxRatios and PlotRange to modify Tubes to look like circular independent of BoxRatios and PlotRange
ClearAll[scaledTube]
scaledTube[t_Tube, pr_, br_] := Scale[t, Normalize[-Subtract @@@ pr]/br,
Mean /@ CoordinateBounds[t[[1]]]]
Examples:
pts = Table[{i, i, i/100.0}, {i, 1, 100}];
tube = Graphics3D[...
3
Here's another way to interpret the task to get a cube-shaped box around the plot:
cubePR[plotrange_] :=
plotrange /. {a_, b_} :> (a + b)/2 + #/2 {-1, 1} &[
Max[Differences /@ plotrange]];
Show[#, PlotRange -> cubePR[PlotRange@#]] &@Graphics3D[Tube[pts]]
2
You can get a normal looking tube by giving it a reasonable radius (2nd argument to Tube).
pts = Table[{i, i, i/100}, {i, 1, 100}];
Graphics3D[Tube[pts, 5]]
6
If you use the code in my answer and convert the result to a MeshRegion using DiscretizeGraphics, then the result exports to OBJ at a reasonable resolution. Here's what it looks like on 3dviewer.net:
You can also see an rotatable and colored version (after conversion to X3D) in this Observable notebook. I added the color by manually editing the X3D file.
A ...
4
Try RegionFunction instead of Piecewise
VectorPlot3D[Sqrt[4 - (x^2 + y^2 + z^2)] {y, -x, 0}, {x, -2, 2}, {y, -2,2}, {z, -2, 2}
, RegionFunction -> Function[{x, y, z}, 4 > (x^2 + y^2 + z^2)],VectorPoints -> Fine]
or alternatively Boole
VectorPlot3D[Boole[4 > (x^2 + y^2 + z^2)] Sqrt[4 - (x^2 + y^2 + z^2)] {y, -x,0}
, {x, -2, 2}, {y, -2, 2}, {z, -...
4
Here's another way to do it using ImplicitRegion and the finite element method package.
Needs["NDSolve`FEM`"]
â„› =
ImplicitRegion[y^2 + z^2 <= (Sqrt[E^-x (1 + E^x)^2])^2, {x, y, z}];
(bmesh = ToBoundaryMesh[â„›, {{0, 4}, {-8, 8}, {-8,
8}}])["Wireframe"]
One possible advantage of using this approach is that the mesh will likely ...
5
Revolve three parametric curves. {x, f[x]} , {0, y} and {4, y}
SetOptions[RevolutionPlot3D, Mesh -> False];
f[x_] := Sqrt[E^-x (1 + E^x)^2];
a = RevolutionPlot3D[{x, f[x]}, {x, 0, 4},
RevolutionAxis -> {1, 0, 0}, PlotStyle -> Red];
b = RevolutionPlot3D[{0, y}, {y, 0, f[0]},
RevolutionAxis -> {1, 0, 0}, PlotStyle -> Yellow];
c = ...
0
Post-process to replace Spheres with desired primitives:
ClearAll[coordsAssoc, postProcess]
coordsAssoc[mol_] := GroupBy[Transpose[{mol["AtomList"][[All, 1]],
mol["AtomCoordinates"]["Magnitudes"]}], First -> Last];
postProcess[mol_, newprimitives_] := ReplaceAll[
Flatten[newprimitives /. HoldPattern[a_ -> p_] :>
...
2
Ah, I realized it is because the arguments supplied to the ColorFunction are Scaled versions of the plotted values. So the values I'm seeing in the plot are not the exact values the ColorFunction is operating on. To stop the scaling, I simply set
ColorFunctionScaling-> False
OpacityFunctionScaling -> False
and that fixed the issue.
So now, the ...
1
Use the "BSPTree" rendering method as this doesn't suffer from z-buffer precision issues and produces crisp edges:
theplot =
Show[{ParametricPlot3D[{x, y, 0}, {x, -4, 4}, {y, -4, 4},
PlotStyle -> LightGray, Mesh -> None],
ParametricPlot3D[{0, 0, t}, {t, -8, 8}, PlotStyle -> Blue],
ParametricPlot3D[{x, 0, z}, {x, -3, 3}, {...
4
m = Molecule["Serine"];
atoms = m["AtomList"][[All, 1]];
atomCoords = m["AtomCoordinates"]["Magnitudes"];
Specify desired colors and primitives for the attoms:
colorRules = {"H" -> Red, "O" -> Blue, "N" -> Green, _ -> RGBColor[.4, .4, .4]};
newPrimsRules = {"H" -&...
4
Perhaps this?
Show[
ParametricPlot3D[{Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]), Sin[u]},
{t, 0, 2 Pi}, {u, 0, 2 Pi},
Boxed -> False, Axes -> False, Mesh -> None],
ParametricPlot3D[
With[{t = v, u = 0.5 Sin[20 v]},
{Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]), Sin[u]}
],
{v, 0, 2 Pi},
PlotStyle -> Thick]
]
2
This is duplicate to how can i access the internal function that plots a molecule from a formatted xy. This is unfortunately outdated.
mole = Import["ExampleData/Caffeine.xyz", "Rules"]
This is a list of 4 component. First is the Graphics3D with which @anton-antonov deals so nicely.
I present this solution:
Quiet[With[{types = "...
3
Edit
You can draw a Sin like curve in the parametric domain,see f[t,u] as below.
f[t_, u_] := 2 u - 1 - Sin[15 t];
ContourPlot[f[t, u] == 0, {t, 0, 2 π}, {u, 0, 2 π},
PlotPoints -> 80, FrameLabel -> {t, u}]
and then use the MeshFunctions to lift it to the surface.
ParametricPlot3D[{Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]),
Sin[u]}, {t, 0, 2 Pi}, {...
12
How to replace the spheres in the plot with other 3d figures, say "N" with a Cylinder, "O" with a Cuboid, and "H" with a sphere.
This answer takes points from the GraphicsComplex object generated by MoleculePlot3D and makes related graphics objects replacements.
The colors are used to identify the atoms. (That is probably a ...
4
Reply the comment.
@Steve237
RegionPlot3D[
And @@ {x - 1/2 <= y <= x + 1/2, x - 1/2 <= z <= x + 1/2,
0 <= x <= 1, 0 <= y <= 1, 0 <= z <= 1}, {x, 0, 1}, {y, 0, 1}, {z,
0, 1}, PlotPoints -> 80, PlotStyle -> Opacity[0.2], Mesh -> None,
BoundaryStyle -> Blue, AxesLabel -> {"x", "y", "...
4
Here is an approach that seems to stem from the equations you mentioned at the end. I am not sure that I have interpreted them correctly, but even if I have not, perhaps it will get you started:
DiscretizeRegion[
ImplicitRegion[
{x - 1/2 <= y <= x + 1/2, x - 1/2 <= z <= x + 1/2}, {x, y, z}
],
{{0, 1}, {0, 1}, {0, 1}},
Axes -> True, ...
1
PLOT = ListPointPlot3D[data, ColorFunction -> "Rainbow", Axes -> True,
PlotStyle -> PointSize[0.025]];
lp3d = ListPlot3D[Join @@ MapIndexed[Append[Reverse@#2, #] &, data, {2}],
MeshFunctions -> {# &, #2 &},
Mesh -> (Range /@ Dimensions[data]),
PlotStyle -> None,
MeshStyle -> Dashed,
...
2
If you did not need the axes and ticks, you could have added a Cuboid with appropriate coordinates before transformation:
Graphics3D[{GeometricTransformation[{plot[[1]],
EdgeForm[Red], FaceForm[], Cuboid @@ Transpose @ PlotRange @ plot},
ShearingMatrix[-Pi/4, {1, 0, 0}, {0, 1, 0}]]}]
To add axes and ticks you can use
boxF[5, 5][plot]
Graphics3D[{...
3
In your Graphics3D the Axes are not shown simply because False is the default value for that option. So just add them:
plot = Plot3D[{1/x + 1/y}, {x, 0, 10}, {y, 0, 10}, ClippingStyle -> None];
Graphics3D[GeometricTransformation[plot[[1]],
ShearingMatrix[-Pi/4, {1, 0, 0}, {0, 1, 0}]], Axes -> True]
Is that all you needed?
0
Why not SphericalPlot3D[1, \[Theta], \[Phi]]?
2
You can construct 3D mesh lines using GeometricTransformation of two great circles:
ClearAll[sphereMesh]
sphereMesh[n_: 40, m_: 40, opts : OptionsPattern[]] :=
Module[{tr1 = AffineTransform[{{{Sin @ #, 0, 0}, {0, Sin @ #, 0}, {0, 0, 1}},
{0, 0, Cos @ #}}] & & /@ Subdivide[0, 2 Pi, n],
tr2 = RotationTransform[#, {0, 0, 1}] & /@ ...
1
We can use RegionMember to view the structure of Sphere[]
RegionMember[Sphere[], {x, y, z}]
(x | y | z) ∈ Reals && x^2 + y^2 + z^2 == 1
and then use ContourPlot3D to make Mesh
6
Is there a way to get a similar result using the (much more efficient) Sphere[] primitive?
No, the internal discretization is not accessible. But you can get something similar, with a trick, and assuming that ...
I'm not picky about which mesh it chooses
DiscretizeRegion[Sphere[],
PrecisionGoal -> 1, MaxCellMeasure -> 0.01,
MeshCellStyle -> {{2,...
0
Head@ParametricPlot3D[{Sin[t] Cos[p], Sin[t] Sin[p], Cos[t]}, {t, 0, \[Pi]}, {p, 0, 2 \[Pi]}]
(* Graphics3D *)
makeDashed[ g_Graphics3D ] := g /. l_Line :> {Dashed, l}
makeDashed[ ParametricPlot3D[{Sin[t] Cos[p], Sin[t] Sin[p], Cos[t]}, {t, 0, \[Pi]}, {p, 0, 2 \[Pi]}] ]
You may give the gridlines on the sphere in ParametricPlot3D the Opacity You like
...
4
If you try evaluating your RegionDistance object for a point you will see that it doesn't work:
RegionDistance[
RegionUnion[Cuboid[{-5,-5,0},{5,5,1}],Cuboid[{-10,-10,-10},{10,10,0}]],
{1,-1,2}
] //InputForm
RegionDistance[Polyhedron[{{-5., -5., 0.}, {5., -5., 0.}, {5., -5., 1.}, {-5., -5., 1.},
{5., 5., 0.}, {-5., 5., 0.}, {-5., 5., 1.}, {5., 5., 1.}...
3
Min work or not?
reg1 = Cuboid[{-5, -5, -12}, {5, 5, 12}];
reg2 = Cuboid[{-10, -10, -10}, {10, 10, 10}];
ContourPlot3D[
Min[RegionDistance[reg1, {x, y, z}],
RegionDistance[reg2, {x, y, z}]] // Evaluate, {x, -15,
15}, {y, -15, 15}, {z, -15, 15}, Mesh -> None, Contours -> {0.25},
ContourStyle -> ColorData[94, "ColorList"], Lighting ...
0
Use the option PlotRegion to specify "what region of the final display area a plot should fill" and add the plot label using the function Labeled:
Labeled[ListPointPlot3D[data,
ViewMatrix -> {transformationMatrix, projectionMatrix},
PlotRange -> {All, All, All},
PlotRegion -> {{.1, .9}, {.1, 1.3}}],
Style["Example Title",...
2
$$\textbf{Parameters}:\quad \theta,\alpha,\beta,\gamma.$$
$$\textbf{Conditions on parameters}:\quad 0<\theta<1,\quad 1\leq \beta \leq \infty.$$
$$\textbf{More constraints:}\quad \begin{cases}
4\theta+\frac{2}{\beta}\theta<1,\\
6\theta-\frac{2}{\beta}\theta<1.\\
\end{cases} $$
$$\textbf{Region to be plotted}:\left(\frac{1}{1-2\theta-\frac{\theta}{\...
2
angularSlider[Dynamic[angle_]] :=
DynamicModule[{p = {1, 0}, angleCalc},
LocatorPane[Dynamic[p, (angleCalc @@ Normalize /@ {#, p}) &],
Graphics[{Circle[], Arrowheads[0.15], Arrow[Dynamic[{{0, 0}, p}]]},
ImageSize -> Tiny], Appearance -> None],
Initialization :> (angle = 0;
angleCalc[newp_,
oldp_] := (angle =
...
2
Another possibility is to use TransformedRegion with RegionProduct. Here is a function that does this:
Options[MinkowskiSum] = Options[BoundaryDiscretizeRegion];
MinkowskiSum[r1_, r2_, opts:OptionsPattern[]] := Module[{d1,d2,func,bounds},
d1=RegionEmbeddingDimension[r1];
d2=RegionEmbeddingDimension[r2];
(
func=Evaluate[Array[Slot, d1] + ...
1
For plane, we can decreasing the MaxCellMeasure instead of increasing it.
reg = ImplicitRegion[
x + y + z <= 3 && x + z <= 1 && 0 <= x <= 3 && 0 <= y <= 3 &&
0 <= z <= 2, {x, y, z}];
RegionPlot3D[DiscretizeRegion[reg, MaxCellMeasure -> 1]]
1
Here is how you create non overlapping random circles inside a unit circles. Take care not to create too many circles, because if the unit circle is filled, the function will search forever:
oldpos = {};
newpos[] := (While[(t = RandomReal[{-.9, .9}, 2]; t.t > 0.9^2) || (
Min[Norm[# - t] & /@ oldpos] < 0.2)]; AppendTo[oldpos, t]; t)
Graphics[...
2
outerradius = 1.0;
seeds = RandomPoint[Disk[{0, 0}, outerradius], 3000];
radius = .05;
results = Reap[
While[Length[seeds] > 2,
(* pick a point and remove all others within radius *)
{{point}, seeds} = TakeDrop[seeds, 1];
seeds = Select[seeds, EuclideanDistance[#, point] > 2 radius &];
Sow[point];
]
][[2, 1]];
...
2
Something like the following?
Graphics3D[{
{Opacity[0.3], Cylinder[{{0, 0, -1}, {0, 0, 1}}, 1]},
{Opacity[0.4],
Table[If[x^2 + y^2 <= .9^2,
Cylinder[{{x, y, -1}, {x, y, 1}}, 0.1]], {x, -1, 1, .2}, {y, -1,
1, .2}]}
, Table[pos = RandomReal[{-.9, .9}, 3];
If[pos[[1 ;; 2]].pos[[1 ;; 2]] <= .9^2, Sphere[pos, 0.1]], 100]
}]
Top 50 recent answers are included
