8
$\begingroup$

I was hoping to find an elegant solution to this riddle, using only a line or two of Mathematica:

Santa Claus was telling one of his elves: "If I multiply the age of three of my reindeer, I get 2450. If I add them up, I get the height of the Christmas tree in front of our house. Can you tell me how old the reindeer are?” After the elf went outside and measured the height of the Christmas tree, he came back and complained: “I’m sorry, but I don’t know the solution”. Santa Claus replies: “Oh, I’m sorry, I forgot to tell you that the oldest Reindeer is still younger than me.”

The question is: “How old is Santa Claus?”

My solution involved finding the following steps:

  1. Find unordered factorizations of 2450 using code from Mma Journal, returning a list of lists of factorizations (these do not include 1 as a factor)
  2. Keep only factorizations of 3 or fewer terms, and padding the shorter ones with 1's if necessary, e.g. 2450 = 2450*1*1 = 490*5*1 = 25*14*7 ...
  3. Testing for duplicates within the sum of these triples, using GatherBy code I found locally (because the elf would only be confused if two triples added to the same thing)
  4. Take the first duplicate triple, which has the smallest max age of the three reindeer, because our factorizations came out arranged in increasing order of the first factor which is also the largest of each triple
  5. Print out the triple along with Santa's age (oldest reindeer + 1, which I believe to be the only appropriate interpretation of the question)

My code below has the virtues of being inelegant, longer than it probably needs to be, and hard to understand. Can anyone improve on it in one or more of these categories?

