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

本文适合对 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 题替换掉,你呢?

原文发布于微信公众号 - WOLFRAM(WolframChina)

原文发表时间:2019-01-25

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

扫码关注云+社区

领取腾讯云代金券