WireWorld

Author

Eric W. Weisstein
April 15, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/CellularAutomata/WireWorld.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/WireWorld.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Inspired by A New Kind of Science.  See page 1117.
Binary Multiplier by Nick Gardner

Code

Options[PPRaster]={Frame->False,MaxPixels->1,MaxWidth->9999,MaxHeight->9999,Margin->0};

ExpandRaster[datain_?MatrixQ,n_Integer]:=If[n==1,datain,Replace[datain,x_:>Sequence@@Table[x,{n}],2]]

PadCenter[A_List,max_List] := PadRight[PadLeft[A,Floor[(Dimensions[A]+max)/2]],max]

GridGraphics[list_?MatrixQ]:=Module[{xmax,ymax,x,y},{ymax,xmax}=Dimensions[list];
Graphics[{Raster[Reverse[1-list]],{GrayLevel[.15],AbsoluteThickness[.25],Table[Line[{{x,0},{x,ymax}}],{x,0,xmax}],Table[Line[{{0,y},{xmax,y}}],{y,0,ymax}]}},AspectRatio->Automatic]]

WWstep[list_] := Table[Function[x,Which[
x==0,0,x==1,2,x==2,3,
x== 3,If[Abs[Count[ Extract[list,
{{i-1,j-1},{i-1,j},{i-1,j+1},{i,j-1},{i,j+1},{i+1,j-1},{i+1,j},{i+1,j+1}}
],1]-1.5]==.5,1,3]]][list[[i,j]]],{i,1,Length[list]},{j,1,Length[list[[1]]]}]

Configurations

BinaryMultiplier

