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
$\endgroup$
4
  • $\begingroup$ Have you tested if memoization helps? $\endgroup$ 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$ 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

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

$\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$ 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}}}
$\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}}}
*)
$\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$ 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$ Oct 30, 2012 at 15:40
  • 2
    $\begingroup$ Mine runs in 0.031. The second time. $\endgroup$ 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}}}

$\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.

$\endgroup$

Your Answer

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

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