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


50

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


46

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


43

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


41

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["NDSolve`FEM`"] 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 ...


33

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


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

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


29

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


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

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


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


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


24

One standard way to detect circular shapes is to binarize the image and apply a distance transform: The maxima locations of the distance transform are the centers of the circles. To make this work on your ellipses, I first have to stretch them to be (roughly) circular, as @Rahul Narain suggested in a comment: img = ColorConvert[Import["http://i.imgur.com/...


24

After all this time, I came up with a very nice tensor calculus proof of the Hairy Ball Theorem. It only depends on Stokes theorem and standard laws of tensor calculus like the Ricci identity and symmetries of curvature tensors. All the topology is done by Stokes theorem. The remainder of the proof is equational, local and geometrical. It is coordinate/basis ...


23

I suggest using Mod - a natural thing for looped boundary conditions on a torus. Finite torus surface area is your bounded region. 2D random walk generally is simple: walk = Accumulate[RandomReal[{-.1, .1}, {100, 2}]]; Graphics[Line[walk], Frame -> True] Confinement to square region {{0,1},{0,1}} would be simple in principle with Mod[walk,1] (periodic ...


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