BinaryMultiplier =Map[IntegerDigits[#,10,263]&,
{,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,}];

AllGates

AllGates =Map[IntegerDigits[#,10,87]&,{000000000000000000000000000000000000000000000000000000000000000000000000000000000000000,000000033000000000000000000033000000000000000000033000000000000000000033000000000000000,002133300300000000000002133300300000000000003333300300000000000003333300300000000000000,000000003333333333333300000003333333333333300000003333333333333300000003333333333333300,002133300300000000000003333300300000000000002133300300000000000003333300300000000000000,000000033000000000000000000033000000000000000000033000000000000000000033000000000000000,000000000000000000000000000000000000000000000000000000000000000000000000000000000000000,000000003300000000000000000003300000000000000000003300000000000000000003300000000000000,000000030030000000000000000030030000000000000000030030000000000000000030030000000000000,002133300333300000000002133300333300000000003333300333300000000003333300333300000000000,000000000303333333333300000000303333333333300000000303333333333300000000303333333333300,002133300333300000000003333300333300000000002133300333300000000003333300333300000000000,000000030030000000000000000030030000000000000000030030000000000000000030030000000000000,000000003300000000000000000003300000000000000000003300000000000000000003300000000000000,000000000000000000000000000000000000000000000000000000000000000000000000000000000000000,002133333333330000000002133333333330000000003333333333330000000003333333333330000000000,000000000000003330000000000000000003330000000000000000003330000000000000000003330000000,000000000003030003000000000000003030003000000000000003030003000000000000003030003000000,002133300033300003000003333300033300003000002133300033300003000003333300033300003000000,000000030303030303003300000030303030303003300000030303030303003300000030303030303003300,000000030300003330030000000030300003330030000000030300003330030000000030300003330030000,000000030300000303300000000030300000303300000000030300000303300000000030300000303300000,000000003000000000000000000003000000000000000000003000000000000000000003000000000000000,000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}];

XOR Gate

Show[GraphicsArray[{GridGraphics[Take[#,{2,-2},{3,-2}]/3]&/@NestList[WWstep,PadCenter[{{0,0,0,0,0,0,0,0,0},{3,1,3,3,3,3,3,3,3},{0,0,0,0,0,0,0,0,0}},{11,11}],8],GridGraphics[Take[#,{2,-2},{3,-2}]/3]&/@NestList[WWstep,PadCenter[Transpose@{{0,0,0,0,0,0,0,0,0},{0,0,0,0,0,0,0,0,0},{0,0,0,3,3,3,0,0,0},{1,3,3,3,0,3,3,3,3},{0,0,0,3,3,3,0,0,0},{0,0,0,3,3,3,0,0,0},{0,0,0,0,3,0,0,0,0},{0,0,0,0,3,0,0,0,0},{0,0,0,0,3,0,0,0,0}},{11,11}],8],GridGraphics[Take[#,{2,-2},{3,-2}]/3]&/@NestList[WWstep,PadCenter[Transpose@{{0,0,0,0,0,0,0,0,0},{0,0,0,0,0,0,0,0,0},{0,0,0,3,3,3,0,0,0},{1,3,3,3,0,3,3,3,1},{0,0,0,3,3,3,0,0,0},{0,0,0,3,3,3,0,0,0},{0,0,0,0,3,0,0,0,0},{0,0,0,0,3,0,0,0,0},{0,0,0,0,3,0,0,0,0}},{11,11}],8]}]];

OR, XOR, and AND gates

<<Graphics`Colors`

movie=Show[PixelPerfect[#,BlockSize->4,
ColorFunction->(Switch[#,0,White,1,Red,2,Yellow,3,Black]&),
ColorFunctionScaling->False]]&/@NestList[WWstep,AllGates,22]

<<GIF`;

Export[gifs<>"wireworl.gif",movie]//Timing

Binary Multiplier picture

PPCellGraphics

Options[PPRaster]={Frame->False,MaxPixels->1,MaxWidth->9999,MaxHeight->9999,Margin->0};

PPRaster[raster_,dim_,opts___]:=Module[{margin,maxpixels,maxwidth,maxheight,ppc,m,m2},
{frame,maxpixels,maxwidth,maxheight,margin}={Frame,MaxPixels,MaxWidth,MaxHeight,Margin}/.{opts}/.Options[PPRaster];
ppc=Min[Floor[{maxwidth/dim[[1]],maxheight/dim[[2]],maxpixels}]];
m=margin*Max[dim];
m2=Ceiling[2 m];
Graphics[{raster,If[frame,{AbsoluteThickness[0.25],Line[{{-m,-m},{-m,dim[[2]]+m},dim+m,{dim[[1]]+m,-m},{-m,-m}}]},{}]},AspectRatio->Automatic,PlotRange->{{-m2,dim[[1]]+m2},{-m2,dim[[2]]+m2}},If[ppc==0,{},ImageSize->{ppc*(dim[[1]]+2 m2)+1,ppc*(dim[[2]]+2 m2)+1}]]]

Options[PPCellGraphics]={Levels->Automatic,Blocking->{1,1},BlockingLevels->None,Frame->Absolute,FrameWidth->2,FrameThickness->.25,Label->None,LabelDistance->None,GraphicsOptions->{},Colors->None,OverflowColor->RGBColor[0,0,0]};

PPCellGraphics[(list_)?MatrixQ,opts___]:=Module[{levels,blocking,blev,label,goptions,colors,ofc,array,raster},{levels,blocking,blev,label,goptions,colors}={Levels,Blocking,BlockingLevels,Label,GraphicsOptions,Colors}/.{opts}/.Options[PPCellGraphics];
If[levels===Automatic,levels=Max[Max[list]+1,2]];
array=If[blocking=!={1,1},Flatten/@Partition[list,{1,1},blocking],list];
array=Reverse[array];If[colors===Automatic,colors=$AutomaticColors];
If[colors===None,array=If[levels==2,1-array,array/.Table[i->(levels-1-i)/(levels-1),{i,0,levels-1}]];
raster=Raster[array],ofc=OverflowColor/.{opts}/.Options[PPCellGraphics];
raster=RasterArray[colors[[#1]]&/@(1+array)]];
PPRaster[raster,Reverse[Dimensions[array]],opts]]

Animation  (way too big)

k=1;

Do[
With[{r=ToString[1000+k]},
Export["C:\\WireWorld\\WW"<>r<>".gif",PPCellGraphics[Mod[3-ExpandRaster[BinaryMultiplier,2]+1,4]],"GIF"]];
BinaryMultiplier = WWstep[BinaryMultiplier];
k=k+1,{1661}]

Picture

Show[PixelPerfect[BinaryMultiplier,BlockSize->4,
ColorFunction->(Switch[#,0,White,1,Red,2,Yellow,3,Black]&),
ColorFunctionScaling->False]]