# Tag Info

67

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

55

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

29

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

27

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

24

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 + b^2)...

22

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

21

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

19

From a quick Google search I found Rob Lockhart's Wolfram Demonstration which plays around with this shape: Koch Snowflake Demo To save time, here are his definitions: TRI2 = {{-1, 0}, {0, Sqrt[3]}, {1, 0}, {-1, 0}} // N; INTRI2 = Reverse[TRI2]; SQU2 = {{-1, 1}, {1, 1}, {1, -1}, {-1, -1}, {-1, 1}} // N; INSQU2 = Reverse[SQU2]; TriRule2 = Flatten[...

18

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

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

17

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

16

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}]]

16

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

16

In the spirit of the season: I used a Lindenmayer (L-) system for the Koch snowflake. I extracted the points of the third generation (ks posted at the end), then interpolated and parametrized (after translation) and added some "decoration" to cover unsightly joins (that Mesh did not deal with): xif = ListInterpolation[ks[[All, 1]], {0, 1}, ...

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

15

Here's an overly detailed way to go about it. The extra detail will allow us to numerically approximate the volume of the object. First, here is some code that generates some approximations to the solid Koch snowflake. level = 4; Clear[triangles]; triangles[1] = Join[ Table[{{0, 0}, {Cos[t], Sin[t]}, {Cos[t + Pi/3], Sin[t + Pi/3]}}, {t, 0, 2 Pi - ...

14

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

13

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

13

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

12

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

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

11

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

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

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

11

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

11

Well, facinating question! Code first: Clear["`*"]; n = 5; steps = 1000; dir = {{0, 0}, {1, 0}, {0, 1}}; start = FromDigits[#, 2] & /@ Transpose@Append[RandomChoice[dir, n - 1], RandomInteger[1, 2]]; move[pt_] :=With[{c = RandomChoice@Pick[-dir, BitAnd @@ (# + pt) & /@ -dir, 0]}, pt + c +RandomChoice@DeleteCases[dir, -c]]; move[{2^n, 0}] := {2^n -...

10

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

10

Here is a "general" Lindenmayer System generator I wrote in the spirit of code-golf. Please beware that the objective of code-golfing is writing the shorter possible program to fulfill an objective, disregarding good practices, robustness, etc. Stay safe and don't use this style in real life. f[i_, b_, h_, j_, r_, n_] := (a = h; p = j; s = k = {}; t = ...

10

I try to use RevolutionPlot3D[f, {t, t1}], but I think there is no $f$ for Koch Snowflake. Here's one: f[t_, θ_, 0] := t AngleVector[θ] f[t_, θ_, n_] := Piecewise[{ {1/3 f[4 t, θ, n - 1], t <= 1/4}, {1/3 (AngleVector[θ] + f[4 t - 1, θ + π/3, n - 1]), 1/4 <= t <= 2/4}, {1/3 (AngleVector[θ] + AngleVector[θ + π/3] + f[4 t - 2, θ - π/3, n - ...

10

I don't have any breakthrough ideas, but I am able to cut the computation time in half on my computer by optimizing the usage of NDSolve. My version of your code looks like this: X[1] = 1; X[2] = -(1/2); X[3] = -(1/2); Y[1] = 0; Y[2] = Sqrt[3]/2; Y[3] = -Sqrt[3]/2; Sol[k_, c_, h_, xo_, yo_] := NDSolve[{ x''[t] + k x'[t] + c x[t] - Sum[(X[i] - x[t])/(h^...

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