# Tag Info

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} ]

48

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

34

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

28

Here's my attempt at a soccer/foot ball, updated with an improved surface model: First create the patches (code below): pl /@ {5, 6} Then stitch them together using FindGeometricTransform to help with the work. The patches are made using NDSolve and simple PDE over a polygonal region. (Pretty cool, I thought.) Then they have to be sized and "...

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

25

This is probably too slow to get a decent image, but here's a simple attempt. As JM suggests, you can use Geodesate to get a good set of points on the sphere. I used ContourPlot3D to plot a sphere whose radius increases in the vicinity of one of those points. Needs["PolyhedronOperations`"] pts = Geodesate[PolyhedronData["Icosahedron"], 2][[1, 1, 14 ;;]]; ...

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

23

I am not sufficiently skilled to be able to fake the ridges along each polygon, so here is my modest attempt: arc[center_?VectorQ, {start_?VectorQ, end_?VectorQ}] := Module[{ang, co, r}, ang = VectorAngle[start - center, end - center]; co = Cos[ang/2]; r = EuclideanDistance[center, start]; BSplineCurve[{start, center + r/co Normalize[(start + ...

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

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

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 /@ { "http://i.stack.imgur.com/FdfMj....

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

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

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

16

Below I'll use @J.M. convenient arc function from his answer to this question: Clear[arc] arc[center_?VectorQ, {start_?VectorQ, end_?VectorQ}] := Module[{ang, co, r}, ang = VectorAngle[start - center, end - center]; co = Cos[ang/2]; r = EuclideanDistance[center, start]; BSplineCurve[{start, center + r/co Normalize[(start + end)/2 - center], end}, ...

15

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

15

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

15

The approach that David took here can be reused in this context like so: vertices[faceIndex_] := N@Part[ PolyhedronData["TruncatedIcosahedron", "VertexCoordinates"], PolyhedronData["TruncatedIcosahedron", "FaceIndices"][[faceIndex]] ] rf[faceIndex_] := Module[{cp}, cp = Cross @@@ Partition[vertices[faceIndex], 2, 1, {1, 1}]; Function[{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

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

If more ad hoc, inexact approaches are welcome, one way to generate relatively uniform density of points on a sphere is to use Monte Carlo Lloyd's algorithm (modified for the spherical case): With[{points = 200, samples = 40000, iterations = 20}, Nest[With[{randoms = Join[#, RandomPoint[Sphere[], samples]]}, Table[Normalize@Mean@Extract[randoms, ...

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

13

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

13

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

13

A mathematical approach using $A_\text{g}$ irreps of $I_h$ symmetry group expressed in terms of spherical harmonics. First some data l[1] = 6; mlist[1] = {-5, 0, 5}; slist[1] = {Sqrt[7]/5, Sqrt[11]/5, -(Sqrt[7]/5)}; l[2] = 10; mlist[2] = {-10, -5, 0, 5, 10}; slist[2] = {Sqrt[187/3]/25, -(Sqrt[209]/25), Sqrt[247/3]/25, Sqrt[ 209]/25, Sqrt[187/3]/25}; l[...

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

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