## Mr P and Mr S

Mathematica Stackexchange is an excellent resource. I have been learning a lot looking at the questions and answers. I have also learned how swiftly poor questions are filtered out: having sadly earned a NARQ (not a real question) assessment while trying to understand “self-triggering” in dynamic vaisualization. My question was poor, non-specific and motivates me to look further.

One of the questions brings up the following puzzle:

**We pick two numbers a and b, such that a≥b and both numbers are within the range (2,99). We give Mr.P the product ab 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’t know either.
Mr.P: Now I know the numbers
Mr.S: Now I know them too
Can we find the numbers a and b?
**

This is an interesting puzzle and reminiscent of another puzzle:

**Two mathematicians are sitting for lunch.
Mr. A: how old are your three sons?
Mr. B: the product of their ages is 36 and the sum of their ages is the same as the number of windows in that building over there.
Mr. A looked perplexed.
Mr. B: the eldest has red hair**

This last problem can be solved relatively quickly by noting that there is only one case where the sum of three factors of 36 is not unique: 13 =2+2+9=1+6+6. Allowing for semantic arguments about one twin always being older than another, the answer is: 2,2,9.

The Mr P and Mr S puzzle has a unique solution but has more cases to examine (though these can be reduced with thought: see here for solution).

Here is my commented attempt:

(* 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}} *)

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]

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