wolframscience.com

A New Kind of Science: The NKS Forum : Powered by vBulletin version 2.3.0 A New Kind of Science: The NKS Forum > Artistic NKS > Cellular Automata from Christmas 1983
  Last Thread   Next Thread
Author
Thread Post New Thread    Post A Reply
Stephen Wolfram
Wolfram Research
Boston, MA

Registered: Oct 2003
Posts: 13

Cellular Automata from Christmas 1983

There's a certain complexity to many of the characteristic forms used in Christmas images: snowflakes, Christmas trees, frost patterns, etc.

And as in so many other cases, it's rather easy to capture the essence of these forms using very simple cellular automaton rules.

So that means it's easy to use cellular automaton rules to make Christmas-like images.

Well, going through some of my archives recently, I was reminded that I did that almost exactly twenty years ago---for Christmas 1983. (The actual file date is November 22, 1983.)

I printed up four types of cards for Christmas 1983:

elementary rule 126, starting from a single black cell

k=3 totalistic code 357, with random initial conditions

k=5 totalistic code 44885, with random initial conditions

k=5 totalistic code 67020, with random initial conditions

or, in modern terms:

CellularAutomaton[126, {{1}, 0}, 150]

CellularAutomaton[{357, {3, 1}}, Table[Random[Integer, {0, 2}], {200}], 150]

CellularAutomaton[{44885, {5, 1}}, Table[Random[Integer, {0, 4}], {200}], 150]

CellularAutomaton[{67020, {5, 1}}, Table[Random[Integer, {0, 4}], {200}], 150]

Attached are scans of the original 1983 cards, together with modern versions made with the same rules (though with slightly different choices of random initial conditions).

It's of course inevitable, but I always find it pleasing that whatever year one makes a cellular automaton image, it always has the same fresh look. Somehow it reminds me of polyhedra from antiquity---that of course look just the same as polyhedra today.

Since 1983 lots of cellular automaton images have been used for Christmas cards---by me and others. And it'd certainly be great to see some of them posted to the Forum. But I thought members of the Forum might be amused to see my original 1983 efforts.

Note the absence in these efforts of rule 30 or anything like it. It wasn't until 1984 that I fully realized that simple initial conditions could still produce highly complex behavior. (See the NKS book, page 881, http://www.wolframscience.com/reference/notes/880b)

Report this post to a moderator | IP: Logged

Old Post 12-24-2003 03:36 AM
Stephen Wolfram is offline Click Here to See the Profile for Stephen Wolfram Visit Stephen Wolfram's homepage! Edit/Delete Message Reply w/Quote
Jason Cawley
Wolfram Science Group
Phoenix, AZ USA

Registered: Aug 2003
Posts: 712

Here are the card images...

Attachment: xmascards.zip
This has been downloaded 2669 time(s).

Report this post to a moderator | IP: Logged

Old Post 12-24-2003 04:18 PM
Jason Cawley is offline Click Here to See the Profile for Jason Cawley Click here to Send Jason Cawley a Private Message Edit/Delete Message Reply w/Quote
Dimitry Gashinsky


Registered: Oct 2003
Posts: 2

Ornaments

I created these pictures for holiday cards.

I was trying to make them look like glass ornaments with CA patterns.
You judge if I succeeded. I think they still look good on their own.

I could not attach file to this post.
You can try downloading it here:
http://barecode.com/files/XMaSphere.zip
or here
https://dam.digash.com/~dig/XMaSphere.zip

You could easily recreate all of them with this code.

code:
<<Graphics`Shapes` FlattenPosition[e_?MatrixQ,rc_:Automatic]:= Module[{r=rc}, If[r===Automatic,r=Max[e[[All,2]]]]; (#[[1]]-1)r+#[[2]]&/@e] SphereMatrix[m_?MatrixQ]:= Module[{s,h,w,pos}, {h,w}=Dimensions[m,2]; s=Sphere[1,h,w+2]; pos=FlattenPosition[Position[m,1]]; s[[pos]]]; Show[Graphics3D[{FaceForm[RGBColor[1,0,0],RGBColor[0,1,0]], SphereMatrix[Transpose[CellularAutomaton[60,{{1},0},40,{All,All}]]]}, ViewPoint->{-1.656, 2.170, 2.000},Lighting->False]]; PaddNumber[n_,p_]:=PaddedForm[n,p,NumberPadding->{"0","0"}] SetDirectory[ToFileName[{$HomeDirectory,"doc","NKS","XmaTranSphere"}]]; With[{s=32}, Do[Export["SpheresTranspose-"<>ToString[PaddNumber[i,2]]<>".gif", GraphicsArray[Partition[Table[Graphics3D[ SphereMatrix[Transpose[CellularAutomaton[j,{{1},0},40,{All,All}]]], {Boxed->False,PlotLabel->j,ViewPoint->{2.6, 1.6, 2.0}}], {j,s*i,s(i+1)-1}],3,3,1,Graphics3D[]]],ImageSize->1024],{i,0,Quotient[255,s]}]]; Do[Export["XMaTranSphere-"<>ToString[PaddNumber[i,3]]<>".gif", Graphics3D[{FaceForm[RGBColor[1,0,0],RGBColor[0,1,0]], SphereMatrix[Transpose[CellularAutomaton[i,{{1},0},50,{All,All}]]]}, {Lighting->False,Boxed->False,ViewPoint->{2.6, 1.6, 2.0}}], ImageSize->640],{i,0,255}]; Do[Export["XMaSphere-"<>ToString[PaddNumber[i,3]]<>".gif", Graphics3D[{FaceForm[RGBColor[1,0,0],RGBColor[0,1,0]], SphereMatrix[CellularAutomaton[i,{{1},0},50,{All,All}]]}, {Lighting->False,Boxed->False,ViewPoint->{2.6, 1.6, 2.0}}], ImageSize->640],{i,0,255}];

Last edited by Dimitry Gashinsky on 12-27-2003 at 04:48 PM

Report this post to a moderator | IP: Logged

Old Post 12-27-2003 04:11 PM
Dimitry Gashinsky is offline Click Here to See the Profile for Dimitry Gashinsky Click here to Send Dimitry Gashinsky a Private Message Visit Dimitry Gashinsky's homepage! Edit/Delete Message Reply w/Quote
Post New Thread    Post A Reply
  Last Thread   Next Thread
Show Printable Version | Email this Page | Subscribe to this Thread


 

wolframscience.com  |  wolfram atlas  |  NKS online  |  Wolfram|Alpha  |  Wolfram Science Summer School  |  web resources  |  contact us

Forum Sponsored by Wolfram Research

© 2004-14 Wolfram Research, Inc. | Powered by vBulletin 2.3.0 © 2000-2002 Jelsoft Enterprises, Ltd. | Disclaimer | Archives