Re: Printing Cellular Automata
- To: mathgroup at smc.vnet.net
- Subject: [mg42042] Re: [mg41592] Printing Cellular Automata
- From: "Oyvind Tafjord" <tafjord at wolfram.com>
- Date: Tue, 17 Jun 2003 05:43:24 -0400 (EDT)
- References: <200305280857.EAA09488@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Hi, Responding to your two issues: 1) There are many efficient ways to implement cellular automata (see Stephen Wolfram's A New Kind of Science, code from the book is available at http://www.wolframscience.com/nks/programs), but the most efficient is to use the built-in CellularAutomaton function, available in Mathematica 4.2. 2) One can get crisp images by correlating the PlotRange and the ImageSize of the graphics, see the example below. MakeNiceRaster[data_]:= With[{dim=Reverse[Dimensions[data]]}, Graphics[Raster[1-Reverse[data]], AspectRatio -> Automatic, PlotRange -> {{0,dim[[1]]},{0,dim[[2]]}}, ImageSize -> dim+1]] This shows 100 steps of rule 30 (notice how crisp it looks on the screen): Show[MakeNiceRaster[CellularAutomaton[30,{{1},0},100]]]; This exports 500 steps to a TIFF file, using exactly one pixel per cell of the CA for a perfectly crisp result: Export["Rule30.tif",MakeNiceRaster[CellularAutomaton[30,{{1},0},500]]]; The generation of the data takes virtually no time using the CellularAutomaton function, e.g. 2000 steps: In[2]:= CellularAutomaton[30,{{1},0},2000];//Timing Out[2]= {0.491 Second,Null} Another way to create these images is with the new product A New Kind of Science Explorer: Mathematica Kit, which will in most cases handle these issues automatically. Hope this helps. Oyvind Tafjord Wolfram Research ----- Original Message ----- From: "Jeremy Foster" <jeremyrfoster at hotmail.com> To: mathgroup at smc.vnet.net Subject: [mg42042] [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"]