# Write a number as the product of its two largest divisors

For even n >= 10 && n <= 98 I want to write n as the product of its two largest divisors (excluding n itself, i.e. 1 * 60 == 60 is not permitted).

EDIT (to account for rasher's criticism)

I have tried:

First@Reverse@Take[Transpose[{#, Reverse@#}], Length[#/2]/2] &[
Rest@Most@Divisors@#] & /@ {10, 12, 52, 60, 66, 70, 72, 98}


giving

{{2, 5}, {3, 4}, {4, 13}, {6, 10}, {6, 11}, {7, 10}, {8, 9}, {7, 14}}

but this fails, f.e., on 16, which should give {4, 4}

• Divisors[n] gives them in ascending order to get started... reference.wolfram.com/mathematica/ref/Divisors.html – dr.blochwave Jul 2 '14 at 19:09
• – Artes Jul 2 '14 at 19:10
• The two largest divisors of 60, excluding 60 itself, are, if I'm not mistaken, 30 and 20. But their product is not 60 (or at least I'm pretty sure it's not 60). Do you mean instead the two divisors that straddle the square root? – Daniel Lichtblau Jul 2 '14 at 19:55
• @Daniel - I think my question plus example is clear (except for square numbers - see answer below). If not, please edit it. – eldo Jul 2 '14 at 20:07
• Agree with Daniel - ambiguous question. In addition, this is not a mechanical turk site to produce code by request. What have you tried? Based on your answering of other questions, you're clearly capable of coding... – ciao Jul 2 '14 at 20:23

## 5 Answers

@blochwave's answer slightly modified:

h = Function[{n},
Module[{d = Divisors[n], m},
m = Ceiling[Length[d]/2];
d[[{m, -m}]]],
{Listable}]
h @ Range[10, 98, 2]
(* {{2, 5}, {3, 4}, {2, 7}, {4, 4}, {3, 6}, {4, 5}, {2, 11}, {4, 6},
{2, 13}, {4, 7}, {5, 6}, {4, 8}, {2, 17}, {6, 6}, {2, 19}, {5, 8},
{6, 7}, {4, 11}, {2, 23}, {6, 8}, {5, 10}, {4, 13}, {6, 9}, {7, 8},
{2, 29}, {6, 10}, {2, 31}, {8, 8}, {6, 11}, {4, 17}, {7, 10},
{8, 9}, {2, 37}, {4, 19}, {6, 13}, {8, 10}, {2, 41}, {7, 12},
{2, 43}, {8, 11}, {9, 10}, {4, 23}, {2, 47}, {8, 12}, {7, 14}} *)

• nice alliance of style and speed – eldo Jul 3 '14 at 18:39
• @eldo, thank you!! – kglr Jul 3 '14 at 19:57
• @kguler agree with eldo, dealing with squares and listability in a compact way – ubpdqn Jul 4 '14 at 0:23

Updated answer

Indeed, the method linked to by Artes can be modified (Generating pairs of additive and multiplicative factors for integers)

f1[n_] := Last[{#, n/#} & /@ First@Partition[#, Ceiling[Length[#]/2]] &@ Divisors[n]]


Which also works nicely for squares, such as 36 giving {6,6} which is an improvement over the original answer I gave below.

This method is pretty efficient so long as the list isn't too large - a speed-up can be found in the answer of @rasher.

Original answer

My original idea is based on How do I extract the middle element(s) of a given list?, since the example given in the question is basically asking for the middle pair of divisors. So,

mid[a_List] := a[[# ;; -#]] &@\[LeftCeiling]Length@a/2\[RightCeiling]
mid[Divisors[#]] & /@ {10, 12, 52, 60, 66, 70, 72, 98}


{{2, 5}, {3, 4}, {4, 13}, {6, 10}, {6, 11}, {7, 10}, {8, 9}, {7, 14}}

I've no idea how foolproof this is...

Certainly the point about excluding 1*itself means you'd have to skip the primes, since mid[Divisors[#]] & /@ Range[10, 98] returns things like {1,29} and so on.

EDIT I've now noticed you said "for even n", oops! So it would be Range[10,98,2].

Also, for the square numbers this method returns one number, e.g. for 36 it returns {6} and not {6,6}.

• +1 f1 seems to work for odd, negative, small and large Integers. More than I expected, and I especially like the {6,6} :) – eldo Jul 2 '14 at 19:46

I'll assume the definition of "two largest" is defined by your example results since you don't define this explicitly. This is a bit faster if you're after a large range of results.

f = (ArrayPad[#, -Ceiling[(Length@#)/2 - 1]] /. {x_} :> {x, x}) &@Divisors[#] &

f /@ {10, 12, 16, 52, 60, 66, 70, 72, 98}

{{2, 5}, {3, 4}, {4, 4}, {4, 13}, {6, 10}, {6, 11}, {7, 10}, {8, 9}, {7, 14}}

• A bit faster by a factor of ~2x in fact! – dr.blochwave Jul 2 '14 at 22:22
• @rasher Excellent! Could your solution (like blochwave's) also respect negative integers, so that -1111 -> {11, -101} ? – eldo Jul 2 '14 at 22:28
• @eldo: Sure, do something like f = (ArrayPad[#, -Ceiling[(Length@#)/2 - 1]] /. {x_} :> {x, x }) &@ Divisors[#] {1, Sign[#]} & instead. Note that allowing a non-positive domain makes "largest" even more ambiguous ;-) – ciao Jul 2 '14 at 22:43

I am late to the party here and just for terseness:

f[x_] := {#, x/#} & @@ Nearest[Divisors[x], Sqrt[x]]


So:

f /@ Range[10, 98, 2]


yields:

{{2, 5}, {3, 4}, {2, 7}, {4, 4}, {3, 6}, {4, 5}, {2, 11}, {4, 6}, {2,
13}, {4, 7}, {5, 6}, {4, 8}, {2, 17}, {6, 6}, {2, 19}, {5, 8}, {6,
7}, {4, 11}, {2, 23}, {6, 8}, {5, 10}, {4, 13}, {6, 9}, {7, 8}, {2,
29}, {6, 10}, {2, 31}, {8, 8}, {6, 11}, {4, 17}, {7, 10}, {8,
9}, {2, 37}, {4, 19}, {6, 13}, {8, 10}, {2, 41}, {7, 12}, {2,
43}, {8, 11}, {9, 10}, {4, 23}, {2, 47}, {8, 12}, {7, 14}}

• Matthew, 19,30: "But many who are first will be last, and the last will be first." Pretty & educational piece of code :) – eldo Jul 4 '14 at 1:07
• @eldo thank you...as you know the joy in this site is seeing how many creative ways people have of approaching questions...I learn more from this than plodding in the dark – ubpdqn Jul 4 '14 at 1:16
• and you don't have to buy all these expensive books and can have a couple of drinks instead ... – eldo Jul 4 '14 at 1:21
• my favorite... +1 – kglr Jul 4 '14 at 3:55
f[n_] := Thread[List[Divisors[n], n/Divisors[n]]][[Ceiling[Length@Divisors[n]/2]]]

f[#] & /@ {10, 12, 52, 60, 66, 70, 72, 98}

(*{{2, 5}, {3, 4}, {4, 13}, {6, 10}, {6, 11}, {7, 10}, {8, 9}, {7, 14}}*)