本文适合对 Wolfram 语言感兴趣的小读者。2018年初网上出现一套所谓的《2018年刑侦科推理试题》。
搜索答案
让我们用 Wolfram 语言解答这个逻辑谜题。各题的答案用“a、b、c、d”四个小写英文字母（注：大写的“C、D”已经有各自的功能）表示，为了避免四个字母被赋值，先把它们保护起来：
代码语言：javascript复制SetAttributes[#, {Protected, ReadProtected}] & /@ {a, b, c, d};定义一个辅助函数，判断若干题目是否都已作答，参数“答案”是一个列表，包含 10 道题的答案，如果某题未答，则为 Indeterminate，不确定。
代码语言：javascript复制已作答[n_Integer, 答案_] := 答案[[n]] =!= Indeterminate;
已作答[l_List, 答案_] := FreeQ[答案[[l]], Indeterminate];然后定义判断函数，用来检查答案是否符合题干要求：如果符合，检查函数的结果为 True；如果不符合，结果为 False；如果有的题目还未作答导致无法判断对错，则结果为 Indeterminate。对于第 1 题，只要作答了，答案就是正确的；如果未作答，则结果为 Indeterminate。
代码语言：javascript复制检查[1, 答案_] := If[已作答[1, 答案], True, Indeterminate];检查第 2 题时，要求第 5 题也必须作答，如果有一题未答，则结果为 Indeterminate。
代码语言：javascript复制检查[2, 答案_] :=
If[已作答[{2, 5}, 答案],
答案[[5]] === (答案[[2]] /. {a -> c, b -> d, c -> a, d -> b}),
Indeterminate];对于第 3 题，4 个选项涉及的 4 道题，其中 3 道题答案相同，另外一题答案与众不同，也就是本题要选的答案。
代码语言：javascript复制检查[3, 答案_] := Module[
{相同3题, 选项 = {a -> 3, b -> 6, c -> 2, d -> 4}},
If[已作答[{3, 6, 2, 4}, 答案]
,
相同3题 = 答案[[DeleteCases[{3, 6, 2, 4}, 答案[[3]] /. 选项]]];
(SameQ @@ 相同3题) && (答案[[答案[[3]] /. 选项]] =!= 相同3题[[1]])
,
Indeterminate]
];第 4 题 4 个选项提供了 4 组题号，题目要求我们把唯一一组答案相同的选出来。检查本题时，不但要求选出的一组题答案相同，而且要求另外 3 组题答案不同：
代码语言：javascript复制检查[4, 答案_] := Module[
{选项 = {a -> {1, 5}, b -> {2, 7}, c -> {1, 9}, d -> {6, 10}}},
If[已作答[Append[Flatten@选项[[All, 2]], 4], 答案]
,
Select[选项[[All, 2]], SameQ @@ 答案[[#]] &] === {答案[[4]] /. 选项}
,
Indeterminate]
];第 5 题情况类似，要求有而且只有一题与本题答案相同：
代码语言：javascript复制检查[5, 答案_] := Module[
{选项 = {a -> 8, b -> 4, c -> 9, d -> 7}},
If[已作答[Append[Flatten@选项[[All, 2]], 5], 答案]
,
Select[选项[[All, 2]], 答案[[#]] == 答案[[5]] &] === {答案[[5]] /. 选项}
,
Indeterminate]
];第 6 题亦然，要求有而且只有一组题目与第 8 题答案相同：
代码语言：javascript复制检查[6, 答案_] := Module[
{选项 = {a -> {2, 4}, b -> {1, 6}, c -> {3, 10}, d -> {5, 9}}},
If[已作答[Append[Flatten@选项[[All, 2]], 6], 答案]
,
Select[选项[[All, 2]],
SameQ @@ 答案[[Append[#, 8]]] &] === {答案[[6]] /. 选项}
,
Indeterminate]
];第 7 和 10 题我们用 Tally 函数统计各选项重复出现的次数。检查第 7 题时要注意不允许出现多种选项并列最少的情况。
代码语言：javascript复制检查[7, 答案_] := Module[
{统计},
If[FreeQ[答案, Indeterminate]
,
统计 = SortBy[Tally@答案, Last];
(Length@统计 > 1) && (统计[[1, 2]] != 统计[[2, 2]]) && (答案[[7]] ===
统计[[1, 1]])
,
Indeterminate]
];
检查[10, 答案_] := Module[
{统计},
If[FreeQ[答案, Indeterminate]
,
统计 = SortBy[Tally@答案, Last];
统计[[-1, 2]] -
统计[[1, 2]] === (答案[[10]] /. {a -> 3, b -> 2, c -> 4, d -> 1})
,
Indeterminate]
];第 8 题判断选项是否相邻时，可以先把选项替换成 1、2、3、4，相差 1 即为相邻。
代码语言：javascript复制检查[8, 答案_] := Module[
{temp, 选项替换 = {a -> 1, b -> 2, c -> 3, d -> 4}},
If[已作答[{8, 7, 5, 2, 10, 1}, 答案]
,
Select[{a, b, c, d},
Abs[答案[[# /. {a -> 7, b -> 5, c -> 2, d -> 10}]] - 答案[[1]] /.
选项替换] =!= 1 &] === {答案[[8]]}
,
Indeterminate]
];第 9 题里两个论断的“真假性”相反，我们可以使用 Xor 异或函数：
代码语言：javascript复制检查[9, 答案_] :=
If[已作答[{1, 6, 5, 10, 2, 9}, 答案]
,
(答案[[1]] === 答案[[6]])~
Xor~(答案[[答案[[9]] /. {a -> 6, b -> 10, c -> 2, d -> 9}]] ===
答案[[5]])
,
Indeterminate];下面通过深度优先搜索答案：对每一题分别尝试四选项，如果没有错误就保留当前答案并进一步搜索下题的答案（深度优先）；反之放弃该选项（剪枝）。当所有题目都正确了，就直接将答案抛出。
代码语言：javascript复制搜索[现答案_, _, {}] := Throw[现答案];
搜索[现答案_, {新题号_, 剩余题目___}, 待查题目_] := Module[
{新答案 = 现答案, 结果},
(
新答案[[新题号]] = #;
结果 = 检查[#, 新答案] & /@ 待查题目;
If[FreeQ[结果, False]
,
搜索[新答案, {剩余题目}, Delete[待查题目, Position[结果, True]]]]
) & /@ {a, b, c, d};
];芝麻开门：
代码语言：javascript复制搜索[Table[Indeterminate, {10}], {5, 3, 1, 2, 4, 6, 7, 8, 9, 10},
Range[10]]读者可能注意到我们不是从 1 到 10 搜索顺序，而是首先搜索第 5 题，然后第 3 题。这是因为作者“手工”做过这套题目，第 5 题和第 3 题相对容易入手。对于搜索程序，这个搜索顺序也明显比顺序搜索快：
代码语言：javascript复制AbsoluteTiming@
Catch@搜索[Table[Indeterminate, {10}], #, Range[10]] & /@ {{5, 3, 1,
2, 4, 6, 7, 8, 9, 10}, Range[10]} // Grid搜索终极版
首先定义新的检查函数，方便我们把原有的检查函数屏蔽掉，把第 10 题替换成第 1 题的形式：
代码语言：javascript复制终极检查[10, 答案_] := If[已作答[10, 答案], True, Indeterminate];
终极检查[n_, 答案_] := 检查[n, 答案];如果要替换一系列题目（如 2、3、5），通过程序生成"终极检查"函数：
代码语言：javascript复制Clear[终极检查];
终极检查[n_, 答案_] := 检查[n, 答案];
(终极检查[#, 答案_] := If[已作答[#, 答案], True, Indeterminate]) & /@ {2, 3, 5};接下来改造搜索函数，发现存在 2 个解时才中止搜索，
代码语言：javascript复制部分答案[] :=
终极搜索[Table[Indeterminate, {10}], {5, 3, 1, 2, 4, 6, 7, 8, 9, 10},
Range[10]];
终极搜索[现答案_, _, {}] := {现答案};
终极搜索[现答案_, {新题号_, 剩余题目___}, 待查题目_] := Module[
{新答案 = 现答案, 结果},
Catch[Fold[Function[{答案累计, 尝试选项},
If[Length@答案累计 > 1, Throw[答案累计]];
新答案[[新题号]] = 尝试选项;
结果 = 终极检查[#, 新答案] & /@ 待查题目;
If[FreeQ[结果, False]
,
Join[答案累计,
终极搜索[新答案, {剩余题目}, Delete[待查题目, Position[结果, True]]]]
,
答案累计]
], {}, {a, b, c, d}]]
];现在让我们看看把任意三题变为“易”题之后是否仍只有唯一解：
代码语言：javascript复制答案统计 = ParallelMap[Function[{要修改的题目},
Clear[终极检查];
终极检查[n_, 答案_] := 检查[n, 答案];
(终极检查[#, 答案_] := If[已作答[#, 答案], True, Indeterminate]) & /@
要修改的题目;
{要修改的题目, 部分答案[]}],
Union[Sort /@ Permutations[{2, 3, 4, 5, 6, 7, 8, 9, 10}, {3}]]];
Grid[Select[答案统计, Length@#[[2]] == 1 &], Frame -> All]容易验证把更多题变为“易”题后就不再存在唯一解了，所以我们的终极版如上表所示，一共有 17 种。作者最喜爱的是把第 3、5、10 题替换掉，你呢？
