Hot answers tagged

49

If you want to make several sequences of the Collatz function for turning it into a graph, you probably want to memorize, which parts you already calculated. What we try to do is to create a graph like this (image from xkcd) When we would calculate the whole chain for each number until it (hopefully) reaches the end sequence 8,4,1 we do a lot of work over ...


30

Scientific progress! In v10.3 with all the goodies in AnatomyData we can now use the simple code: Entity["AnatomicalStructure", "Skin"]["Graphics3D"] Zoom in on the appropriate part and you're done. pelvisLoc = AnatomyData[Entity["AnatomicalStructure", "Pelvis"], "RegionBounds"]; Show[ Entity["AnatomicalStructure", "Skin"]["Graphics3D"], ...


29

Usage Just use this function with any polyhedron in in form: GraphicsComplex[pts_, Polygon[vertices_, ___]]. When I find time and motivation maybe I will add more DownValues so it can be more general. At the moment you can play with solids given by PolyhedronData[... "Faces"]: polyhedronRandomWalk[ PolyhedronData["DuerersSolid", "Faces"] ] ...


29

This is the Collatz function I know: Collatz[1] := {1} Collatz[n_Integer] := Prepend[Collatz[3 n + 1], n] /; OddQ[n] && n > 0 Collatz[n_Integer] := Prepend[Collatz[n/2], n] /; EvenQ[n] && n > 0 Generating a graph from this is easy: Graph[(DirectedEdge @@@ Partition[Collatz[#], 2, 1]) & /@ Range[500] // Flatten // Union, ...


26

Here's a function to create a random scalar field: randomFunction3D[xrange_, yrange_, zrange_] := Interpolation[ Flatten[Table[{{x, y, z}, RandomReal[{-1, 1}]}, Evaluate@{x, Sequence @@ xrange}, Evaluate@{y, Sequence @@ yrange}, Evaluate@{z, Sequence @@ zrange}], 2], Method -> "Spline"] Now instead of drawing a sphere with constant ...


21

If I'm not mistaken, a complement is defined as the set of elements in one set that are not contained in a given other set. In your case, you have specified the 'other' set (the union of S1, S2 and S3), but not the 'one' set. As you phrased it, I guess that set must be $\mathbb R^3$. So, the complement is the difference between an infinite space and a finite ...


19

Using RandomPoint (available in Mathematica 10.2 or later): c = Cuboid[]; pts = RandomPoint[RegionBoundary[c], 5000]; Graphics3D[Point[pts], Boxed -> False] Check the average distance to the centroid Mean[Map[Norm[# - RegionCentroid[c]] &, pts]] (* 0.640991 *)


18

A crude attempt This is for Mathematica 10+ only. To construct each face, I use an intersection between a unit 3-ball centred at the origin and a pyramid whose base is at infinity and apex is at the origin. Each edge of the pyramid passes through each vertex of the spherical face. The pyramid is given by ConicHullRegion[{origin}, {vertices}]. The ...


16

Update: With the function top defined in the original post you can replicate all the cool things you see in rm-rf's answer in the linked Q/A. For example, with a slight modification of gr1, i.e., Graphics3D[hexTile[20, 20] /. Polygon[l_] :> {Directive[Orange, Opacity[0.8], Specularity[White, 30]], Polygon[l], Polygon[{Pi/5, 0} + {-1, 1} # & ...


16

You could make 2d plot and then convert 2d coord to 3d: data1 = {{1, -5.8}, {2, -5.4}, {3, -0.8}, {4, -0.2}, {5, 4.6}, {1, -6.4}, {2, -5.6}, {3, -0.7}, {4, 0.04}, {5, 1.0}, {1, -6.8}, {2, -4.7}, {3, -1.0}, {4, 0.03}, {5, 2.8}}; data = Table[{1, 1.2 - j*.2} i, {j, 4}, {i, data1}]; Logit[p_] = Log[p/(1 - p)]; Invlogit[x_] = Exp[x]/(1 + Exp[x]); ...


16

data = Import["orbit3d.out", "Table"]; (* Your Table is not needed; you can use [[...]] instead *) (*d=Table[{data[[i,2]],data[[i,3]],data[[i,4]]},{i,1,Length[data]}];*) d = data[[All, 2 ;; 4]]; l = Line[d]; (* Projections on bounding box *) lz = l /. {x_, y_, z_} -> {x, y, -5.5}; ly = l /. {x_, y_, z_} -> {x, 5.5, z}; lx = l /. {x_, y_, z_} -> ...


16

a = .2; base = Polygon[{{-a, -a, 0}, {-a, a, 0}, {a, a, 0}, {a, -a, 0}}/2]; r = 2 a; Graphics3D[{ GeometricTransformation[ base, Flatten[ Table[ TranslationTransform[{x, y, 0}] @* RotationTransform[ {{0, 0, 1}, Cross[{1, 0, .5 y}, {0, 1, -.5 x}]}], {x, - r, r, a}, {y, - r, r, a} ], 1] ], { Thick , ...


15

Using the same initialization code as Taiki: origin = {0, 0, 0}; points = {{-0.9207, -0.3896, 0.0091}, {-0.8272, 0.5077, -0.2399}, {0.2544, -0.3511, 0.901}, {0.351, 0.6527, 0.6712}, {0.5436, -0.6326, -0.5513}, {0.6016, 0.2317, -0.7643}}; fs = {{1, 3, 5}, {1, 2, 4, 3}, {1, 2, 6, 5}, {3, 4, 6, 5}, {2, 4, 6}}; faces = points[[#]] & /@ fs; Then ...


15

Circle Let's create circle3D that is something you would expect from Circle but with an extra argument for its normal vector. With circle3D[centre_: {0, 0, 0}, radius_: 1, normal_: {0, 0, 1}, angle_: {0, 2 Pi}] := Composition[ Line, Map[RotationTransform[{{0, 0, 1}, normal}, centre], #] &, Map[Append[#, Last@centre] &, #] &, ...


14

Let me add another answer. This code is much shorter and faster than my previous one, and the resulting mesh of each face is much cleaner. The procedure is simple. Triangles are first made from the given face vertices and discretised. Each mesh point is then pushed onto a 2-sphere while its angular positions are maintained. points = { {-0.9207, -0.3896, ...


14

center = Normalize@{1, 2, 3}; point = Normalize@{0, 2, 1}; with minimum of algebra: Show[ ParametricPlot3D[ Evaluate[ N[center + RotationMatrix[t, center].(point - center)]], {t, 0, 2 Pi}], Graphics3D[{Sphere[], Blue, Sphere[{center, point}, .05]}] , PlotRange -> 1.1 ]


14

The blue line occurs at the edge of the function, where ϕ wraps from 2π to 0. We can get rid of it by adding BoundaryStyle -> None: SphericalPlot3D[ Abs[.5 + Sin[2 ϕ]/2] Sin[θ] + Abs[.5 + Sin[2 (ϕ + π/2)]/2] Sin[θ], {θ, 0, π}, {ϕ, 0, 2 π}, PlotStyle -> {Opacity[0.3], Yellow}, BoxRatios -> {1, 1, 1/2}, MeshFunctions -> {#3 &}, ...


14

One very clean way to do this is via x3dom, which is a javascript framework for deploying the x3d standard. The library is well supported by modern browsers, and the output is an html file with a supporting archive of x3d files. It is generally very clean and fast, and it does not require any external plugins. The library can be called from the x3dom site or ...


13

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


13

What about some 2D Geo functionality for this? points = {{-0.9207, -0.3896, 0.0091}, {-0.8272, 0.5077, -0.2399}, {0.2544, -0.3511, 0.9010}, {0.3510, 0.6527, 0.6712}, {0.5436, -0.6326, -0.5513}, {0.6016, 0.2317, -0.7643}}; edges = {{1, 2}, {1, 3}, {1, 5}, {2, 4}, {2, 6}, {3, 4}, {3, 5}, {4, 6}, {5, 6}}; Construct the geodesics as GeoPath objects: latlons ...


13

This can also be made a little lumpier with spherical harmonics. realization[r_] := Assuming[{0 <= θ <= π, 0 <= φ <= 2 π}, Simplify[r + Abs[ComplexExpand[Plus @@ Flatten[ Table[ RandomReal[{-1, 1}] 1/(l^2 + m^2) SphericalHarmonicY[l, m, θ, φ], {l, 1, 4}, {m, 0, l}] ]]]]] Block[{inner, outer}, outer = ...


12

A method of assembling 2d contour plots ... Show[Table[ Graphics3D@ First@Cases[ Normal@ContourPlot[y^2 == a*x, {x, 0, 2}, {y, -2, 2}, Frame -> False], Line[x_] :> {Hue[(a - 1)/4], Line[Append[#, a] & /@ x]}, Infinity], {a, 1, 5, .5}] ,PlotRange->All] ...


12

First, I defined dd as follows: dd = Entity["Polyhedron", "Dodecahedron"] (* regular dodecahedron *) Probing the properties of this Entity object, I can extract the vertex coordinates (I used Short here to truncate the output): dd["VertexCoordinates"]//Short (* {{-Sqrt[1+2/Sqrt[5]],0,Root[1-20 #1^2+80 #1^4&,3]},<<19>>} *) Now, I can use ...


12

Indeed, 3D plots like this were exported as vector graphics with generally huge numbers of polygons in version 8. But even then, the export was automatically rasterized whenever there were VertexColors present in the plot. I described this as a trick for getting smaller PDF files here, and also used it e.g. here. So in general, I think it's actually a good ...


12

Perhaps: gt = GeometricTransformation; box = gt[{box1, box2}, ScalingTransform[.1 {1, 1, 1}]]; cc[{x_, y_, z_}] := gt[gt[box, RotationTransform[{{1, 1, 0}, {x, y, 0}}]], TranslationTransform[{0, 0, z}]] Graphics3D[cc /@ listept] Edit A small generalization, just for fun: gt = GeometricTransformation; box = gt[{box1, box2}, ...


12

Very inefficient but short: I assumed that DiscretizeRegion of a Sphere gives us a mesh that have 5 or 6 triangles at each vertex. ms = DiscretizeRegion[Sphere[], MaxCellMeasure -> .01]; (*groups of polygons with one common vertex*) data = Sow[#, #[[1]]] & /@ MeshCells[ms, 2] // Reap // #[[-1, All, All, 1]] &; data0 = MeshCoordinates[ms]; ...


11

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


11

I know it's been more than two years since the question was asked but please allow me to answer nevertheless for future reference. According to Wikipedia articles on Mollweide and equirectangular projections, the function mollweidetoequirect that converts the former to the latter can be constructed as follows: lat[y_, rad_:1] := ArcSin[(2 theta[y, rad] + ...


10

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


10

Changing the rendering engine to BSPTree seems to help for me: SetOptions[$FrontEnd, RenderingOptions -> {"Graphics3DRenderingEngine" -> "BSPTree"}] Not sure if this is the best solution, but do try it out.



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