Tag Info

Hot answers tagged

49

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


45

I'm going to brute force it numerically. First, let's define the function we're interested in: fun = KnotData[{3, 1}, "SpaceCurve"] Imagine that this function fun[t] describes the position of a moving point in time. The the magnitude of its velocity as a function of the time t is Sqrt[#.#] & [fun'[t]] I'm going to make an interpolating function ...


36

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


33

General remarks In General Relativity we work in a 4-dimentional Lorentzian manifold i.e. there is a metric tensor $g$ of signature $(+,-,-,-)$ or $(-,+,+,+)$. Theses signatures are mathematically equivalent and we choose the latter because of certain quite formal aspects even though there are some physically relevant reasons for choosing the former one. In ...


32

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


31

I'm coming to the party a bit late, but here's my approach. It should work for any two polygons, including non-convex and self-intersecting ones. winding[poly_, pt_] := Round[(Total@ Mod[(# - RotateRight[#]) &@(ArcTan @@ (pt - #) & /@ poly), 2 Pi, -Pi]/2/Pi)] cross[e1_, e2_] /; (N[Det[{Subtract @@ e1, Subtract @@ e2}]] === 0.) = ...


30

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


28

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


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


26

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


25

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


25

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. Equadiff 8, 49 (1994) [pdf] and references therein). However I'm going to implement the simplest method as possible. Just ...


24

Update With the approach described in detail below and the function given by J. M. in his answer, we can additionally introduce points to the lines which vary randomly in their size. This gives the look and feel of a pen not drawing with constant thickness due to outrunning ink: ParametricPlot[{{Cos[t] (2 + 7 Cos[2 t] - Cos[4 t])/8, Sin[t]^3 (3 - 2 Cos[2 ...


23

I recreated the animation on Wikipedia for those who like such things (I do). 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, ...


23

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


23

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, methodData, pdeData}, {ndstate} = NDSolve`ProcessEquations[Flatten[{pde, Γ}], ...


22

Here's one way to implement Yves's suggestion: (* arclength function *) trefarc = \[FormalS] /. First[NDSolve[ {\[FormalS]'[t] == Norm[KnotData[{3, 1}, "SpaceCurve"]'[t]], \[FormalS][0] == 0}, \[FormalS], {t, 0, 2 Pi}, Method -> "Extrapolation"]] (* length of trefoil *) end = trefarc[2 Pi]; With[{n = 25}, (* n - number of points to ...


22

Edit A new solution (no luck is needed now :P ): g[x_] := (a x + b)/(c x + 1); (*d is a scale factor or zero*) cent[x1_, x2_, x3_] := 1/3 ({x1, g[x1]} + {x2, g[x2]} + {x3, g[x3]}); fi = First@FindInstance[{ g@First@cent[x1, x2, x3] == Last@cent[x1, x2, x3], a/b != c != 0, x1 != x2 != x3, Element[{x1, x2, x3, g[x1], g[x2], g[x3],Sequence @@ ...


22

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


21

I prefer PolygonArea myself, but for version 7 users, there's this function by Mr.Wizard for non-intersecting polygons: polygonArea = Compile[{{v, _Real, 2}}, Block[{x, y}, {x, y} = Transpose[v]; Abs[x.RotateLeft[y] - RotateLeft[x].y]/2 ] ] It gives the same answer as the undocumented built-in (as it should).


21

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


21

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


21

I've decided to expand on my comment. Before I delve into the solution, let's all pause for a moment and marvel at the stereographic parametrization of a unit circle: $$\begin{pmatrix}\frac{1-t^2}{1+t^2}\\\frac{2t}{1+t^2}\end{pmatrix}$$ Sometimes also referred to as the Weierstrass substitution, it has often been used as a tool in the solution of algebraic ...


20

The idea is quite simple: Since any great circle can be parametrized as $\cos(\theta)u + \sin(\theta)v$ where $u$ and $v$ are two orthonormal vectors. One can start with $u=\{1,0,0\}, v=\{0,1,0\}$ and use RotationTransform to get out of the xy plane, then use RotationTransform again to spin around the z-axis to get all great circles with desired inclination. ...


20

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


20

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


19

How about RegionPlot? RegionPlot[ { (x - 0.2)^2 + y^2 < 0.5 && 0 < x < 1 && 0 < y < 1, (x - 0.2)^2 + y^2 < 0.5 && ! (0 < x < 1 && 0 < y < 1), ! ((x - 0.2)^2 + y^2 < 0.5) && 0 < x < 1 && 0 < y < 1 }, {x, -1, 1.5}, {y, -1, 1.5}, PlotStyle -> ...


19

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


19

I think you should not be looking at Graph, which is for graph plotting. This is really a graphics question. Looking at your example, I see one or more curves split into (equal?) segments, and then the division points connected with straight lines. So we can base this on this answer (please check there for the code). After dividing a single curve into ...


18

As a starting point: ParametricPlot[{ (* modified hypotrochoid *) {Cos[t] (2 + 7 Cos[2 t] - Cos[4 t])/8, Sin[t]^3 (3 - 2 Cos[2 t])/4}, (* lemniscate of Bernoulli *) 3/2 {1, Cos[t]} Sin[t]/(1 + Cos[t]^2)}, {t, 0, 2 Pi}, Axes -> None, Background -> ColorData["Legacy", ...



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