hashlife.ma

(* Conway's life rules *)
rule = {224, {2, {{2, 2, 2}, {2, 1, 2}, {2, 2, 2}}}, {1, 1}};

(* hashlife algorithm *)
lastId = 1;
h[x_] := (lastId = lastId + 1; h[x] = lastId; q[lastId] = x; lastId);
q2[i_] := ArrayFlatten[Map[q, q[i], {2}]];
step[i_, d_] := step[i, d] = Block[{
    i2 = q2[i],
    half = Map[step[h[#], d - 1] &, Partition[#, {2, 2}, 1], {2}] &},
   If[i2[[1, 1]] < 2,
     CellularAutomaton[rule, i2][[2 ;; 3, 2 ;; 3]],
     half[i2] //
      If[d > 0, half,
       Map[h, Partition[
          ArrayFlatten[Map[q, #, {2}]][[2 ;; 5, 2 ;; 5]],
          {2, 2}], {2}] &]
     ] // h
   ]

(* Additional utilities *)
level[0] = 0;
level[1] = 0;
level[i_] := 1 + level[q[i][[1, 1]]];
zero[0] = 0;
zero[l_] := zero[l] = h[{{#, #}, {#, #}}] &[zero[l - 1]];
empty[i_] := empty[i] = i == zero[level[i]];
pop[0] = 0;
pop[1] = 1;
pop[i_] := pop[i] = Total[pop /@ Flatten[q[i]]];
pad[i_] :=
  h[Map[h, Partition[
     PadLeft[q[i], {4, 4}, zero[level[i] - 1], {1, 1}], {2, 2}], {2}]];
unpad[i_] := Block[{x = q2[i]}, x[[2 ;; 3, 2 ;; 3]] = 0;
   If[Count[x, _?empty, {2}] == 16, h[q2[i][[2 ;; 3, 2 ;; 3]]], i]];
(* Wrapper around step[], run 2^d generations *)
run[i_, d_] := 
  FixedPoint[unpad, step[Nest[pad, i, Max[1, d + 2 - level[i]]], d]];

(* Input/output *)
fromArray[a_] := Block[{s = Max[2, Ceiling[Log[2, Length[a]]]]},
   h[Nest[Map[h, Partition[#, {2, 2}], {2}] &, 
     PadRight[a, {2^s, 2^s}], s - 1]]];
toArray[i0_, w_] := Block[{rec, z = zero[level[i0] - w]},
    rec[i_, 0] := If[i == z, 0, 1];
    rec[i_, d_] := Map[rec[#, d - 1] &, q[i], {2}];
    Nest[ArrayFlatten, rec[i0, w], w]
    ] /; w <= level[i0];
toArray[i_] := toArray[i, level[i]];

(* Golly's macrocell format *)
readMC::failed = "failed to parse Macrocell file";
readMC[text_] := Block[{read1, map, err},
   err := (Message[readMC::failed]; Throw[$Failed]);
   map[_] := err;
   read1[i_, l_?(StringMatchQ[#, RegularExpression["[.*$]+"]] &)] :=
    (map[i] = 
      fromArray[
       PadRight[
        Characters /@ StringSplit[l, "$", All] /. {"." -> 0, 
          "*" -> 1}, {8, 8}]];
     map[i]);
   read1[i_, l_?(StringMatchQ[#, RegularExpression["[0-9 ]+"]] &)] :=
    Block[{s, is},
     {s, is} = Through[{First, Rest}[FromDigits /@ StringSplit[l]]];
     If[Length[is] != 4, err];
     map[i] = h[Partition[If[# == 0, zero[s - 1], map[#]] & /@ is, 2]];
     map[i]];
   read1[___] := err;
   Catch[
    DeleteCases[
      StringSplit[text, 
       "\n"], _?(StringMatchQ[#, {"#", "[M2]"} ~~ ___] &)] //
     Last[MapIndexed[read1[#2[[1]], #1] &, #]] &
    ]
   ];