Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2001
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2001

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

Search the Archive

Penrose Seasons Greetings

  • To: mathgroup at smc.vnet.net
  • Subject: [mg31862] Penrose Seasons Greetings
  • From: wself at msubillings.edu (Will Self)
  • Date: Fri, 7 Dec 2001 05:57:01 -0500 (EST)
  • Sender: owner-wri-mathgroup at wolfram.com

A Penrose Seasons Greetings to everyone!  Start a new Mathematica
session, copy the code below, paste it into a new notebook, and
evaluate the notebook.  You can drag the resulting picture to make it
bigger.  On an older computer, perhaps change the final 6 to 4, at
least to begin with.  Email me if you would like to have a notebook
with comprehensible version of the code.  --Will Self

(**** copy and paste below this line ****)

(c=N@GoldenRatio;z=Pi/5.;pi=N@Pi;gr=Graphics;
x=Cos;y=Sin;f=RGBColor[1,0,0];g=RGBColor[0,.8,0];
c1=x[z];s1=y[z];c2=x[2z];s2=y[2z];o={0,0};
p[1]={1,0};q[1]={1+c2,s2};r[1]={c2,s2}; 
s[1]={1,0};t[1]={1-c1,s1};u[1]={-c1,s1};
b[co_,ce_,rs_,rb_,a1_,a2_]:={co, 
Polygon[Join[{ce+rs{x[a1],y[a1]}},{ce+rb{x[a1],y[a1]}}, 
Table[ce+rb{x[t],y[t]},{t,a1,a2,.1}],
{ce + rb{x[a2],y[a2]}},{ce+rs{x[a2],y[a2]}}, 
Table[ce+rs{x[t],y[t]},{t,a2,a1,-.1}]]]};
aL[1]=gr[{b[f,{0,0},.68,.96,0.,z+.02],
b[g,{0,0},.44,.71,0.,z+.02]}];
aU[1]=gr[{b[f,{0,0},.68,.96,z-.02,2z],
b[g,{0,0},.44,.71,z-.02,2z]}];
bL[1]=gr[{b[f,{1,0},.68,.96,pi-z/2,pi],
b[g,{1,0},.44,.71,pi-z/2,pi]}];
bU[1]=gr[{b[f,u[1],.68,.96,-z,-z/2],
b[g,u[1],.44,.71,-z,-z/2]}];
m[ob_,an_,di_]:=ob/.{xx_?NumberQ,yy_?NumberQ}->
di+{x[an]xx-y[an]yy,y[an]xx+x[an]yy};
p[n_]:=c*p[n-1];q[n_]:=c*q[n-1];r[n_]:=c*r[n-1];
s[n_]:=c*s[n-1];t[n_]:=c*t[n-1];u[n_]:=c*u[n-1];
aL[n_]:=aL[n]={m[aU[n-1],pi,q[n-1]],
m[bU[n-1],z/2-pi/2,p[n-1]],m[aL[n-1],pi+z,q[n]]};
aU[n_]:=aU[n]={m[aL[n-1],pi,q[n-1]],
m[bL[n-1],0,r[n-1]],m[aU[n-1],4z,q[n]]};
bL[n_]:=bL[n]={m[bL[n-1],pi/2+z/2,p[n]-p[n-1]],
m[aL[n-1],-2z,t[n]]};
bU[n_]:=bU[n]={m[bU[n-1],-pi/2-z/2,u[n]-u[n-1]],
m[aU[n-1],4z,t[n]]};
cc[n_]:={m[{aL[n],aU[n]},pi,q[n]],m[{bL[n],bU[n]},0,r[n]]};
pp[ob_]:=Show[{ob,m[ob,2z,o],m[ob,4z,o],m[ob,6z,o],m[ob,8z,o]},
AspectRatio->Automatic];
pp[cc[6]];)

(******** down to here ********)


  • Prev by Date: Complicated Graph
  • Next by Date: Re: Fit[]: how to obtain the parameter values?
  • Previous by thread: Complicated Graph
  • Next by thread: Re: Surface graphics (Plot4D) coloring question