Re: Re: AMERICAN MATHEMATICAL MONTHLY -April
- To: mathgroup at smc.vnet.net
- Subject: [mg98582] Re: [mg98558] Re: AMERICAN MATHEMATICAL MONTHLY -April
- From: Chris Hill <chill at wolfram.com>
- Date: Mon, 13 Apr 2009 03:35:00 -0400 (EDT)
- References: <grcgfr$pil$1@smc.vnet.net>
At 02:50 AM 4/12/2009, Roger Bagula wrote: >I found what appears to be a new tile associated with Barnsley's > triangular affine. >The fourth transform algorithm is my own. >Riddle rotation of Barnsley affine: fractal animation > >http://www.mathematica-users.org/mathematica/images/d/db/affine_riddle.avi > >Clear[f, dlst, pt, cr, ptlst, M, p, a, b, c, n] >rotate[theta_] := {{Cos[theta], -Sin[theta]}, {Sin[theta], Cos[theta]}}; >n0 = 4; >dlst = Table[ Random[Integer, {1, n0}], {n, 10000}]; >a = b = c = 0.5; >M = {{{-1 + b, -1/2 + b/2 + a/2}, {0, a}}, {{b + c/2 - 1/2, >b/2 - c/4 + > 1/4}, {1 - c, c/2 - 1/2}}, {{c/2, -1/2 + a/2 - c/4}, {-c, -1 + a + > c/2}}, rotate[-Pi/((7/4 - >a/2 - b/2 - c/2)) + n*Pi/20].{{1/2 - a/2 - > b/2 - c/2, 3/4 - a/4 - b/4 - c/4}, {1 - a/3 - b/3 - c/3, 1/2 - a/6 - b/6 - > c/6}}} >a0 = Table[Det[M[[i]]], {i, 1, 4}] >FullSimplify[Apply[Plus, a0]] >rotate[-Pi/((7/4 - a/2 - b/2 - c/2))] >in = {{1 - b, 0}, {1 - b, 0}, {1/2, 1}, {1 - b, 0}}; >Length[in] >f[j_, {x_, y_}] := M[[j]]. {x, y} + in[[j]] >pt = {0.5, 0.5}; >cr[n_] := Flatten[Table[If[i == j == k == 1, {}, > RGBColor[i, j, k]], {i, 0, 1}, {j, 0, 1}, {k, 0, 1}]][[1 + Mod[n + > 1, 7]]]; >ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]}, > {j, Length[dlst]}]; >Table[Show[Graphics[Join[{PointSize[.001]}, ptlst[n]]], AspectRatio -> > Automatic, PlotRange -> All], {n, 0, 20}] Thanks for sharing that. Users of Mathematica version 7 can achieve a faster display of the result by using a single Point primitive with the VertexColors option instead of a long list of (color, Point) pairs. Here's a modified version using that optimization: Clear[f, dlst, pt, cr, ptlst, M, p, a, b, c, n]; rotate[theta_] := {{Cos[theta], -Sin[theta]}, {Sin[theta], Cos[theta]}}; n0 = 4; dlst = Table[Random[Integer, {1, n0}], {n, 10000}]; a = b = c = 0.5; M = {{{-1 + b, -1/2 + b/2 + a/2}, {0, a}}, {{b + c/2 - 1/2, b/2 - c/4 + 1/4}, {1 - c, c/2 - 1/2}}, {{c/2, -1/2 + a/2 - c/4}, {-c, -1 + a + c/2}}, rotate[-Pi/((7/4 - a/2 - b/2 - c/2)) + n*Pi/20].{{1/2 - a/2 - b/2 - c/2, 3/4 - a/4 - b/4 - c/4}, {1 - a/3 - b/3 - c/3, 1/2 - a/6 - b/6 - c/6}}} a0 = Table[Det[M[[i]]], {i, 1, 4}] FullSimplify[Apply[Plus, a0]] rotate[-Pi/((7/4 - a/2 - b/2 - c/2))] in = {{1 - b, 0}, {1 - b, 0}, {1/2, 1}, {1 - b, 0}}; Length[in] f[j_, {x_, y_}] := M[[j]].{x, y} + in[[j]] pt = {0.5, 0.5}; colors = List @@ # & /@ Flatten[Table[ If[i == j == k == 1, {}, RGBColor[i, j, k]], {i, 0, 1}, {j, 0, 1}, {k, 0, 1}]]; cr[n_] := colors[[1 + Mod[n + 1, 7]]]; ptlst[n_] := Point[Developer`ToPackedArray[ Table[pt = f[dlst[[j]], Sequence[pt]], {j, Length[dlst]}]], VertexColors -> Developer`ToPackedArray[cr /@ dlst]]; ListAnimate[ Table[Graphics[{AbsolutePointSize[1], ptlst[n]}, PlotRange -> {{-.1, 1.25}, {-.7, 1.1}}], {n, 0, 20}]] Chris Hill Wolfram Research