14
$\begingroup$

Mr.S and Mr. P puzzle — "Formalization of two Puzzles Involving Knowledge", McCarthy, John (1987)

We pick two numbers $a$ and $b$, such that $a\geq b$ and both numbers are within the range $(2,99)$. We give Mr.P the product $a b$ and give Mr.S the sum $a+b$. Then following dialog takes place:

Mr.P: I don't know the numbers
Mr.S: I knew you didn't know. I don'tknow either.
Mr.P: Now I know the numbers
Mr.S: Now I know them too

Can we find the numbers $a$ and $b$?

I tried to do this, but it is very slow. I am sure there must be a simpler way.

Clear[pool, f1, f2, f3];
pool = Join @@ Table[{i, j}, {i, 2, 99}, {j, 2, i}];

f1[x_] := Length@Select[pool, Times @@ # == x &] != 1
f2[x_] := Length@Select[pool, Plus @@ # == x &] != 1
f3[x_] := And @@ (f1 /@ (Times @@@ Select[pool, Plus @@ # == x &]))
f4[x_] := Length@Select[Select[pool, Times @@ # == x &], f3[#[[1]] + #[[2]]] &] == 1
f5[x_] := Length@Select[Select[pool, Plus @@ # == x &], f4[#[[1]]*#[[2]]] &] == 1

Select[pool, 
  f1[#[[1]]*#[[2]]] && f2[#[[1]] + #[[2]]] && f3[#[[1]] + #[[2]]] && 
    f4[#[[1]]*#[[2]]] && f5[#[[1]] + #[[2]]] &] // Timing
Improve this question
$\endgroup$
4
  • $\begingroup$ Have you tested if memoization helps? $\endgroup$
    – Dr. belisarius
    Oct 30, 2012 at 14:37
  • $\begingroup$ yep it's faster with memoization, but I don't know how much because your code takes too long in my machine $\endgroup$
    – Dr. belisarius
    Oct 30, 2012 at 14:42
  • $\begingroup$ Oh,I forget it. $\endgroup$
    – chyanog
    Oct 30, 2012 at 14:47
  • $\begingroup$ You could ask MrP or MrS $\endgroup$
    – Rojo
    Oct 30, 2012 at 18:35

5 Answers 5

Reset to default
13
$\begingroup$

I tried to understand the other two solutions, but honestly, I couldn't. So I tried to write a version that is easier to understand.

EDIT: I've refactored the code a little, primarily pulling out the "knowledge operators" personKnowsSolution and personKnowsProperty. I'm not really following McCarthy's axiomatization of knowledge, this is just my ad-hoc way of expressing "knowledge" in Mathematica.

Clear[personKnowsSolution, personKnowsProperty, mrP, mrS]
personKnowsSolution[informationFilter_, possibilities_] := 
 Join @@ Select[GatherBy[possibilities, informationFilter], Length[#] == 1 &]
personKnowsProperty[informationFilter_, possibilities_, property_] := 
 Select[possibilities, property[informationFilter[#]] &]
mrP[{a_, b_}] := a*b
mrS[{a_, b_}] := a + b
(
  allPossibilities = Join @@ Table[{i, j}, {i, 2, 99}, {j, 2, i}];

  (* Mr. P doesn't know the solution *)
  mrPWouldKnowSolution = personKnowsSolution[mrP, allPossibilities];
  mrPDoesntKnowSolution = Complement[allPossibilities, mrPWouldKnowSolution];

  (* Mr. S doesn't know the solution *) 
  mrSWouldKnowSolution = personKnowsSolution[mrS, allPossibilities];
  mrSDoesntKnowSolution = Complement[allPossibilities, mrSWouldKnowSolution];

  (* Mr. S knows Mr. P doesn't know the solution *)
  sumsWhereMrPWouldKnowTheSolution = Union[mrS /@ mrPWouldKnowSolution];
  mrSKnowsMrPDoesntKnow = 
   personKnowsProperty[mrS, mrSDoesntKnowSolution, 
    Not[MemberQ[sumsWhereMrPWouldKnowTheSolution, #]] &];

  (* Given that, Mr. P knows the solution *)
  mrPKnowsTheSolution = personKnowsSolution[mrP, mrSKnowsMrPDoesntKnow];

  (* Given that, Mr. S knows the solution *)
  mrSKnowsTheSolution = personKnowsSolution[mrS, mrPKnowsTheSolution]
) // Timing

Output: {0.063, {{13, 4}}}

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Just for the record, I don't understand my solution either. I just memoized the Op's functions, not a hard try $\endgroup$
    – Dr. belisarius
    Nov 1, 2012 at 3:47
9
$\begingroup$

A much faster approach is to precompute:

pool = Join @@ Table[{i, j}, {i, 2, 99}, {j, 2, i}];
Block[{products = Times @@@ pool, sums = Total[pool, {2}], bys, byp, 
   f1, f2, f3, f4},
  bys = GatherBy[Transpose[{sums, products}], First];
  byp = GatherBy[Transpose[{products, sums}], First];
  Set[f1[#1], Unequal[#2, 1]] & @@@ Tally[products];
  Set[f2[#1], Unequal[#2, 1]] & @@@ Tally[sums];
  Set[f3[#1], #2] & @@@ 
   Map[{Part[#, 1, 1], 
      Fold[And[#1, f1[#2]] &, True, Part[#, All, 2]]} &, bys];
  Set[f4[#1], #2] & @@@ 
   Map[{Part[#, 1, 1], Count[Map[f3, Part[#, All, 2]], True] == 1} &, 
    byp];
  Set[f5[#1], #2] & @@@ 
   Map[{Part[#, 1, 1], Count[Map[f4, Part[#, All, 2]], True] == 1} &, 
    bys];
  Extract[pool, 
   Position[
    Transpose[{sums, products}], {su_, pr_} /; 
     f1[pr] && f2[su] && f3[su] && f4[pr] && f5[su]]]
  ] // AbsoluteTiming

With the timing:

Out[70]= {0.150003, {{13, 4}}}

Edit
Improving on the readability:

In[178]:= 
Block[{products, sums, pool, bys, byp, f1, f2, f3, f4, f5, sp},
  pool = Flatten[Table[{i, j}, {i, 2, 99}, {j, 2, i}], 1];
  sp = Transpose[{sums = Plus @@@ pool, products = Times @@@ pool}];
  bys = {Part[#, 1, 1], Part[#, All, 2]} & /@ GatherBy[sp, First];
  byp = {Part[#, 1, 2], Part[#, All, 1]} & /@ GatherBy[sp, Last];
  SetAttributes[{f1, f2, f3, f4, f5}, Listable];
  Scan[(f1[First[#]] = (Last[#] > 1)) &, Tally[products]];
  Scan[(f2[First[#]] = (Last[#] > 1)) &, Tally[sums]];
  Scan[(f3[First[#]] = Apply[And, f1[Last[#]]]) &, bys];
  Scan[(f4[First[#]] = Total[Boole[f3[Last[#]]]] == 1) &, byp];
  Scan[(f5[First[#]] = Total[Boole[f4[Last[#]]]] == 1) &, bys];
  Extract[pool, 
   Position[
    sp, {su_, pr_} /; 
     f5[su] && f4[pr] && f3[su] && f2[su] && f1[pr]]]] // Timing

Out[178]= {0.078, {{13, 4}}}
Improve this answer
$\endgroup$
5
$\begingroup$

I didn't follow your logic, but a simple memoization trick makes it faster

Clear[pool, f1, f2, f3];
pool = Join @@ Table[{i, j}, {i, 2, 99}, {j, 2, i}];

f1[x_] := f1[x] = Length@Select[pool, Times @@ # == x &] != 1
f2[x_] := f2[x] = Length@Select[pool, Plus @@ # == x &] != 1
f3[x_] := f3[x] = And @@ (f1 /@ (Times @@@ Select[pool, Plus @@ # == x &]))
f4[x_] := f4[x] = Length@Select[Select[pool, Times @@ # == x &], f3[#[[1]] + #[[2]]] &] == 1
f5[x_] := f5[x] = Length@Select[Select[pool, Plus @@ # == x &], f4[#[[1]]*#[[2]]] &] == 1

Select[pool, 
  f1[#[[1]]*#[[2]]] && f2[#[[1]] + #[[2]]] && f3[#[[1]] + #[[2]]] && 
  f4[#[[1]]*#[[2]]] && f5[#[[1]] + #[[2]]] &] // Timing

(*
  {74.094, {{13, 4}}}
*)
Improve this answer
$\endgroup$
10
  • $\begingroup$ Thanks.In my PC, it take 43sec. $\endgroup$
    – chyanog
    Oct 30, 2012 at 14:49
  • $\begingroup$ I need a newer machine $\endgroup$
    – Dr. belisarius
    Oct 30, 2012 at 14:51
  • $\begingroup$ Clearly, you do: {17.2204, {{13, 4}}} :) $\endgroup$
    – rm -rf ♦
    Oct 30, 2012 at 15:17
  • $\begingroup$ In my Pc, {57.437, {{13, 4}}} $\endgroup$
    – minthao_2011
    Oct 30, 2012 at 15:40
  • 2
    $\begingroup$ Mine runs in 0.031. The second time. $\endgroup$
    – Marcks Thomas
    Oct 30, 2012 at 17:09
3
$\begingroup$

This is just based on the answer by @nikie above. It is my first answer...a leap. The commented code: 

(* table of possible pairs and their sum and product *)    
all=Join @@ Table[{i, j, i + j, i j}, {i, 2, 99}, {j, 2, i}];
            (* function to select unique products/sums *)
s[u_, j_] := Join @@ Select[GatherBy[u, #[[j]] &], Length[#] == 1 &];
(* Possibilities Mr. P would not know *)
pu=Complement[all, s[all, 4]]; 
(* Possibilities Mr. S would not know *)
su=Complement[all, s[all, 3]]; 
(* Possibilities Mr. P and Mr S. would not know *)
ju=Intersection[pu,su];
(* Sums without unique entries *)
com = Complement[all[[All, 3]], s[all, 4][[All, 3]]];
(* Mr P knows: selects from subset of intersection. Mr S. knows: selects from this *) 
(* i.e. nested selection *)
s[s[Select[ju, MemberQ[com, #[[3]]] &], 4], 3]
(* yields {{13, 4, 17, 52}} *)

The uncommented code:

 (all = Join @@ Table[{i, j, i + j, i j}, {i, 2, 99}, {j, 2, i}];
  s[u_, j_] := Join @@ Select[GatherBy[u, #[[j]] &], Length[#] == 1 &];
  pu = Complement[all, s[all, 4]];
  su = Complement[all, s[all, 3]];
  ju = Intersection[su, pu];
  com = Complement[all[[All, 3]], s[all, 4][[All, 3]]];
  s[s[Select[ju, MemberQ[com, #[[3]]] &], 4], 3]) // Timing

The timing: {0.125, {{13, 4, 17, 52}}}

Improve this answer
$\endgroup$
1
  • $\begingroup$ I had copy in paste errors from my notebook which I have corrected now. $\endgroup$
    – ubpdqn
    Nov 12, 2012 at 8:26
1
$\begingroup$ 
pools = Join @@ Table[{i, j}, {i, 2, 99}, {j, 2, i}];
mul[{x_, y_}] := x*y
sums = Dispatch@Thread[Tr /@ #[[All, 1]] -> #] &@GatherBy[pools, Tr@# &];
prods = Dispatch@Thread[mul /@ #[[All, 1]] -> #] &@GatherBy[pools, mul];

pDontKnow[p_] := pDontKnow[p] = Length[p /. prods] != 1
sDontKnow[s_] := sDontKnow[s] = Length[s /. sums] != 1
sKnowPdontKnow[s_] := sKnowPdontKnow[s] = And @@ (pDontKnow /@ mul /@ (s /. sums))
pNowKnow[p_] := pNowKnow[p] = Length@Select[p /. prods, sKnowPdontKnow[Tr@#] &] == 1
sKnowPnowKnow[s_] := sKnowPnowKnow[s] = Length@Select[s /. sums, pNowKnow[mul@#] &] == 1

Select[pools, 
  pDontKnow[mul@#] && sDontKnow[Tr@#] && sKnowPdontKnow[Tr@#] && 
    pNowKnow[mul@#] && sKnowPnowKnow[Tr@#] &] // Timing
Clear["`*"]
(*{0.046, {{13, 4}}}*)

I rewrite it use Transformation Rules, like dictionary in Python.

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.