Hot answers tagged

51

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


40

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


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

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

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


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


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

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

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

ef[pts_List, e_] := {Arrowheads[{0, .05, 0}], Arrow[ BezierCurve[ {pts[[1]], pts[[1]] + {0, 0, 1}, pts[[2]] + {0, 0, 1}, pts[[2]]}]]}; myfig = Graph[ {Style[1 -> 2, Thickness[0.005], Yellow], Style[1 -> 4, Yellow, Dashing[0.02]], Style[1 -> 6, Yellow], Style[2 -> 3, Green], Style[3 -> 4, Green], ...


11

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


10

RegionMeasure chooses a method which is slow when exact non-rational coefficients are present. I will correct this for a future version. Thanks for pointing it out. In Mathematica 10 the example works fast with approximate coefficients. In[1]:= Timing@RegionMeasure@N@ RegionIntersection[ Tetrahedron[{{0, 0, Sqrt[3/2]}, {2/Sqrt[3], 0, ...


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