Three Dimensional Self Reproducing Cellular Automata

3d_cellular_automata.nb

Evolve2D[m_] := 
 ArrayPad[BlockMap[
   Mod[#[[2, 1]] + #[[2, 3]] + #[[1, 2]] + #[[3, 2]], 2] &, m, {3, 3},
    1], 1]
    
Evolve3D[m_] := ArrayPad[
  BlockMap[
   Mod[#[[1, 2, 2]] + #[[3, 2, 2]] + #[[2, 1, 2]] + #[[2, 3, 2]] + #[[
       2, 2, 1]] + #[[2, 2, 3]], 2] &, m, {3, 3, 3}, 1
   ],
  1
]

VoxelPlot[m_, opts : OptionsPattern[]] := Graphics3D[
  {EdgeForm[Black], Cuboid[#] & /@ Position[m, 1]},
  PlotRange -> Table[{1, Length[m] + 1}, 3],
  FilterRules[{opts}, Options[Graphics3D]]
]
 
(* 2D Automata *)
plus = Table[0, {i, 3}, {j, 3}];
plus[[2, 2]] = 1;
plus[[1, 2]] = 1;
plus[[2, 1]] = 1;
plus[[2, 3]] = 1;
plus[[3, 2]] = 1;

progression = NestList[Evolve2D, ArrayPad[plus, 6], 4];
ImageAssemble[
 MapIndexed[
  ArrayPlot[#1,
    PlotLabel -> 
     Style["Step " <> ToString[First@#2], FontSize -> 24],
    Frame -> None] &,
  progression
  ]
]

(* 3D Automata *)
plus3d = Table[0, {i, 3}, {j, 3}, {k, 3}];
plus3d[[2, 2, 2]] = 1;
plus3d[[1, 2, 2]] = 1;
plus3d[[2, 1, 2]] = 1;
plus3d[[2, 2, 1]] = 1;
plus3d[[3, 2, 2]] = 1;
plus3d[[2, 2, 3]] = 1;
plus3d[[2, 3, 2]] = 1;

plusProgression = NestList[Evolve3D, ArrayPad[plus3d, 5], 4];

ImageAssemble@
 MapIndexed[
  Rasterize[
    VoxelPlot[#1, Boxed -> False, 
     PlotLabel -> 
      Style["Step " <> ToString[First@#2], FontSize -> 24], 
     ViewAngle -> Pi/12, ViewPoint -> {Pi, 4 Pi/10, 1}]] &, 
  plusProgression]
  
(* Triceratops: This can take a while to run *)
triceratops = Module[{dino, memberQ},
   dino = 
    ExampleData[{"Geometry3D", "Triceratops"}, "BoundaryMeshRegion"];
   memberQ = RegionMember[dino];
   Table[If[memberQ[{i, j, k}], 1, 0], {i, -5, 5, 0.1}, {j, -5, 5, 
     0.1}, {k, -5, 5, 0.1}]
   ];
progression3d = NestList[Evolve3D, ArrayPad[triceratops, 40], 34];
images = Rasterize[
     VoxelPlot[#, Boxed -> False, ViewPoint -> {Pi, -Pi/2, Pi/2}, 
      ViewAngle -> Pi/14]] & /@ progression3d;
Export["triceratops.gif", 
 Join[images[[1 ;; 33]], {images[[33]], images[[33]]}, 
  Reverse[images[[1 ;; 33]]]], AnimationRepetitions -> 1, 
 "DisplayDurations" -> 0.15]