用 Wolfram 语言解答2018年刑侦科推理题

WolframChina

发布于 2019-03-06 17:30:50

7870

发布于 2019-03-06 17:30:50

文章被收录于专栏：WOLFRAM

本文适合对 Wolfram 语言感兴趣的小读者。2018年初网上出现一套所谓的《2018年刑侦科推理试题》。

搜索答案

让我们用 Wolfram 语言解答这个逻辑谜题。各题的答案用“a、b、c、d”四个小写英文字母（注：大写的“C、D”已经有各自的功能）表示，为了避免四个字母被赋值，先把它们保护起来：

SetAttributes[#, {Protected, ReadProtected}] & /@ {a, b, c, d};

定义一个辅助函数，判断若干题目是否都已作答，参数“答案”是一个列表，包含 10 道题的答案，如果某题未答，则为 Indeterminate，不确定。

已作答[n_Integer, 答案_] := 答案[[n]] =!= Indeterminate;
已作答[l_List, 答案_] := FreeQ[答案[[l]], Indeterminate];

然后定义判断函数，用来检查答案是否符合题干要求：如果符合，检查函数的结果为 True；如果不符合，结果为 False；如果有的题目还未作答导致无法判断对错，则结果为 Indeterminate。对于第 1 题，只要作答了，答案就是正确的；如果未作答，则结果为 Indeterminate。

检查[1, 答案_] := If[已作答[1, 答案], True, Indeterminate];

检查第 2 题时，要求第 5 题也必须作答，如果有一题未答，则结果为 Indeterminate。

检查[2, 答案_] := 
  If[已作答[{2, 5}, 答案], 
   答案[[5]] === (答案[[2]] /. {a -> c, b -> d, c -> a, d -> b}), 
   Indeterminate];

对于第 3 题，4 个选项涉及的 4 道题，其中 3 道题答案相同，另外一题答案与众不同，也就是本题要选的答案。

检查[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 组题答案不同：

检查[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 题情况类似，要求有而且只有一题与本题答案相同：

检查[5, 答案_] := Module[
   {选项 = {a -> 8, b -> 4, c -> 9, d -> 7}},
   If[已作答[Append[Flatten@选项[[All, 2]], 5], 答案]
    ,
    Select[选项[[All, 2]], 答案[[#]] == 答案[[5]] &] === {答案[[5]] /. 选项}
    ,
    Indeterminate]
   ];

第 6 题亦然，要求有而且只有一组题目与第 8 题答案相同：

检查[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 题时要注意不允许出现多种选项并列最少的情况。

检查[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 即为相邻。

检查[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 异或函数：

检查[9, 答案_] :=
  If[已作答[{1, 6, 5, 10, 2, 9}, 答案]
   ,
   (答案[[1]] === 答案[[6]])~
    Xor~(答案[[答案[[9]] /. {a -> 6, b -> 10, c -> 2, d -> 9}]] === 
      答案[[5]])
   ,
   Indeterminate];

下面通过深度优先搜索答案：对每一题分别尝试四选项，如果没有错误就保留当前答案并进一步搜索下题的答案（深度优先）；反之放弃该选项（剪枝）。当所有题目都正确了，就直接将答案抛出。

搜索[现答案_, _, {}] := Throw[现答案];
搜索[现答案_, {新题号_, 剩余题目___}, 待查题目_] := Module[
   {新答案 = 现答案, 结果},
   (
       新答案[[新题号]] = #;
       结果 = 检查[#, 新答案] & /@ 待查题目;
       If[FreeQ[结果, False]
        ,
        搜索[新答案, {剩余题目}, Delete[待查题目, Position[结果, True]]]]
       ) & /@ {a, b, c, d};
   ];

芝麻开门：

搜索[Table[Indeterminate, {10}], {5, 3, 1, 2, 4, 6, 7, 8, 9, 10}, 
 Range[10]]

读者可能注意到我们不是从 1 到 10 搜索顺序，而是首先搜索第 5 题，然后第 3 题。这是因为作者“手工”做过这套题目，第 5 题和第 3 题相对容易入手。对于搜索程序，这个搜索顺序也明显比顺序搜索快：

AbsoluteTiming@
    Catch@搜索[Table[Indeterminate, {10}], #, Range[10]] & /@ {{5, 3, 1,
     2, 4, 6, 7, 8, 9, 10}, Range[10]} // Grid

搜索终极版

首先定义新的检查函数，方便我们把原有的检查函数屏蔽掉，把第 10 题替换成第 1 题的形式：

终极检查[10, 答案_] := If[已作答[10, 答案], True, Indeterminate];
终极检查[n_, 答案_] := 检查[n, 答案];

如果要替换一系列题目（如 2、3、5），通过程序生成"终极检查"函数：

Clear[终极检查];
终极检查[n_, 答案_] := 检查[n, 答案];
(终极检查[#, 答案_] := If[已作答[#, 答案], True, Indeterminate]) & /@ {2, 3, 5};

接下来改造搜索函数，发现存在 2 个解时才中止搜索，

部分答案[] := 
  终极搜索[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}]]
   ];

现在让我们看看把任意三题变为“易”题之后是否仍只有唯一解：

答案统计 = 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 题替换掉，你呢？