Tag Info

Hot answers tagged

58

This seems the most natural to me: carpet[n_] := Nest[ArrayFlatten[{{#, #, #}, {#, 0, #}, {#, #, #}}] &, 1, n] ArrayPlot[carpet @ 5, PixelConstrained -> 1] Shorter (in InputForm), but perhaps harder to read and slightly slower, though speed hardly matters given the geometric memory usage: carpet[n_] := Nest[ArrayFlatten @ ArrayPad[{{0}}, 1, ...


49

Use these 3 components: compile, C, parallel computing. Also to speed up coloring instead of ArrayPlot use Graphics[Raster[Rescale[...], ColorFunction -> "TemperatureMap"]] In such cases Compile is essential. Compile to C with parallelization will speed it up even more, but you need to have a C compiler installed. Note difference for usage of C and ...


27

This might be an excellent candidate for ParallelTable; MakeFractal[f_, nx_, ny_, {cx_, cy_}, {rx_, ry_}] := Module[{pts}, DistributeDefinitions[nx, ny, cx, cy, rx, ry, f]; pts = ParallelTable[f[x + I y], {x, cx - rx, cx + rx, (2 rx)/nx}, {y, cy - ry, cy + ry, (2 ry)/ny}]; ArrayPlot[Reverse@pts, ColorFunction -> "TemperatureMap"] ] ...


23

As the other answers have shown, it's fairly easy to map an image onto a parametrized surface using textures. It can be a bit tricky, though, getting the image to mesh well with the transformation. J.M. hit on the crucial issue, namely that we compute the image using points that map to the sphere with minimal distortion. This answer is largely an ...


22

The whole "fractal" is an exercise in rounding errors. Following all the links to some code, we find that something is considered an integer if its fractional part is less than 0.1. Using something similar to Mr.Wizard's answer: inQ = Abs[FractionalPart[N[#, 16]]] < 0.1 &; check[0 | 0., 0 | 0.] := 0; check[a_, b_] := With[{p = (a + b)/(a^2 + ...


21

Assuming you want a vector-based image, it's more efficient to cut holes: translations = {#, #} & /@ Complement[Tuples[{-1, 0, 1}, 2], {{0, 0}}]; shrink[{{x0_, y0_}, {x1_, y1_}}] := {{2 x0 + x1, 2 y0 + y1}, {x0 + 2 x1, y0 + 2 y1}}/3 children[sq : {{x0_, y0_}, {x1_, y1_}}] := With[{side = x1 - x0, newsq = shrink[sq]}, (newsq + #) & /@ (side ...


19

What is wrong: a) you're using exact arithmetic. b) You keep iterating even if the point seems to be escaping. Try this ClearAll@prodOrb; prodOrb[c_, maxIters_: 100, escapeRadius_: 1] := NestWhileList[#^2 + c &, 0., Abs[#] < escapeRadius &, 1, maxIters ] prodOrb[0. + 10. I] prodOrb[0. + .1 I] (if you don't need the entire list but ...


18

Quick&Dirty: pt = {0, 0}; full = MandelbrotSetPlot[]; r = 0.2; Column[{ Row[{"Zoom: ", Slider[Dynamic[r], {0.01, 1}]}], Row[ { LocatorPane[Dynamic[pt], Dynamic[Show[full, Graphics[{EdgeForm[Red], Transparent, Rectangle[pt + r, pt - r]}], ImageSize -> Scaled[.45]]]], Dynamic[ MandelbrotSetPlot[{pt + r, ...


16

This is a tricky case indeed, because what you basically ask for is compile-time evaluation (macro-style). Generally, the answer is to use meta-programming, to assemble the compiled expression at run-time. The reason your attempt did not work is that the expression you want to evaluate is too deep for Evaluate to be effective. Solution using in-place ...


15

After an initial attempt with a Graphics-based solution, it became apparent that raster-based solutions would be far more efficient. Methods based on ArrayPlot work nicely, but I wondered whether image-based manipulations might be the most efficient possible way, given that they would be optimized for precisely the kinds of operations being performed here. ...


15

Here are two methods using rules, shamelessly modified from a MathGroup posting (http://forums.wolfram.com/mathgroup/archive/2007/May/msg01356.html). rules = # -> ArrayPad[{{0}}, 1, #] & /@ {0, 1} f1[m_] := ArrayFlatten[m /. rules] drawSerp[n_] := ArrayPlot[Nest[f1, 1, n], Frame -> False] drawSerp[3] An alternative cute ASCII ...


15

Just a bit of fun with @acl's code: ArrayPlot[Table[ NestWhile[#^2 - (0. - 1 I) & , r + i I, Abs[#] < 2.0 &, 1, 10], {r, -2, 2, 0.005}, {i, -2, 2, 0.005}]]


15

You can still use box count, but doing it smarter :) Counting boxes with at least 1 white pixel from ImagePartition can be done more efficiently using Integral Image, a technique used by Viola-Jones (2004) in their now popular face recognition framework. For a mathematical motivation (and proof), Viola and Jones point to this source. Actually, someone ...


12

You can certainly draw 2D fractals, eg the Mandelbrot set ClearAll[mnd] mnd = Compile[{{m, _Integer}, {n, _Integer}, {steps, _Integer}, {maxiter, _Integer}, {xmax, _Real}}, Block[{z, c, iters = 0}, z = c = -xmax + 2.*xmax*n/steps - 0.5 + I*(-xmax + 2.*xmax*m/steps); While[(iters < maxiter) && (Abs@z < 2), iters++; z = z^2 ...


12

Mathematica's estimation routines are able to recover the Hurst exponent from the sample: BlockRandom[SeedRandom["mathematica.SE/58539"]; tlow = 1; thigh = 1000; tinc = 1; hurst = 0.4; dataz = RandomFunction[FractionalBrownianMotionProcess[hurst], {tlow, thigh, tinc}, 1]]; FindProcessParameters[dataz, FractionalBrownianMotionProcess[h]] {h -> ...


11

This is a compiled version of @wxffles answer (since I got bored waiting for the uncompiled version to finish on my slow home computer:) inQ = Compile[{a}, Abs[FractionalPart[a]] < 0.1]; check = Compile[{a, b}, With[{p = (a + b)/(a^2 + b^2), q = (a - b)/(a^2 + b^2)}, Sum[Boole[inQ[c p] && inQ[c q]], {c, 100}]], CompilationOptions ...


11

I think the lower quality you see has to do with the downscaling of the image. It is generated at 512x512 pixels which you can check if you right mouse click on the image, but it isn't displayed that way. So, if I change this to: OpenCLFractalRender3D[ImageSize -> 512] I get . As to your second question: of course you can use Mathematica to generate ...


11

Many plots can be speeded up by pre-generating the data set you want and then plotting the resulting list. In any case, it's not coincidence that Table and Plot have similar syntax, only that Plot does additional things like finding out the range to be displayed, the interpolation strength, and so forth. If you're already sure what kind of picture you want ...


11

I don't think there is a carpet graph built-in, but it's hard to be sure that something is not there. Still it's not hard to construct a Graph -- not quite the same thing as drawing it (I wasn't sure what you meant). There are probably more efficient ways, but adapting Mr.Wizard's carpet function, it is fairly straightforward to make an edge between ...


11

As I understand it, you'd like to dynamically illustrate how the chaos game works by showing how the points arise randomly. Here are two approaches, with enough code in common that we can practically do them both at once. Using Dynamic First, I think it's quite natural to do this with Dynamic. To do so, we set up an image called dynamicPic that we'll ...


10

The problem with the speed is that check is using brute force to count the Gaussian integers among the first 100 multiples of $(1+i)/(a + bi)$ by enumerating and checking them all. This count can be computed directly for about two orders of magnitude speedup simply by finding the least common denominator of the real and imaginary parts of the quotient: ...


9

One lame method would be to create a replacement rule which replaces one Rectangle's of an graphics which the appropriate 8 others. f[p_, {min_, max_}] := p/3 max + (1 - p/3) min; rule = Rectangle[{xmin_, ymin_}, {xmax_, ymax_}] -> With[{expr = Table[If[i =!= 1 || j =!= 1, Rectangle[{f[i, xmin, xmax], f[j, ymin, ymax]}, {f[i + ...


9

The image taken from MathWorld appears to be something like this: Image @ Rescale @ Table[Mod[x^2 + y^2, 100], {x, -50, 50}, {y, -50, 50}] In my opinion this is not a fractal, and it certainly isn't produced by iteration. You described it as "Moiré-like", which is a far better description. It is simply a uniformly sampled 2D parabola, modulo some ...


9

With a hue disk as you suggested (but slightly tweaked to get the colours in the right spot): hueDisk = With[{sectors = 360}, angle = 2 Pi/sectors; Table[{Hue[1 - i/sectors], EdgeForm[{Thick, Hue[1 - i/sectors]}], Disk[{0, 0}, 0.6, {\[Pi]/2 + i angle, \[Pi]/2 + (i + 1) angle}]}, {i, 0, sectors - 1}]]; Then we can use the FilledCurve technique to ...


9

I've written a package that allows you to easily generate images of self-similar sets in the plane. Here is a zip file containing that package, as well as a related package for digraph self-similar sets. Here's an example of its use that seems related to your needs. We first load the package, after placing it in our $Path, as described in the installation ...


8

With a compiled version you get it so fast, that you can manipulate it in real time. fc = Compile[{{in, _Complex, 0}, {c, _Complex, 0}}, Module[{iter = 0, max = 10, z = in}, While[iter++ < max, If[Abs[z = z^2 + c] > 2.0, Break[] ] ]; {Abs[z], iter} ], CompilationTarget -> "C", Parallelization -> True, ...


8

On version 7 you will need to use DistributeDefinitions: {xc, yc} = {0.5527, 0.9435}; r = 0.1; nx = 350; ny = 350; DistributeDefinitions[nx, ny, xc, yc, r]; pts = ParallelTable[ cosineEscapeTime[x + I y], {x, xc - r, xc + r, (2 r)/nx}, {y, yc - r, yc + r, (2 r)/ny} ]; For faster plotting try using ArrayPlot: ...


8

Here is my modest attempt, based on the formulae for stereographic projection in this Wikipedia entry (where the north pole corresponds to the point at infinity) and using a technique similar to the one in this answer: newtonRaphson = Compile[{{n, _Integer}, {c, _Complex}}, Arg[FixedPoint[(# - (#^n - 1)/(n #^(n - 1))) &, c, 30]]] ...


7

Here is a "general" Lindenmayer System generator I wrote in the spirit of code-golf: f[i_, b_, h_, j_, r_, n_] := (a = h; p = j; s = k = {}; t = Flatten; (Switch[#, 6, s = {a, p, s}, 8, {a, p, s} = s, _C, k = {k, Black, Line@{p, p += {Cos@a, Sin@a}}}, _W, k = {k, White, Line@{p, p += {Cos@a, Sin@a}}}]; If[# < 9, a += I^# ...


7

I'm sure you can make it slicker, but one way to approach this is to change the plotrange dynamically. Here I've added four sliders to change the x and y scaling and the x and y offset. As in your original code, the amount of detail in the curve is given by the refinement variable. f[form_, {a_, b_}] := AffineTransform[{{b - a, ({{0, -1}, {1, 0}}).(b - ...



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