Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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
share|improve this question
    
Have you tested if memoization helps? –  belisarius Oct 30 '12 at 14:37
    
yep it's faster with memoization, but I don't know how much because your code takes too long in my machine –  belisarius Oct 30 '12 at 14:42
    
Oh,I forget it. –  chyaong Oct 30 '12 at 14:47
    
You could ask MrP or MrS –  Rojo Oct 30 '12 at 18:35
add comment

5 Answers

up vote 12 down vote accepted

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}}}

share|improve this answer
1  
Just for the record, I don't understand my solution either. I just memoized the Op's functions, not a hard try –  belisarius Nov 1 '12 at 3:47
add comment

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}}}
*)
share|improve this answer
    
Thanks.In my PC, it take 43sec. –  chyaong Oct 30 '12 at 14:49
    
I need a newer machine –  belisarius Oct 30 '12 at 14:51
    
Clearly, you do: {17.2204, {{13, 4}}} :) –  rm -rf Oct 30 '12 at 15:17
    
In my Pc, {57.437, {{13, 4}}} –  minthao_2011 Oct 30 '12 at 15:40
2  
Mine runs in 0.031. The second time. –  Marcks Thomas Oct 30 '12 at 17:09
show 5 more comments

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}}}
share|improve this answer
add comment

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}}}

share|improve this answer
    
I had copy in paste errors from my notebook which I have corrected now. –  ubpdqn Nov 12 '12 at 8:26
add comment
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.

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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