# Tag Info

78

Here's what I came up with How I did it First we need a list of words. Here, I've taken the original list ordered by size. tally = Tally@ Cases[StringSplit[ExampleData[{"Text", "AliceInWonderland"}], Except@LetterCharacter], _?(StringLength@# > 4 \[And] # =!= "Alice" &)]; tally = Cases[tally, _?(Last@# > 10 &)]; tally = ...

69

This answer evolved over time and got quite long in the process. I've created a cleaned-up, restructured version as an answer to a very similar question on dsp.stackexchange. Here's my quick&dirty solution. It's a bit similar to @azdahak's answer, but it uses an approximate mapping instead of cylindrical coordinates. On the other hand, there are no ...

67

A preview Before I show any code, here's a preview of what is possible with some tweaking: First try Here's a go at implementing Wordle's layout algorithm, described at cormullion's link. First, let's generate the word data (this is pretty arbitrary): punctuation = ",/.<>?;':\"()-_!&" (* boring words: *) common = {"the", "of", "and", ...

50

The undocumented GraphicsMeshPointWindingNumber (probably not available on version 7) does exactly this — it gives you the winding number of a point. A point lies inside the polygon if and only if its winding number is non-zero. Using this, you can create a Boolean function to test if a point is inside the polygon inPolyQ[poly_, pt_] := ...

40

I dug up some simple analog circuit design definitions that I sometimes use to make diagrams for classes or problem sets. Mathematica is obviously very useful when you have to create iterative copies of circuit elements, as in this example (a chain of resistor-capacitor elements): Since this is for teaching purposes and not professional, you may forgive ...

38

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

34

======= Update ========= Great question! It inspired this Wolfram Blog article and includes most of the code below plus some apps and fractal layouts like this: I think it make sense to keep the older code blow for archival and historic purposes. ======= Older implementation ========= Excellent motivating creativity question. This is a bit big for a ...

30

Using the function winding from Heike's answer to a related question winding[poly_, pt_] := Round[(Total@ Mod[(# - RotateRight[#]) &@(ArcTan @@ (pt - #) & /@ poly), 2 Pi, -Pi]/2/Pi)] to modify the test function in this Wolfram Demonstration by R. Nowak to testpoint[poly_, pt_] := Round[(Total@ Mod[(# - RotateRight[#]) &@(ArcTan @@ (pt ...

29

My friend C.P and I worked out these solutions. The 1st is C.P.s' Here we go. First things to know: 1) New Graph[] and related functionality in v8.0.4 is powerful in the sense that it does not only create an image but also stores all the information, including vertex coordinates, in that Graph[] object. 2) There is a GridGraph[...] function that makes ...

27

Now that two of our resident Mathematica geniuses (genii?) have produced such awesome examples, there's not much room left for anyone else... :) But that didn't stop me - and I'm here to make you guys look good. I had an idea... I decided not to make a cloud, but a tale - or rather, a tail. I've pinched Szabolc's code to get the words and frequencies: ...

26

The first step is to rasterize the points, so let's just start there as an example: n = 512; g = Image[Map[Boole[# > 0.001] &, RandomReal[{0, 1}, {n, n}], {2}]] The trick is to exploit the distance image. Almost all the work is done here (and it's fast): i = DistanceTransform[g] // ImageAdjust // ImageData; We need a little more precomputation ...

26

Obtain the image: i = Import["http://i.stack.imgur.com/iab6u.png"]; Compute the distance transform: k = DistanceTransform[ColorNegate[i]] // ImageAdjust; ReliefPlot[Reverse@ImageData[k]] (* To illustrate *) Identify the "peaks," which must bound the Voronoi cells: l = ColorNegate[Binarize[ColorNegate[LaplacianGaussianFilter[k, 2] // ImageAdjust]]]; ...

20

Short answer Yes, it is possible to speed up the Delaunay-triangulation and make it as fast as it is in Matlab. If you are not afraid of some setup-work, then one possibility is to use a package which calls a c-implementation of the Delaunay-triangulation. One package I know is qh-math which is available in the Wolfram-library: This package includes ...

20

I propose a small modification to 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 ...

18

Given that the triangle might not exactly be isosceles, let's characterize this direction as being from the triangle's center towards the most distant vertex: ClearAll[direction]; direction[t_List] := With[{center = Mean[t]}, t[[First[Ordering[N[Norm /@ (# - center & /@ t)], -1]]]] - center] (Edit As @R.M. notes, N needs to be applied for ...

18

You could use this package to triangulate your polygon, and then use this barycentric formula on each of the triangles. inside[{{x1_, y1_}, {x2_, y2_}, r3 : {x3_, y3_}}, r : {_, _}] := # >= 0 && #2 >= 0 && # + #2 < 1 & @@ LinearSolve[{{x1 - x3, x2 - x3}, {y1 - y3, y2 - y3}}, r - r3] Example for a single triangle: tri = ...

18

The second "Neat Example" in the documentation for SmoothKernelDistribution contains this compiled function: (* A region function for a bounding polygon using winding numbers: *) inPolyQ = Compile[{{polygon, _Real, 2}, {x, _Real}, {y, _Real}}, Block[{polySides = Length[polygon], X = polygon[[All, 1]], Y = polygon[[All, 2]], Xi, Yi, Yip1, wn = ...

18

One strength of InterpolatingFunctions is that they can be used just about like any other function. Thus, a more or less analytic approach may be possible. It's hard to say for sure, without seeing your example, but here's a contrived example. pts1 = Table[{x, y, Sin[x] + Cos[y + 1]}, {x,-10,10}, {y,-10,10}]; f1 = Interpolation[Flatten[pts1, 1]]; ...

17

The first part of the problem is partitioning a shape into smaller parts of a roughly equal area. Then we can add little "tongues" on the pieces to make them interlock. One idea for partitioning is using either a Delaunay triangulation of a set of points (for triangular pieces) or a Voronoi tessellation (for many-sided polygons). Let's take for example ...

17

Sometimes speed is an issue if there are many polygons and or many points to check. There is an excellent reference on this issue under http://erich.realtimerendering.com/ptinpoly/ with the main conclusion that the angle summation algorithm should be avoided if speed is the objective. Below is my Mathematica implementation of the point in polygon problem ...

17

Another approach to this problem is computing the winding number by integrating $1/z$ centered on the point of interest along the contour of the polygon in the complex plane. Sure this isn't exactly efficient but still i think it's nice to see this working in action. And since complex integration is feasible in Mathematica i just tried :) ...

16

An alternative approach that does not require the ComputationalGeometry package: You can use a combination of ClusteringComponents and ComponentMeasurements as follows: Define chVertices[txtimg_] := Insert[#, First@#, -1] &@ ComponentMeasurements[ClusteringComponents[Binarize@txtimg, 2], "ConvexVertices"][[2, 2]] Example data: textimg1 = ...

16

This is just a quick sketching out of an answer (rescales galore!) textOnCurve[text_, f_, n_, p_: 0.01] := Text[Rotate[text, ArcTan @@ (f[Rescale[n + p, {0, 1}, {p, 1 - p}]] - f[Rescale[n - p, {0, 1}, {p, 1 - p}]])], f[n]] textCurve[string_, f_, stylef_: (# &), range_: {0, 1}] := With[{chars = ...

15

I will show a method that is conjectural, though i believe it is correct. It differs from the more common approach of using (quadratic) birational transformations to force singularities to be double points. More a detailed approach to that, see Madelina's response. Also I cover the exact case, although at least some of this could be adopted to the case of ...

15

For computing the genus of a plane algebraic curve implicitly defined by a squarefree polynomial $f(x,y)$ there are different softwares available in the literature. Remark: I assume you are interested in computing the genus when the coefficients of the defining polynomial of the curve are either integers or rationals right? This is the case of exact data. ...

15

I know think of at least one way of doing it slowly and in a bitmap approach: img[p_, r_] := Module[{f, closest, color, colors, n, t}, n = 250; colors = List @@@ {Red, Green, Blue, Yellow, Orange, Pink, RGBColor[0, 0, 0], Cyan, Magenta, Brown, Purple}; color[i_] := Module[{c}, c = colors[[1 + Mod[i, Length@colors]]]; If[i == 0, {1, ...

15

This following code that uses TetGen we will compute the volume of the convex hull. Needs["TetGenLink"]; TetraMaker[pts_, surface_, TetGenString_?StringQ] := Module[{inInst, outInst, coords, surface1, meshElements, facets}, inInst = TetGenCreate[]; TetGenSetPoints[inInst, pts]; facets = Partition[surface, 1]; ...

15

Here's my go at it. This tells you if two line segments intersect (unless they lie on the same line, in which case it fails horribly): ClearAll[segmentsIntersect]; segmentsIntersect[{a_, b_}, {p_, q_}] := Module[{s, t, soln}, soln = NSolve[a + t (b - a) == p + s (q - p), {s, t}]; If[Length@soln == 0, False, (0 <= s <= 1 && 0 <= t ...

15

Since ConvexHull doesn't support 3D points (and you incorrectly tried to compute the ConvexHull of the Graphics object) your code didn't work. Here is one way to do what I think you want (I left out of the step of the Cuboids but if you want that basically just offset your convex hull). Needs["TetGenLink"] pos = Position[DiskMatrix[{12, 10, 8}], 1]; ...

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