Services & ResourcesWolfram ForumsMathGroup Archive

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

Re: Printing Cellular Automata

• To: mathgroup at smc.vnet.net
• Subject: [mg41654] Re: [mg41592] Printing Cellular Automata
• From: Tomas Garza <tgarza01 at prodigy.net.mx>
• Date: Thu, 29 May 2003 08:15:05 -0400 (EDT)
• References: <200305280857.EAA09488@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

I guess you should try other approaches. I didn't run your code, after
noticing you are using too many Do's, Table's and If's (procedural
programming) which is bad form in Mathematica.
First, you may try Wolfram's own code to produce Rule 30 cellular automata.
For the first 400 rows:

In[1]:=
Show[Graphics[Raster[
     1 - Reverse[NestList[
        Sign[BitAnd[2^ListConvolve[{1, 2, 4}, #1, 2],
           30]] & , IntegerDigits[2^100, 2, 201],
        400]]]], AspectRatio -> Automatic, Frame -> True,
   FrameTicks -> None]

This of course is pure and deep Mathematica programming, straight from the
horse's mouth. But I found it damn hard to understand, so I tried to write
one of my own (using the functional programming paradigm), resulting in the
following function of n (Rule number):

In[2]:=
celAutom[n_, row_] :=
  Module[{allAutos = Reverse[Table[IntegerDigits[j, 2,
        3], {j, 0, 7}]], z},
   z = Transpose[{allAutos, IntegerDigits[n, 2, 8]}];
    Drop[Rest[Partition[row, 3, 1, {-1, 1}] /.
       (#1[[1]] -> #1[[2]] & ) /@ z], -1]]

so that, for Rule 30,

In[3]:=
Show[Graphics[Raster[
     1 - Reverse[NestList[celAutom[30, #1] & ,
        IntegerDigits[2^100, 2, 201], 400]]]],
   AspectRatio -> Automatic, Frame -> True,
   FrameTicks -> None]

Needless to say, a fair amount of time and effort went into this. But it
worked all right, and the speed ratio was only about 2.18 in favor of
Wolfram's. And I'm talking of less than half a second to produce the first
400 rows (so I was absolutely delighted, not being a born computer
programmer and only a lightweight Mathematica practicioner).

Tomas Garza
Mexico City


----- Original Message ----- 
From: "Jeremy Foster" <jeremyrfoster at hotmail.com>
To: mathgroup at smc.vnet.net
Subject: [mg41654] [mg41592] Printing Cellular Automata


> I have been trying to create cellular automata. I realize that
> funtions exist already, but my ultimate goal is to print large posters
> of the results and so I am trying to do it manually.
>
> I have two issues: 1. My code takes an enormous amount of time and
> memory to run... it doesn't seem like it should be that difficult...
> and 2. The resulting bitmap file (TIF) does not come out crisp and
> defined... it has imperfections even when very large and thus won't
> print perfectly.
>
>
> Below is my code... please run it and see if you can help me optimize
> it and/or give me any clues on how to print it right:
>
> (*BitTest is the rule to see what value a certain cell should be... I
> am using the famous rule 30 here*)
> BitTest[i_, j_, k_] := If[(i==1 && j==0 && k==0) || (i==0 && j==1 &&
> k==1) || (i==0 && j==1 && k==0) || (i==0 && j==0 && k==1), 1, 0]
>
> (*A w value over ~800 takes major resources and usually fails before
> finishing*)
> w = 400;
> h = Floor[w/GoldenRatio];
> l1 = Table[1, {i, 1, h}, {j, 1, w}];
> l1[[h]] = Table[If[j == w/2, 1, 0], {j, 1, w}];
>
> (*Here's where I actually modify each row based on the previous row*)
> Do[Do[l1[[i, j]] = If[j > 1 && j < w, BitTest[l1[[i + 1, j - 1]],
> l1[[i + 1, j]], l1[[i + 1, j + 1]]], 0], {j, 1, w}], {i, h - 1, 1,
> -1}]
>
> (*Then I have to invert the values to match my logic*)
> Do[Do[l1[[i, j]] = If[l1[[i, j]]==0, 1, 0], {j, 1, w}], {i, 1, h}]
>
> (*I export the results as a tif file to avoid lossy compression, but
> it still doesn't look very good*)
> Export["Rule30.tif", ListDensityPlot[l1, {AspectRatio -> h/w,
> ImageSize -> {w, h}, Mesh -> False, Frame -> False}], "TIFF"]
>
>

• References:
  • Printing Cellular Automata
    • From: jeremyrfoster@hotmail.com (Jeremy Foster)