# Tag Info

76

cow = ExampleData[{"Geometry3D", "Cow"}]; Manipulate[cow /. GraphicsComplex[array1_, rest___] :> GraphicsComplex[(# (Norm[#]^-coeff)) & /@ array1, rest], {{coeff, .25}, 0, 1}] Edit To answer to Clément's comment, here is same thing with constant plot range :

67

We can do this by building a regular hexagon tile and wrapping it onto a torus: hexTile[n_, m_] := With[{hex = Polygon[Table[{Cos[2 Pi k/6] + #, Sin[2 Pi k/6] + #2}, {k, 6}]] &}, Table[hex[3 i + 3 ((-1)^j + 1)/4, Sqrt[3]/2 j], {i, n}, {j, m}] /. {x_?NumericQ, y_?NumericQ} :> 2 π {x/(3 m), 2 y/(n Sqrt[3])} ] ht = With[{...

55

TL;DR Yes, this can be done! If you read the article "Hexagonal circle packings and Doyle spirals" by Leys, you will see that for a choice p and q, we need to find the complex values A, B and r. For that purpose, we can steal this part from the demonstration you linked: doyle[pi_, qi_] := Module[{p = pi, q = qi, s, t, r}, r[s_, t_, p_, q_] := (s^2 + ...

49

Edit: added Gradient -> grad[vars] option. Without this small option the code was several orders of magnitude slower. Yes, it can! Unfortunately, not automatically. There are different algorithms to do it (see special literature, e.g. Dziuk, Gerhard, and John E. Hutchinson. A finite element method for the computation of parametric minimal surfaces. ...

48

I propose a small modification of the parametrization for the torus that addresses issues with conformality. Try F[t_, u_, r_] := {Cos[t] (r + Cos[u + Sin[u]/r]), Sin[t] (r + Cos[u + Sin[u]/r]), Sin[u + Sin[u]/r]} instead. Next, we wish to choose suitable values for $m, n$ for a given $r$ such that the mapping of the ...

48

To answer your question: I don't think it's a bad or good idea to use If. It depends on how you do it. To demonstrate I'll use If combined very powerfully with Mathematica 10's ability to tell if a point is inside a specified region or not. step[position_, region_] := Module[{randomStep}, randomStep = RandomChoice[{{-1, 0}, {1, 0}, {0, -1}, {0, 1}}]; If[...

44

Mathematica wouldn't be much helpful if one applied only formulae calculated by hand. Here we demonstrate how to calculate the desired geometric objects with the system having a definition of the curve r[t] : r[t_] := {t, t^2, t^3} now we call uT the unit tangent vector to r[t]. Since we'd like it only for real parameters we add an assumption to Simplify ...

42

Update: Extended to Include 3D Shapes I have extended the workflow to include using 3D shapes including an imported 3D CAD object at the end of this answer. Original Post Here is a slight adaptation to my answer to your previous question here. It uses region functions, but not RegionIntersection. Rather it relies on the ray advancing to within the ...

40

A basic approach You can start with a regular density plot, restricted to the domain of x and y using RegionFunction. Then you can transform the plot to an equilateral triangle. f[p_, q_, r_] := r Sin[10 p]^2 + (1 - r) r Cos[20 q]^2; dp = DensityPlot[f[x, y, 1 - x - y], {x, 0, 1}, {y, 0, 1}, RegionFunction -> (#1 <= 1 - #2 &), ColorFunction -&...

40

Version 11 has both symbolic and numeric eigensolvers, see here for an overview Here is a slightly different way to do it. We write a function that converts any PDE (1D/2D/3D) into discretized system matices: Needs["NDSolveFEM"] PDEtoMatrix[{pde_, Γ___}, u_, r__, o : OptionsPattern[NDSolve`ProcessEquations]] := Module[{ndstate, feData, sd, bcData, ...

39

p1 = {Sin[t], Cos[t]}; p2 = {Cos[3 t], Sin[2 t]}; tAtMin = ArgMax[{EuclideanDistance[p1, p2]^2, 0 <= t <= 2 Pi}, t] tAtMax = ArgMin[{EuclideanDistance[p1, p2]^2, 0 <= t <= 2 Pi}, t] ParametricPlot[{p1, p2}, {t, 0, 2 Pi}, Epilog -> {PointSize[0.02], Red, Thick, Dashed, Through[{Point, Line}[{p1, p2} /. t -> tAtMax]], Darker@Green, ...

38

I recreated the animation on Wikipedia: Here is the Manipulate version: R = 3; r = 1; fx[θ_, a_: 1] := (R + r) Cos[θ] - a r Cos[(R + r) θ/r]; fy[θ_, a_: 1] := (R + r) Sin[θ] - a r Sin[(R + r) θ/r]; gridlines = Table[{x, GrayLevel[0.9]}, {x, -6, 6, 0.5}]; plot[max_] := ParametricPlot[ {fx[θ], fy[θ]}, {θ, 0, max}, PlotStyle -> {Red, Thick}, ...

38

Edit V10! This is simple example what we can now do in real time! R = RegionUnion @@ Table[Disk[{Cos[i], Sin[i]}, .4], {i, 0, 2 Pi, Pi/6.}]; R2 = RegionBoundary@DiscretizeRegion@R; go[] := (While[r > .105, x += v; r = RegionDistance[R2, x]; Pause[.01]]; bounce[];) bounce[] := With[{normal = Normalize[x - RegionNearest[R2, x]]}, If[break, Abort[]]; v ...

37

EDIT 01: The original code had an issue when the angle of the ray is counterclockwise from the normal of the circle, which I didn't catch. The code should be correct now, I think. RegionIntersection and friends are really nice functions if you just need to find a couple of values, but it looks to me like RegionIntersection will be called 500 times (since ...

30

Just wanted to update everyone that things are much simpler, - there is built in support for this: MeshFunctions -> {"ArcLength"} So for our case: Show[{ ParametricPlot3D[KnotData[{3, 1}, "SpaceCurve"][t], {t, 0, 2 Pi}, (* the trick *) Mesh -> 15, MeshFunctions -> {"ArcLength"}, (* styles *) MeshStyle -> Directive[Red, ...

30

There is an explicit formula n = 30; m = 10; f[t_, u_] := {Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]), Sin[u]}; Graphics3D[Polygon /@ Table[ f[(4 π)/(3 n) (Cos[π k/3] + i 3/2), (2 π)/(Sqrt[3] m) (Sin[π k/3] + (j + i/2) Sqrt[3])], {i, n}, {j, m}, {k, 6}]] % /. Polygon -> Tube I find it a bit simpler than rm -rf's solution. Here f transforms from ...

30

The following is based on the fact that the determinant of a matrix is equal to zero when two rows are the same. Thus, if you plug any of the points in, you get a true statement. SeedRandom[3]; pts = RandomReal[{-1, 1}, {5, 2}]; row[{x_, y_}] := {1, x, y, x*y, x^2, y^2}; eq = Det[Prepend[row /@ pts, row[{x, y}]]] == 0 (* Out: 0.0426805-0.0293168x-0....

30

Here is a method that utilizes $H^1$-gradient flows. This is far quicker than the $L^2$-gradient flow (a.k.a. mean curvature flow) or using FindMinimum and friends, in particular when dealing with finely discretized surfaces. Background For those who are interested: A major reason for numerical slowness of $L^2$-gradient flow is the Courant–Friedrichs ...

29

One way to approach is to calculate the basic triangle (with sides of lengths Sqrt[n], Sqrt[n+1] and 1) and then rotate it the correct amount so that they all fit together. sumAng[n_] := Sum[ArcTan[1/Sqrt[i]], {i, 1, n}]; poly[n_] := {{0, 0}, {Sqrt[n + 1], 0}, {Sqrt[n + 1], 1}}; Graphics[Table[Rotate[{Opacity[1], Hue[RandomReal[]], Polygon[poly[i]]}, ...

28

Fixed (see below) Here's an approach: r1 = Exp[-x^3 - y] - 1 == z; r2 = y == z; We create ImplicitRegions: reg1 = ImplicitRegion[r1, {x, y, z}]; reg2 = ImplicitRegion[r2, {x, y, z}]; The intersection of these regions is the line you seek: reg = RegionIntersection[reg1, reg2]; And here is the length (note the inclusion of the range of values in ...

28

Get cow as a mesh region: cow = ExampleData[{"Geometry3D", "Cow"}, "MeshRegion"]; Take coordinates of 0 cells: coords = MeshCoordinates[cow]; Get outer sphere that bounds cow: boundary = RegionBoundary @ BoundingRegion[cow, "MinBall"]; You could also try other bounds like "FastCapsule". For example, boundary = RegionBoundary @ BoundingRegion[cow, "...

27

There are many ways to proceed, the best one uses FrobeniusSolve : I Since we know, that a x + b == y /. Solve[{-4 a + b == 11, 16 a + b == -1}, {a, b}] // Simplify {3 x + 5 y == 43} we find FrobeniusSolve[ {3, 5}, 43] {{1, 8}, {6, 5}, {11, 2}} a bit more straightforward way : II {x, y} /. Solve[ (a x + b == y /. Solve[ {-4 a + b == 11, 16 a + b == ...

26

Here are three points in space. SeedRandom[2]; {p1, p2, p3} = {{x1, y1, z1}, {x2, y2, z2}, {x3, y3, z3}} = RandomReal[{-3, 3}, {3, 3}]; If the center is $p=(x,y,z)$ and the radius is $r$, then the distance from $p$ to each $p_i$ must be exactly $r$. Thus, for each $i=1,2,3$, we have $$(x - x_i)^2 + (y - y_i)^2 + (z - z_i)^2 = r^2.$$ Furthermore, the ...

26

Update: now it is real ternary plot. You can start with the 2D-adaptation of the surface plotting: texturize[f_, n_, colf_] := # /. Polygon[{v1_, v2_, v3_}] :> {EdgeForm[], Texture@ImageData@Colorize[Image@f[#1, #2, 1 - #1 - #2] &[#, Transpose[#]] &@ ConstantArray[Range[-1./n, 1 + 1/n, 1./n], n + 3], ColorFunction ->...

26

p1 = Partition[{{243.8, 77.}, {467.4, 12.}, {291.8, 130.}, {476., 210.5}, {103.2, 327.}, {245.2, 110.5}, {47.4, 343.}, {87.4, 108.5}, {371., 506.5}, {384.6, 277.}, {264.6, 525.5}, {353.8, 294.5}, {113.2, 484.5}, {296., 304.5}, {459.6, 604.5}, {320.2, 466.5}, {288.2, 630.5}, {199.6, 446.5}, {138.8, 615.5}, {81.8, 410.}, {232.4, 795.}, ...

26

The kite-domino tiling is based the pinwheel tiling which is falls out of a particular decomposition of a right triangle with legs of length 1 and 2. In the code that follows, rt[{a,b,c}] represents such a right triangle and dissect indicates how such a triangle should be decomposed into smaller copies of itself. We simply iterate the dissect function on ...

26

Hyperbolic lines in the Poincare disk are arcs of circles which, if extended, would meet the unit circle boundary orthogonally. Tiling the disk requires reflection of a tile's vertices and circular edges in those same circular edges. This corresponds to inversion in a circle. Begin with a central polygon having p edges, with q such polygons meeting at each ...

25

There is no need to use Eigensystem or Eigenvectors to find the axis of a rotation matrix. Instead, you can read the axis vector components off directly from the skew-symmetric matrix $$a \equiv R^T-R$$ In three dimensions (which is assumed in the question), applying this matrix to a vector is equivalent to applying a cross product with a vector made up ...

25

#/Total[#,{2}]&@Log@RandomReal[{0,1},{m,n}] will give you a sample of m points from a uniform distribution over an n-1-dimensional regular simplex. (An equilateral triangle is a 2-dimensional regular simplex.) Here's what m = 2000, n = 3 should look like, where {x,y} = {p[[2]]-p[[1]], Sqrt@3*p[[3]]} are the barycentric coordinates of the 3-element ...

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