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

5 Answers 5

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

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

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

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

This site is currently not accepting new answers.

Not the answer you're looking for? Browse other questions tagged .