Tag Info

78

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 :

69

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/2 j], {i, n}, {j, m}] /. {x_?NumericQ, y_?NumericQ} :> 2 π {x/(3 m), 2 y/(n Sqrt)} ] ht = With[{...

57

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

49

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

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

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

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

38

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

37

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

32

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

31

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 m) (Sin[π k/3] + (j + i/2) Sqrt)], {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; 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, Hue[RandomReal[]], Polygon[poly[i]]}, ...

30

d = {#, 0} ~ Disk ~ ##2 &; Graphics @ {d[4, 8, {0, π}], 8~d~4, White, 0~d~4, d@8, Black, d@0, Circle @@ 4~d~8} StringLength @ "d={#,0}~Disk~##2& Graphics@{d[4,8,{0,π}],8~d~4,White,0~d~4,d@8,Black,d@0,Circle@@4~d~8}" 87 We can get the rotated version at a cost of three additional characters: Replace {#, 0} with {0,#} and {0, π} with {...

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

29

Unicode: \:262F (* ☯ *) For post-processing at higher resolution, we can rasterize this character to arbitrary pixel counts: Rasterize[\:262F, RasterSize -> 1000] // ImageCrop

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

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

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

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

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

23

With labels k = 1; angles = NestList[# - ArcTan[1./Sqrt[k++]] &, Pi, 15]; pts = Table[Sqrt[n]* {Cos[angles[[n]]], Sin[angles[[n]]]}, {n, 15}]; Graphics[{ Line[pts], Line[{{0, 0}, #}] & /@ pts, k = 2; Text["1", Sqrt[k++] {Cos[#], Sin[#]}] & /@ Mean /@ Most@Partition[angles, 2, 1], k = 1; Text[ToString[Sqrt[ToString[k]], ...

23

A crude attempt This is for Mathematica 10+ only. To construct each face, I use an intersection between a unit 3-ball centred at the origin and a pyramid whose base is at infinity and apex is at the origin. Each edge of the pyramid passes through each vertex of the spherical face. The pyramid is given by ConicHullRegion[{origin}, {vertices}]. The ...

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