118
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 = ...
91
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 ...
89
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", "to", "...
78
The undocumented Graphics`PolygonUtils`PointWindingNumber (if you're on versions < 10, use Graphics`Mesh`PointWindingNumber) 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
...
58
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 ...
49
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 -...
49
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. ...
44
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 of ...
44
======= 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 ...
44
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]]];
...
41
We need quite a bit of preparation. In the first place we need methods to compute cell adjacency matrices from here. I copied the code for completeness.
CellAdjacencyMatrix[R_MeshRegion, d_, 0] := If[MeshCellCount[R, d] > 0,
Unitize[R["ConnectivityMatrix"[d, 0]]],
{}
];
CellAdjacencyMatrix[R_MeshRegion, 0, d_] := If[MeshCellCount[R, d] > 0,
...
40
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 Szabolcs's code to get the words and frequencies:
...
38
I guess the first step would always be to find an ordered list of points along the middle of the curve. That I can help with:
First binarize and thin the image of the curve, so you get a 1-pixel wide white line:
img = Import["http://i.stack.imgur.com/fEf1i.jpg"];
bin = Thinning@ColorNegate[Binarize[img]]
Finding the white pixels in this image is easy:
...
37
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, ...
35
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.) =
...
32
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 to ...
31
There is now a built-in version of an algorithm in v10.1: WordCloud. I wonder whether any of your nice algorithms introduced here had any influence on the built-in function...
Individual words can be styled, annotated, rotated, etc., so I must assume that there is a polygon-intersection checking algorithm running under the hood. Would be useful to know more ...
30
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 ...
30
Geodesics in Heat Algorithm
At the suggestion of @user21 I am splitting up my answers to help make the code(s) for calculating geodesics distances easier to find for other people interested in these sorts of algorithms.
The Geodesics in Heat algorithm is a fast approximate algorithm for estimating geodesic distances on discrete meshes (but also a variety ...
28
You'll be interested in the (undocumented!) functions Graphics`Mesh`IntersectQ[] (for checking the intersections) and Graphics`Mesh`FindIntersections[] (for actually finding them). As a sample:
BlockRandom[SeedRandom[42, Method -> "MersenneTwister"]; (* for reproducibility *)
lins = Table[{Line[RandomReal[1, {2, 2}]]}, {42}];]
Graphics`Mesh`...
answered Oct 27 '12 at 0:47
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
I guess I should not have been surprised that there are actually many ways to estimate the Gaussian and mean curvature of a triangular mesh. I shall present here a slightly compacted implementation of the MDSB method, with a few of my own wrinkles added in. I should say outright that the current implementation has two weaknesses: the determination of the ...
answered Jun 13 '16 at 5:57
27
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 ...
27
I've wrapped up @ybeltukov's code into a function that works for an arbitrary MeshRegion surface.
First we need to find the boundary vertices, which will remain fixed. If the MeshRegion represents a 2-dimensional manifold with boundary, then every internal vertex has as many edges as it has faces, but every boundary vertex has one extra edge.
...
26
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 ...
25
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 = ...
25
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 ...
24
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, 1,...
24
Here's a possible approach.
First use TetGen to tetrahedralize the data:
Needs["TetGenLink`"]
{pts, tetrahedra} = TetGenDelaunay[data3D];
Next define a function to compute the radius of the circumsphere of a tetrahedron (formula from Wikipedia)
csr[{aa_, bb_, cc_, dd_}] :=
With[{a = aa - dd, b = bb - dd, c = cc - dd},
Norm[a.a Cross[b, c] + b.b Cross[...
Only top voted, non community-wiki answers of a minimum length are eligible
