找琼脂

之前试着重写了搜索静物的代码：把找静物看做是一个布尔可满足性问题，然后用 Mathematica 自带的 SatisfiabilityInstances 函数。这样找静物还行，比原来还快一些。但找振荡子就出奇地慢，至今没找到过周期大于3或者大小大于10x10的振荡子。

不过，那个代码略作修改之后，倒是可以用来找琼脂（Agar，与振荡子或静物类似，但在空间上也是周期性的，覆盖整个平面）。找琼脂同样也很慢，但至少在周期2，也有不少个头不大的有趣的琼脂。

With[{w = 5, h = 5, p = 2, n = 1}, 
 Block[{r = RandomInteger[1, {w, h, p}]}, 
  Transpose[
     Mod[r + ArrayReshape[Boole@#, {w, h, p}], 2], {2, 3, 1}] & /@ 
   SatisfiabilityInstances[
    Array[BooleanConvert[(! 
              b[##] && (b[#, #2, #3 + 1] \[Equivalent] 
               BooleanCountingFunction[{{3}}, 
                Flatten@Array[b, {3, 3, 1}, {##} - {1, 1, 0}]~Delete~
                 5])) || (b[##] && (b[#, #2, #3 + 1] \[Equivalent] 
               BooleanCountingFunction[{{2, 3}}, 
                Flatten@Array[b, {3, 3, 1}, {##} - {1, 1, 0}]~Delete~
                 5])) //. {b[0, j_, t_] :> b[w, j, t], 
           b[w + 1, j_, t_] :> b[1, j, t], b[i_, 0, t_] :> b[i, h, t],
            b[i_, h + 1, t_] :> b[i, 1, t], 
           b[i_, j_, p + 1] :> b[i, j, 1]} /. {b[i_, j_, t_] /; 
            r[[i, j, t]] == 1 :> ! b[i, j, t]}, "BFF"] &, {w, h, p}, 
      1, And] && 
     Array[BooleanConvert[! Equal @@ Table[b[##, t], {t, p}], 
         "BFF"] /. {b[i_, j_, t_] /; r[[i, j, t]] == 1 :> ! 
           b[i, j, t]} &, {w, h}, 1, Or], Flatten@Array[b, {w, h, p}],
     n]]]

下面是找到的一些结果，都是周期2：

• 4x4：

• 5x5：

这个代码还是太慢，没法用来找周期3的琼脂。