# How to improve this code for solving the “Mr.S and Mr.P” puzzle?

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
f5[x_] := Length@Select[Select[pool, Plus @@ # == x &], f4[#[]*#[]] &] == 1

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

• Have you tested if memoization helps? – Dr. 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 – Dr. belisarius Oct 30 '12 at 14:42
• Oh,I forget it. – chyanog Oct 30 '12 at 14:47
• You could ask MrP or MrS – Rojo Oct 30 '12 at 18:35

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

• Just for the record, I don't understand my solution either. I just memoized the Op's functions, not a hard try – Dr. belisarius Nov 1 '12 at 3:47

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= {0.150003, {{13, 4}}}


Edit

In:=
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= {0.078, {{13, 4}}}


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
f5[x_] := f5[x] = Length@Select[Select[pool, Plus @@ # == x &], f4[#[]*#[]] &] == 1

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

(*
{74.094, {{13, 4}}}
*)

• Thanks.In my PC, it take 43sec. – chyanog Oct 30 '12 at 14:49
• I need a newer machine – Dr. 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
• Mine runs in 0.031. The second time. – Marcks Thomas Oct 30 '12 at 17:09

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, #[]] &], 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, #[]] &], 4], 3]) // Timing


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

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