# Tag Info

33

A percolation network is just a kind of network, so I went in the direction of proposing a graph-theoretic approach. You seem to be measuring distances between nodes multiple times, but given the points don't move, you need only do it once: ed = Outer[EuclideanDistance, randPts, randPts, 1]; You can get the positions of the nodes you are trying to connect ...

33

For starters i tried an easy intuitive approach, namely, combining the best parts from each image adjusted for the different exposure times all into one HDR image. Let's start by importing all the images imageurls = "http://upload.wikimedia.org/wikipedia/commons/thumb/" <> # & /@ ...

33

Edit. I have produced an image which is "cleaner" looking than my original attempt, and the processing is faster too. As before we start by loading the images in order from darkest to brightest, and cropping away the artifacts from alignment. files = Reverse@FileNames["memorial*.png"]; images = ImagePad[Import[#], {{-2, -12}, {-35, -30}}] & /@ files; ...

28

This shows a way to parametrise a line using the method suggested by Rahul Narain in a comment, i.e. using Fourier to approximate the data with a set of sinusoids. I use Rationalize to convert all the reals back to rationals, this isn't necessary but it makes the expression look more like those used in Wolfram Alpha. param[x_, m_, t_] := Module[{f, n = ...

20

(I've been waiting for somebody to ask this question for months... :D ) Here's the Mathematica implementation of the Frobenius companion matrix approach discussed by Jim Wilkinson in his venerable book (for completeness and complete analogy with built-in functions, I provide these three): PolynomialEigenvalues[matCof : {__?MatrixQ}] := Module[{p = ...

17

Here is a hybrid recursive/StringReplaceList method. It builds a tree representing all possible splits. Now with a massive speed improvement thanks to Rojo's brilliance. elements = ToLowerCase @ Array[ElementData[#, "Symbol"] &, 112]; altelem = Alternatives @@ elements; f1[""] = Sequence[]; f1[s_String] := Block[{f1}, StringReplaceList[s, ...

16

================= UPDATE ====================== Due to @halirutan comment I'll add a note on realism. First of all pure water and clouds are not the best subject to simulate reflecations because they have fractal structure - meaning they tend to appear the same on different magnification scales. So it is hard to give impression to a human eye of refraction ...

16

This answer is going to be a bit of a sprawl. Please read on. I am going to present several methods of simulation, hopefully in increasing order of performance. Method 1 We can carry out the filling of seats, at least as I understand the puzzle, quite literally like this: fillseats[seats_List] := ReplacePart[seats, {{1}, {2}} + RandomChoice @ ...

16

This now has been discussed in Wolfram blog posts by Michael Trott: Part 1: Making Formulas… for Everything — From Pi to the Pink Panther to Sir Isaac Newton Part 2: Using Formulas... for Everything — From Complex Analysis Class to Political Cartoons to Music Album Covers Here is one of the example apps from blog - go read it in full - fun! Don't miss the ...

15

As you said, essentially you need binary search, since you have a sorted list and binary search has a logarithmic complexity. However, since the limiting numbers may not be present in the list some numbers may be present more than once we'd need modified binary search. Here is a possible implementation: (* maximum number smaller than the limit *) ...

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

Version 9 answer - use built-in functionality The symbols ImageCreateHDRI and ImageToneMapHDRI were present in version 8 but didn't seem to do anything. In version 9 there is functioning code behind them. This is all undocumented, and therefore liable to change before it is officially released, but here is what I've managed to dig up. ImageCreateHDRI ...

15

This is more of an add-on to Vitaliy's excellent answer, than a completely new approach. I wanted to try to simulate some of the image distortion that would be seen at the jar walls. A simple (though utterly wrong in a physics sense) way to do this is to make the demagnification vary according to the jar image intensity. Load a picture and the jar image, ...

15

Played with some image processing functions, get some rough procedure. Import the test image: img = Import["http://i.stack.imgur.com/H2Ksg.jpg"]; Do some gamma adjust to emphasize the edge: img // ImageAdjust[#, {0, 0, 5}] &; Draw rough edges: GradientFilter[%, 2, "NonMaxSuppression" -> True] // ImageAdjust Binarize and dilate it to form ...

15

This is an incomplete answer; I will continue it tomorrow. Work In Progress: errors may abound. Preamble hat-tip to Leonid For the variations with custom test or ordering functions we can snoop on applications of that function to deduce the algorithm that is used. In the case of the default methods we must rely on observed complexity and guesswork ...

14

GraphicsMeshPolygonIntersection[] is not documented; it builds full polygon triangulations. To handle holes, you can use: PolygonIntersection[a, b, FillingMethod -> "OddEvenRule"] or PolygonIntersection[a, b, FillingMethod -> "WindingRule"] To create the visualization: GraphicsMeshMeshInit[]; a = Polygon@RandomReal[1, {100, 2}]; b = ...

13

Here is a fairly simple approach using only higher level functions. First, note that StringCases does almost all the work for you. István mentioned it in passing, but it is more powerful than that. It has an Overlap option that you can set to True to get all possible decompositions in one go: elements = Table[ElementData[i, "Symbol"], {i, 112}]; ...

13

An image-based method ... just a curiosity: r = 10; (*half range*) i = step = 1/100; rndpts = RandomReal[{-r, r}, {200, 2}]; l = Graphics[{Thickness[.001 r], Line@{{{-r, -r}, {r, -r}}, {{r, r}, {-r, r}}}}]; lPlot[i_] := ListPlot[rndpts, PlotStyle -> {Black, PointSize[i/(2 r)]}, PlotRange -> {{-r, r}, {-r, r}}, ...

13

Let me add a few ideas, but be aware that this is unpolished code which was only hacked to show my points. I assume you have some kind of function $f(t;x_0,y_0,z_0)$ which gives you a trajectory starting at the initial point $(x_0,y_0,z_0)$ for $t=0$. I used $t$ only for convenience. Your function should be parametrized by the arc-lenc if you want a defined ...

13

It might be easier to use TriangularSurfacePlot3D to find the Delaunay triangulation of the points. For example, Needs["ComputationalGeometry"]; triangles[points_] := Module[{pl}, pl = TriangularSurfacePlot[ArrayPad[points, {{0, 0}, {0, 1}}]]; Cases[pl, Polygon[a_] :> Flatten[(Position[points, #[[{1, 2}]]] & /@ a)], Infinity]] ...

13

Using Accumulate for 20,000,000 size list. Time < 1 Hour Your timings seem way too high. On my PC, Accumulate on an 20.000.000-element packed array takes about 50ms. A For loop (not compiled!) needs about one minute for 20 million values. My PC may be fast, but not that fast. Make sure your array contains only machine-precision reals and is packed. ...

12

Update: I described an alternative approach based on built in plotting functions in this answer. That approach is not very practical here though because I need to be able to handle points at arbitrary positions while built in functions work with a rectangle-based mesh. I am still looking for improvements. I came up with this very naive approach and ...

12

Some really simple partial answers using the string patternmatcher: elements = ToLowerCase /@ Select[Table[ElementData[i, "Symbol"], {i, Length@ElementData[]}], StringLength[#] < 3 &]; StringReplace["archbishop", # -> {#} & /@ elements] /. StringExpression -> Join StringReplace["titanic", # -> {#} & /@ elements] /. ...

12

I think Nearest[] is the most effective way. You don't even need to sort your data. a = RandomReal[1, 100]; nf = Nearest@a; xmin = 0.01; xmax = 0.6; x0 = (xmin + xmax)/2; dx = (xmax - xmin)/2; nf[x0, {\[Infinity], dx}] // Sort {0.0117819, 0.013102, 0.0177269, 0.0356801, 0.040019, 0.0504563, \ 0.0627056, 0.0749593, 0.0758206, 0.106541, 0.107941, 0.112281, ...

12

Here's my version. I don't know how fast/slow it is compared to the other solutions, but at least is shortish. spiral[rlist_ /; Length[rlist] >= 2] := Module[{findCentre}, findCentre[zlist_] := Module[{coslst, theta, ind, k}, k = Length[zlist] + 1; coslst = Table[ With[{dist = N@Norm[zlist[[-1]] - zlist[[l]]]}, ((rlist[[k - 1]] ...

12

This is my implementation using Graphics primitives and rules. Here's the final result; the implementation details and edge cases follow. 1. General approach First, we start with a single square and build up a test grid: square = Polygon[{{0, 0}, {1, 0}, {1, 1}, {0, 1}}]; grid = Graphics[{EdgeForm[Black], FaceForm[None], Table[Transpose@First@square ...

12

We can substantially speed up the calculation for large primes by making some elementary observations about the Fibonacci series. There are two motivating ideas behind them: Almost all the properties of the Fibonacci series rely only on the field axioms, so that the theory of Fibonacci series (and linear recurrences in general) holds practically without ...

12

Here I will attempt to provide a basic implementation of the random forest algorithm for classification. This is by no means fast and doesn't scale very well but otherwise is a nice classifier. I recommend reading Breiman and Cutler's page for information about random forests. The following are some helper functions that allow us to compute entropy and ...

12

This is a straightforward application of FindClusters: ListPlot@FindClusters[#, 2] & /@ Transpose@PairSet // GraphicsRow See the DistanceFunction and Method options to further fine tune your clustering or use a different metric.

11

Here's a functional implementation of the binary method. The Fold operates only Log[2,n] times, performing either one or two "multiplications" each time. power[f_][a_, n_Integer] := With[{b = Reverse@IntegerDigits[n, 2]}, Last@Fold[ With[{p = f[#1[[1]], #1[[1]]]}, {p, If[#2 == 1, If[#1[[2]] === Null, p, f[p, #1[[2]]]], #1[[2]]]}] ...

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