之前试着重写了搜索静物的代码:把找静物看做是一个布尔可满足性问题,然后用 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的琼脂。
网友评论