Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: Fractal grammars/creation

• To: mathgroup at smc.vnet.net
• Subject: [mg9384] Re: Fractal grammars/creation
• From: "Xah" <xah at best.com>
• Date: Sun, 2 Nov 1997 01:02:17 -0500
• Organization: smtp.best.com
• Sender: owner-wri-mathgroup at wolfram.com

In article <63etm1$k0c at smc.vnet.net>, Kushner <maxnco at asan.com> wrote:

>I am trying to generate fractals via transformations. This involves
>methods used by Hilbert, Peano, and Mandelbrot, among others. 
>(how to) ...

Mathematica is perhaps the best tool for doing this, and there are a lot
codes about it out there. At the end of this message is a quick code
that recursively generates a 30-60-90 triangle tiling. After that is a
more general code that needs my package PlaneTiling.m. (available at my
website) The general version allows you to generate all recursive
graphics with the condition that each shape can be defined in terms of
its parent shape. (write to me if you want detail)

Robert Dickau has done a lot on fractals with Mathematica. See his web
site <http://forum.swarthmore.edu/advanced/robertd/index.html>

 Xah, xah at best.com
 http://www.best.com/~xah/PageTwo_dir/more.html
 Mountain View, CA, USA

-------------
(*30-60-90 triangle tiling*)
Clear[rule];
rule=tri_triangle:>Module[{p1,p2,p3,p4,p5},
		{p1,p2,p3}=List@@tri;
		p4=(p2-p1)*2/3+p1;
		p5=(p3-p1)/2+p1;
		{triangle[p1,p5,p4],triangle[p3,p5,p4],triangle[p3,p2,p4]}
		];

gp=Nest[((#/.rule)&),
    N at triangle[{0,0},{Sqrt[3]/2,0},N at {Cos@#,Sin at #}&@(2*Pi/12)],4];

gp2=gp/.triangle[a_,b_,c_]:>{Line[{a,b,c,a}]};

Show[Graphics[{gp2}],AspectRatio->Automatic];

-------------
(*sphinx tiling*)


Needs["PlaneTiling`"];


Clear[shapePrimitive];
shapePrimitive::"usage"=
  "shapePrimitive[sidedness:(True|False),s,\[Alpha],{x,y}] represents a
shape \
having sense sidedness, scale s, orientation \[Alpha], and position
{x,y}.";


Clear[x,y,z,shape];
x=({Cos at #,Sin at #}&)@0*1/6;
y=({Cos at #,Sin at #}&)@(2*Pi/6)*1/6;
z={0,0};
shape=List at Polygon[{z,6*x,2*x+4*y,2*x+2*y,2*y}];


Clear[transformationRule];
transformationRule=
  shapePrimitive[m_,s_,\[Alpha]_,{x_,y_}]:>{
      shapePrimitive[Not at m,s*1/2,
        \[Alpha]+2*Pi/2,{x,y}+({Cos at #,Sin at #}&)@(\[Alpha])*s*1/2],
      shapePrimitive[Not at m,s*1/2,
        \[Alpha]+2*Pi/2,{x,y}+({Cos at #,Sin at #}&)@(\[Alpha])*s],
      shapePrimitive[Not at m,s*1/2,
       
\[Alpha],{x,y}+({Cos at #,Sin at #}&)@(\[Alpha]+If[m,1,-1]*2*Pi/6)*s*2/6],
      shapePrimitive[m,s*1/2,
        \[Alpha]+
          If[m,1,-1]*2*Pi/6*2,{x,y}+({Cos at #,Sin at #}&)@(\[Alpha])*
            s+({Cos at #,Sin at #}&)@(\[Alpha]+If[m,1,-1]*2*Pi/6*2)*s*1/6]};


Clear[initialImage];
initialImage=shapePrimitive[True,1,0,{0,0}];


Clear[shapePrimitiveCollection];
shapePrimitiveCollection=NestList[(#/.transformationRule)&,N at initialImage,3]
;

Clear[finalImageGP];
finalImageGP=
  shapePrimitiveCollection/.shapePrimitive[m_,s_,
        \[Alpha]_,{x2_,y2_}]:>(
          Translate2DGraphics[{x2,y2}])@(
            Rotate2DGraphics[{0,0},\[Alpha]])@(
              Transform2DGraphics[#*s&])@(
                If[m,Identity,Reflect2DGraphics[{1,0}]])@shape;


Show[Graphics[{
      N at Last@finalImageGP/.poly_Polygon:>{
            RGBColor[Random[],Random[],Random[]],poly}}],
  AspectRatio->Automatic,Frame->True];