阮一峰之前有篇文章《Prolog 语言入门教程》，介绍说Prolog（全称Programming in Logic）是一种专门解决逻辑问题的语言。
其实解决逻辑推理问题也不用特意去学一门新语言，去自己工具箱里找个趁手的兵器也行。
本文采用Mathematica解题，可与上文对照阅读，文末还求解了一道更复杂的题目。
话说有了计算机以后，干啥都喜欢简单粗暴的，纯推理是越来越懒了。

1.找朋友

 1
 2
 3
 4
 5
 6
 7
 8
 9
10

(*给定4对（单向）朋友*)
friends = {{"john", "julia"}, {"john", "jack"}, {"julia", "sam"}, {"julia", "molly"}};
allpeople = DeleteDuplicates@Flatten@friends;
(*查询a、b是否是朋友*)
FriendQ[a_, b_] := MemberQ[friends, {a, b}];
FriendQ["john", "sam"]
False
(*查询john有多少个朋友*)
Select[allpeople, FriendQ["john", #] &]
{"julia", "jack"}

列出所有的朋友关系？friends列表本身就是了。

2.地图着色问题

用红、绿、蓝给分成A、B、C、D、E五块的地图上色，要求相邻区域不能使用同一种颜色。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10

colors = {"red", "green", "blue"};
colorOK[{a_, b_, c_, d_, e_}] := And[a != b, a != c, a != d, a != e, b != c, c != d, d != e];
sol = Select[Tuples[colors, 5], colorOK];
StringPadLeft /@ sol // TableForm
  red   green    blue   green    blue
  red    blue   green    blue   green
green     red    blue     red    blue
green    blue     red    blue     red
 blue     red   green     red   green
 blue   green     red   green     red

3.谁是凶手

Boddy 先生死于谋杀，现有六个嫌疑犯，每个人在不同的房间，每间房间各有一件可能的凶器，但不知道嫌疑犯、房间、凶器的对应关系。请根据下面的条件和线索，找出谁是凶手。已知条件：

  • 六个嫌疑犯是三男（George、John、Robert）三女（Barbara、Christine、Yolanda）。
  • 六个嫌疑犯分别待在六个房间：浴室（Bathroom）、饭厅（Dining Room）、厨房（Kitchen）、起居室（Living Room）、 储藏室（Pantry）、书房（Study）。
  • 每间房间都有一件可疑的物品，可以当作凶器：包（Bag）、火枪（Firearm）、煤气（Gas）、刀（Knife）、毒药（Poison）、绳索（Rope）。
  • 线索一：厨房里面是一个男人，那里的凶器不是绳索、刀子、包和火枪。
  • 线索二：Barbara 和 Yolanda 在浴室和书房。
  • 线索三：带包的那个人不是 Barbara 和 George，也不在浴室和饭厅。
  • 线索四：书房里面是一个带绳子的女人。
  • 线索五：起居室里面那件凶器，与 John 或 George 在一起。
  • 线索六：刀子不在饭厅。
  • 线索七：书房和食品储藏室里面的凶器，没跟 Yolanda 在一起。
  • 线索八：George 所在的那间屋子有火枪。
  • 线索九：Boddy 先生死在食品储藏室里，那里的凶器是煤气。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

props = {"bathroom", "dining", "kitchen", "livingroom", "pantry", "study", "bag", "firearm", "gas", "knife", "poison", "rope"};
men = {"george", "john", "robert"};
women = {"barbara", "christine", "yolanda"};
people = Flatten@{men, women};
allcases = Flatten /@ Permutations[Permutations[people], {2}];
murderQ[case_] := Module[{p},
  p = AssociationThread[props, case];
    And @@ {MemberQ[men, p["kitchen"]], !MemberQ[{p["knife"], p["bag"], p["firearm"], p["rope"]}, p["kitchen"]], 
      Sort@{p["bathroom"], p["study"]} == {"barbara", "yolanda"}, 
        !MemberQ[{"barbara", "george", p["bathroom"], p["dining"]}, p["bag"]], 
        And[p["study"] == p["rope"], MemberQ[women, p["study"]]], 
        MemberQ[{"george", "john"}, p["livingroom"]], 
        p["knife"] != p["dining"], 
        And[p["study"] != "yolanda", p["pantry"] != "yolanda"], 
        p["firearm"] == "george", 
        p["pantry"] == p["gas"]}
      ];
      sol = First@Select[allcases, murderQ];
  StringRiffle[ Transpose@{StringPadLeft@props, StringPadRight@sol}, "\n", "->"]
  bathroom->yolanda  
    dining->george   
   kitchen->robert   
livingroom->john     
    pantry->christine
     study->barbara  
       bag->john     
   firearm->george   
       gas->christine
     knife->yolanda  
    poison->robert   
      rope->barbara

4.关联题目

网传的2018年刑侦科推理试题，实为2014年杭州学军中学推理社的招新考题。

题号 题目 选项A 选项B 选项C 选项D
1 这道题的答案是 A B C D
2 第5题的答案是 C D A B
3 以下选项中哪一题的答案与其他三项不同 3 6 2 4
4 以下选项中哪两题的答案相同 1、5 2、7 1、9 6、10
5 以下选项中哪一题的答案与本题相同 8 4 9 7
6 以下选项中哪两题的答案与第8题相同 2、4 1、6 3、10 5、9
7 在此十道题中，被选中次数最少的选项字母为 C B A D
8 以下选项中哪一题的答案与第1题的答案在字母中不相邻 7 5 2 10
9 已知"第1题与第6题的答案相同"与"第X题与第5题的答案相同"的真假性相反，那么X为 6 10 2 9
10 在此10道题中，ABCD四个字母出现次数最多与最少者的差为 3 2 4 1 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19

Clear@checkQ; checkQ[c_] := Module[{t, t3, t4, t6},
  t = Count[c, #] & /@ Range@4;
  Ans[i_] := c[[i]]; (*题目i的答案*)
  OfAns[l_, i_] := l[[c[[i]]]];  (*题目i的答案内容*)
  AnsOfAns[l_, i_] := c[[l[[c[[i]]]]]];   (*题目i的答案内容对应的题目的答案*)
  And @@ {Ans[5] == OfAns[{3, 4, 1, 2}, 2],
    t3 = SortBy[Tally[c[[{3, 6, 2, 4}]]], Last]; t3[[1, 2]] == 1 && t3[[2, 2]] == 3 && t3[[1, 1]] == AnsOfAns[{3, 6, 2, 4}, 3],
    t4 = AnsOfAns[{{1, 5}, {2, 7}, {1, 9}, {6, 10}}, 4]; t4[[1]] == t4[[2]],
    Ans[5] == AnsOfAns[{8, 4, 9, 7}, 5],
    t6 = AnsOfAns[{{2, 4}, {1, 6}, {3, 10}, {5, 9}}, 6]; t6[[1]] == t6[[2]] == Ans[8],
    OfAns[{3, 2, 1, 4}, 7] == First@Ordering[t, 1],
    Abs[AnsOfAns[{7, 5, 2, 10}, 8] - Ans[1]] != 1,
    (Ans[1] == Ans[6]) != (Ans[5] == AnsOfAns[{6, 10, 2, 9}, 9]),
    Max@t - Min@t == OfAns[{3, 2, 4, 1}, 10]
    }
  ];
sol = Select[Tuples[{1, 2, 3, 4}, {10}], checkQ];
StringJoin@Characters["ABCD"][[#]] & /@ sol
{"BCACACDABA"}  (*唯一解*)