Tag Info

Hot answers tagged

82

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


71

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


68

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


56

The undocumented Graphics`Mesh`PointWindingNumber (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_] := ...


45

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


40

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


36

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


33

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


29

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


29

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


29

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


28

Well, you can use the undocumented RegionDistance which does exactly this as follows: (This answer, as written, only works for V9 as noted by Oska, for V10 see update below) here is a triangle in 3D region = Polygon[{{0, 0, 0}, {1, 0, 0}, {0, 1, 1}}]; Graphics3D[region] Now suppose you want to find the shortest distance from the point {1, 1, 1} in 3D ...


27

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


24

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


21

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


21

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


21

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


20

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


19

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


19

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


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

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

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


17

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


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

SystemModeler is one of the Wolfram products that allows building and simulating complex electric circuits - stand alone or as coupled to other systems, like thermodynamic or mechanical ones. This is an alternative answer. If you have latest SystemModeler 4 you can visually create a model there and then import it into Mathematica: Needs["WSMLink`"]; ...


17

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


17

Update: Using Raster3D and a variation of func that returns 4-tuples data3C = RandomReal[1, {10, 6}]; func3C = Nearest[{#, #2, #3} -> {##4, .03} & @@@ data3C]; tbl3C = Table[ First[func3C[{x, y, z}]] // Quiet, {x, 0, 1, .01}, {y, 0, 1, .01}, {z, 0, 1, .01}]; Examples: Row[Labeled[Graphics3D[Raster3D[tbl3C, ColorFunction -> #, ...



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