Hot answers tagged

53

Edit: Added the reversal and some refinements ω = 1; posP[t_, φ_] := Sin[ω t + φ] {Cos[φ], Sin[φ]} posL[φ_] := {-#, #} &@{Cos[φ], Sin[φ]} Animate[ Graphics[{PointSize[0.02], Table[{Black, Line[posL[π i]], Hue[i], Point[posP[t, π i]]}, {i, 0, 1, 1/(3π-Abs[9.43-t])}] }, PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}} ], {t, 0, 6π, 0.2} ]


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


42

I'd like to expand on Quantum_Oli's answer to give an intuitive explanation for what's happening, because there's a neat geometric interpretation. At one point in the animation it looks like there is a circle of colored dots moving about the center, this is a special case of so called hypocycloids known as Cardano circles. A hypocyloid is a curve generated ...


32

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

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


23

What you need to do here is to generate a ParametricPlot to give the 2D goat/silo problem, and then we can rotate it with RevolutionPlot3D. From reading the page on MathWorld, we can see that we need to make a circle involute to describe the portion of the area where the goat's circle is limited by the presence of the silo. In Cartesian coordinates, this ...


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


21

Image3D isn't what you're looking for. That actually generates a "3-dimensional image" with voxels instead of pixels (by using the given images as layers in the voxel grid). That's what you're seeing in the example you included. What you want is render a bunch of (square) polygons and use your images as textures. To do so you'll need Texture and the ...


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 *)


19

tl;dr Playing with your code I found that using Rasterize is a mayor pain in the behind because of various reasons (RasterSize is, at least for me, not working as advertised in the documentation; I found no easy way to remove padding around letters and get a nice $n \times n$ representation of each letter, get each letter the appropriate size, issues with ...


19

By using a cube with rounded corners, from this answer, and by applying the images as "stickers" onto the sides of this cube, the dice can be made to look a little bit more realistic. The black border does not translate well to a 3D visualization, so I hid it by fiddling with the vertex coordinates. faces = Import /@ { ...


17

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


17

From a quick Google search I found Rob Lockhart's Wolfram Demonstration which plays around with this shape: Koch Snowflake Demo To save time, here are his definitions: TRI2 = {{-1, 0}, {0, Sqrt[3]}, {1, 0}, {-1, 0}} // N; INTRI2 = Reverse[TRI2]; SQU2 = {{-1, 1}, {1, 1}, {1, -1}, {-1, -1}, {-1, 1}} // N; INSQU2 = Reverse[SQU2]; TriRule2 = ...


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


14

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


14

In the spirit of the season: I used a Lindenmayer (L-) system for the Koch snowflake. I extracted the points of the third generation (ks posted at the end), then interpolated and parametrized (after translation) and added some "decoration" to cover unsightly joins (that Mesh did not deal with): xif = ListInterpolation[ks[[All, 1]], {0, 1}, ...


14

Here's an overly detailed way to go about it. The extra detail will allow us to numerically approximate the volume of the object. First, here is some code that generates some approximations to the solid Koch snowflake. level = 4; Clear[triangles]; triangles[1] = Join[ Table[{{0, 0}, {Cos[t], Sin[t]}, {Cos[t + Pi/3], Sin[t + Pi/3]}}, {t, 0, 2 Pi - ...


14

moon = Import[ "https://upload.wikimedia.org/wikipedia/commons/f/f0/Full_Moon_as_\ Seen_From_Denmark.jpg"] Here are two ways to get something like that: with Texture or with ColorFunction Texture: pic = ImageCrop @ ImageResize[ColorConvert[moon, "Grayscale"], Scaled@.3] Worse quality than is possible with this image but I had to make it smaller ...


14

One way is to compute the solid angle subtended by the cow viewed at the point by summing signed solid angles corresponding to the cow's polygonal faces. If the total is 4 pi, the point is inside the cow; if 0, outside. Background Quoting Wikipedia, "Solid angle is the two-dimensional angle in three-dimensional space that an object subtends at a point." ...


13

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


13

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


13

Here is an approach based on direct construction of Image3D from ImageData. The basic idea is taken from the subsection "Volume Creation" of the section "Scope" on the Documentation page for Image3D, some other ideas are from the answer by Kuba: moon = Import[ "https://upload.wikimedia.org/wikipedia/commons/f/f0/Full_Moon_as_Seen_From_Denmark.jpg"]; ...


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


12

You can use FoldList to generate evolution of your system. You need a function that propagates your particles in time. Every time you apply your function to state at time $t$ you obtain your state at time $t+dt$. Let's make such function for one particle in 1D. Tr1D[{x_, v_}, dt_, L_] := Module[{u, w}, u = x + v dt; {u, w} = If[u < L, {u, v}, {L - ...


12

The short (and probably correct) answer is to download Mercury and get the CIF file from the Crystallograph Open Database. That way you can focus on your science and less on the, well fitting a square peg in a round hole. If you really want that square peg to fit in that round hole, however. First, recognize that Mathematica does not yet get a passing ...


12

This is basically a rehash of code I posted in a prior thread on this topic. The underlying method is to shoot a ray from the point and see how many surface triangles it intersects. elsie = ExampleData[{"Geometry3D", "Cow"}]; verts = First[Cases[elsie, GraphicsComplex[a_, ___] :> a, Infinity]]; pgons = First[Cases[elsie, Polygon[x_, ___] :> x, ...


11

Confirmed. These have already been implemented, but did not make it in time for the 10.2 release. DiscretizeRegion should work, however. Update Working as of Mathematica 10.3: DiscretizeGraphics[Graphics3D[SphericalShell[{0, 0, 0}, {1/2, 1}]]] BoundaryDiscretizeGraphics[Graphics3D[CapsuleShape[]]]



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