UnorderedFactorizations[m_, 1] = {{}};
UnorderedFactorizations[1, n_] = {{}};
UnorderedFactorizations[m_, n_ /; PrimeQ[n]] := If[m < n, {}, {{n}}]
UnorderedFactorizations[m_, n_] := Flatten[Function[d, 
  Prepend[#, d] & /@ UnorderedFactorizations[d, n/d]] /@ 
  Rest[Select[Divisors[n], # <= m &]], 1]
UnorderedFactorizations[n_] := UnorderedFactorizations[n, n]
Function[la, StringForm[
    "Santa's reindeer are ages ``, ``, and ``, and he himself is age \
    ``.", la[[1]], la[[2]], la[[3]], la[[1]] + 1]]@ 
  Part[#, Flatten[
    Select[GatherBy[Range@Length[#], Function[n, #[[n, 1]]]], 
      Function[l, Length[l] >= 2]]][[1]], 2] & @ 
  (Function[
        triples, {Total[triples], triples}] /@ 
     Function[f, PadRight[f, 3, 1]] /@ 
       Select[UnorderedFactorizations[2450], 
         Function[l, Length[l] <= 3]])

Out[6] = Santa's reindeer are ages 49, 10, and 5, and he himself is age 50.

EDIT: Some more explanation. There are many combinations of 3 factors that produce 2450, but only two of them have the same sum, namely 64: (49, 10, 5) and (50, 7, 7). The elf requires additional information, namely the fact that the oldest reindeer is younger than Santa. In other words, the oldest one is 49 and Santa must be 50. I hard-coded the 1-increment to the reindeer's age, which is perhaps not very general but I also think it is correct based on a strict reading of the riddle. For example, if the second triple were (51, X, Y), then Santa's age wouldn't be uniquely determined. So even without seeing the triples, we know that one must be (R1, R2, R3) and the other (R1+1, R4, R5).

Improve this question
$\endgroup$
  • 1
    $\begingroup$ Reduce[x1 x2 x3 == 2450 && 30 > x1 >= x2 >= x3 > 0, {x1, x2, x3}, Integers] (caribou lifespan is approx. 20 years in captivity so we require age less than 30, if we assume that the units are years). This gives a single result of ages 7, 14, and 25, which makes the tree have a height of 46 and Santa is older than 25. $\endgroup$ – Oleksandr R. Dec 12 '14 at 3:04
  • $\begingroup$ @OleksandrR. I don't want to spoil the fun, but Santa's reindeers are certainly older than 7. I'm still thinking we miss something of this riddle because should the solution not be unique? $\endgroup$ – halirutan♦ Dec 12 '14 at 3:12
  • $\begingroup$ Are reindeers spherical? $\endgroup$ – Dr. belisarius Dec 12 '14 at 3:14
  • $\begingroup$ The solution is indeed unique and uses all the information of the riddle and nothing more. Unfortunately @OleksandrR.'s answer relies on an additional assumption. I added some additional detail above to explain it more. $\endgroup$ – Apo Dec 12 '14 at 3:40
5
$\begingroup$

Edit:

Since now even I have understood the reasoning of the elf requiring more information because after measuring the tree the solution is not unique, I can give a full implementation too.

When n is the magical number 2450, then we can create all possibilities with

Union[Sort /@ Select[Tuples[Divisors[n], {3}], Times @@ # === n &]]

Now, what's left is group these possibilities by their sum, because with this we find the two possibilities that fall together. After we have this, we only need to select the one that has the smaller largest age in it. I'm using the newly introduced operator form for Select and MaximalBy which should make it easy to read:

n = 2450;
MinimalBy[Last]@
SelectFirst[Length[#] > 1 &]@
  GatherBy[Union[Sort/@Select[Tuples[Divisors[n],{3}],Times@@#===n&]],Plus@@#&]
(* {{5, 10, 49}} *)

To show the output we could use the version 10 function StringTemplate.

StringTemplate["Dasher is `1`, Dancer is `2`, Prancer is `3`, 
 the christmastree has a height of <*Plus[##]*> "] @@ First[%]

"Dasher is 5, Dancer is 10, Prancer is 49, the christmastree has a height of 64 "

Improve this answer
$\endgroup$
  • $\begingroup$ This is really impressive, but it missed the factorization 50*7*7, which also adds to a height of 64. In my solution, I found 20 combos, and yours 16. The others are (50, 7, 7), (35, 35, 2), (98, 5, 5), (2450, 1, 1). It will take me a while to understand your solution, but it seems to be missing triples with repeated factors. $\endgroup$ – Apo Dec 12 '14 at 3:54
  • $\begingroup$ @Apo I saw this some minutes ago. I'll edit my code. $\endgroup$ – halirutan♦ Dec 12 '14 at 3:55
  • $\begingroup$ Very cool. Would you mind re-posting your first answer as well? I was just starting to step through it to try to understand. (For those just joining us, @halirutan had another answer using an entirely different method, but it seemed to miss a few factors due to a Union. There is a lot to learn from that answer as well.) $\endgroup$ – Apo Dec 12 '14 at 4:06
  • $\begingroup$ Just realized that we can access the earlier solution by clicking on "edited X mins ago" under your answer. $\endgroup$ – Apo Dec 12 '14 at 4:14
  • $\begingroup$ @Apo Correct. With this you can watch the full history. $\endgroup$ – halirutan♦ Dec 12 '14 at 4:23
3
$\begingroup$

Perhaps shorter:

<< Combinatorica`
factors = Join @@ ConstantArray @@@ FactorInteger@2450;
toWork = {#, Tr@#} & /@ (Sort /@ Apply[Times, KSetPartitions[factors, 3], {2}] // Union)
Sort[First[Transpose @@ Select[GatherBy[toWork, Last], Length@# == 2 &]], Max] // First

(* {5, 10, 49} *)
Improve this answer
$\endgroup$
  • $\begingroup$ KSetPartitions is great! This solution gives the right answer for this particular case, but in general it doesn't include factorizations with 1, e.g. (1, 2, 1225). This is almost fixed just by factors = Join @@ ConstantArray @@@ FactorInteger@2450//Prepend[1] except it still misses the special case of (1, 1, 2450). Any ideas how to handle that without a kludge (adding that case explicitly)? $\endgroup$ – Apo Dec 12 '14 at 17:20
  • $\begingroup$ @Apo toWork = {#, Tr@#} & /@ Union[Sort /@ (PadRight[#, 3, 1] & /@ Apply[Times, Select[SetPartitions[factors], Length@# <= 3 &], {2}])] $\endgroup$ – Dr. belisarius Dec 12 '14 at 17:33
3
$\begingroup$

Short, but barely shorter than halirutan's. And much uglier. And it assumes that Santa is less than 100 years old. But I'm posting it anyway:

n = 2450;
Cases[IntegerPartitions[#,{3},Divisors@n]~Cases~
{x__/;1x==n}&/@Range@100,x:{_,__}:>x~MinimalBy~Max->Max@x]
Improve this answer
$\endgroup$
  • $\begingroup$ Here's an interpretation of @Simon Woods solution. The inner Cases yields all the triples formed by divisors of n, that add up to a number between 1 and 100, and that multiply to yield n. The outer Cases picks from those eligible triples the ones where more than one add up to the same number (thus confusing the elf), and returns the smaller of these (the reindeer ages) as well as the maximum of that set (Santa's age). An interesting approach, but I don't understand 1x==n which seems like it should be the same as x==n but clearly is not. What's the trick here? $\endgroup$ – Apo Dec 16 '14 at 5:17
  • $\begingroup$ Also it's possible to avoid the assumption Santa is less than 100, for example by using Range[n+2], because no triple can add up to more than (n, 1, 1). This is computationally a bit wasteful but safely avoids assumptions. $\endgroup$ – Apo Dec 16 '14 at 5:21
  • $\begingroup$ @Apo, x matches a Sequence in that pattern, so Times[1, x] splices the sequence into Times, ie it gives the product of the elements in x. It's a nice trick when you're playing golf but probably best avoided in code that you might want to read again one day... $\endgroup$ – Simon Woods Dec 17 '14 at 19:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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