Tag Info

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

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

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

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

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

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

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

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

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

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

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

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

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

img2 = ImageCrop[Image[Graphics[{Raster[cols]}, PlotRangePadding -> 0, ImagePadding -> 0, ImageMargins -> 0]], {343, 343}]; SphericalPlot3D[1 , {u, 0, Pi}, {v, 0, 2 Pi}, Mesh -> None, TextureCoordinateFunction -> ({#1, #2} &), PlotStyle -> Directive[Specularity[White, 10], Texture[img2]], Lighting -> "Neutral", ...

I've decided to write a simplification+extension of Mark's routine as a separate answer. In particular, I wanted a routine that yields Riemann sphere fractals not only for Newton-Raphson, but also its higher-order generalizations (e.g. Halley's method). I decided to use Kalantari's "basic iteration" family for the purpose. An $n$-th order member of the ...

Many of the approaches here use image processing functions and they are blazing fast and very cool. However, there are advantages of a primitives based approach. When studying fractals, sometimes you need vertex information of the approximations, for example. Also, I don't think these image based techniques extend easily to self-similar sets that are not ...

Other solutions: f2 = "Compile[{{arr,_Real,2}}, Module[{a,b,c,d},{a,b,c,d}=arr;" <> ToString[ InputForm@ Map[Mean, Partition[Tuples[{a, b, c, d}, 2], 4], {2}]] <> "],RuntimeAttributes->{Listable}]" // ToExpression; f3 = Compile[{{arr, _Real, 2}}, Module[{a, b, c, d}, {a, b, c, d} = arr; #], ...

Try this: SetAttributes[check, Listable] check[0] = 0; check[a_] := Count[Divisible[(1 + I) Range[100], a], True]; ArrayPlot[check[Table[a + b I, {a, -1, 1, 1/100}, {b, -1, 1, 1/100}]], ColorFunction -> GrayLevel] Why it looks nothing like the picture in the OP, I don't know...

As a first pass this is about 40% faster on my machine: iQ = # == Round@# &; check[a_, b_] := With[{s = (a^2 + b^2)}, Sum[Boole[iQ[(a c + b c)/s] && iQ[(a c - b c)/s]], {c, 100}]] ArrayPlot[ Table[If[a != 0 || b != 0, check[a, b], 0`], {a, -1`, 1, 1/100}, {b, -1`, 1, 1/100}], ColorFunction -> GrayLevel] This is using ...

As @acl mentioned in chat, your question really indicates that you should read some fundamental sources. Two that I'd recommend are: A First Course in Chaotic Dynamical Systems by Bob Devaney for a good overview of the mathematical theory. Mathematica in Action by Stan Wagon, specifically Chapter 11, for a more condensed overview but with specific ...

Thanks for @Mark McClure. Inspired by him, my original code is simplified. This seems also natural. f[v_] := Table[i + j, {i, Drop[Tuples[{0, 1, 2}, 2], {5}]}, {j, v}]/3.; d = Nest[Join @@ f /@ # &, N@{{{0, 0}, {1, 1}}}, 3]; Graphics[Rectangle @@@ d] It's also easily generalized to 3D: f[v_] := Table[ i + j, {i, Select[Tuples[{0, 1, 2}, 3], ...

I might as well... as a variation, here's a chaos game method for generating the carpet: With[{verts = DeleteCases[Tuples[{-1, 0, 1}, {2}], {0, 0}], n = 1*^6}, Graphics[{AbsolutePointSize[1/2], Point[NestList[(2 RandomChoice[verts] + #)/3 &, RandomReal[{-1, 1}, 2], n]]}]]

This is more or less equivalent to halirutan's approach, but slightly compacted (adapted from code I wrote ~ 10 years ago, before Tuples[] came along): Block[{n = 5, pos = Select[Tuples[2 {-1, 0, 1}/3, {2}], (Count[#, 0] < 2) &]}, Graphics[Nest[Function[g, (g /. v_ /; VectorQ[v, NumericQ] :> v/3 - #) & /@ pos], ...

cf = Compile[{{a, _Real, 1}}, Module[{z = 0 I, i = 0, max = 100}, While[i++ < max && Abs[z] <= 2, z = z^2 + a[[1]] + a[[2]]*I]; {Log[i], Abs[z]}], RuntimeAttributes -> {Listable}, CompilationTarget -> "C", RuntimeOptions -> "Speed", Parallelization -> True]; t1 = AbsoluteTime[]; data = Table[{i, j}, {j, -2, ...