# Generating pairs of additive and multiplicative factors for integers

Given an integer $n$, I want to get two lists:

a) the set of pairs of the divsors $a,b$ into exactly two factors $n=a\cdot b$,

b) the set of pairs $a,b$ of two summands $n=a+b$.

The code I came up with works, but I'd like to know if there is a more efficient/elegant or even build in alternative:

  Function[ int, {#,int/#}& /@ Divisors[int]][12]

Function[ int, {#,int-#}& /@ Range[int -1]][12]


Also, in case I want to do that later, how do I eliminate lists from a list, which only differ in order, e.g. how do I reduce {{a,b},{b,a}} to {{a,b}} ?

(Side note: These problems arise in writing the code for this bigger problem)

• Have you seen IntegerPartitions[]? Commented Nov 23, 2012 at 10:51
• Since the answers below are from nearly a decade ago: Has Wolfram since introduced a built-in for product pairs? Commented Dec 27, 2021 at 4:43
• @theorist Asking here you probably reach nobody but me and I don't know. Commented Dec 28, 2021 at 20:22
• I thought the others who answered might be notified of my comment on your post, but perhaps that's not how the notifications work here. Commented Dec 28, 2021 at 20:25
• Pretty sure you only get a notification if it's under your post/writing. Commented Dec 28, 2021 at 20:27

a)

We can pass through the first half of the list of divisors to avoid duplicating factors. There are many possible ways to proceed, let's mention a few of them :

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


or

f2[n_] := Module[{k, l}, k = Divisors @ n; l = Length @ k;
Table[{k[[i]], k[[l + 1 - i]]}, {i, Ceiling[l/2] }] ]


or a completely different (less efficient) approach :

f3[n_Integer] /; n > 0 := Solve[x y == n && 0 < x <= y, {x, y}, Integers][[All, All, 2]]


e.g.

f1[37900003]
And @@ (f1[#] == f2[#] == f3[#] & /@ Range[100, 200])

{{1, 37900003}, {19, 1994737}, {131, 289313}, {2489, 15227}}
True


b)

Let's point out three different ways, using various Mathematica functions, respectively IntegerPartitions, FrobeniusSolve and PowersRepresentations :

g1[n_Integer /; n > 0] := IntegerPartitions[n, {2}]
g2[n_Integer /; n > 0] := FrobeniusSolve[{1, 1}, n]
g3[n_Integer /; n > 0] := PowersRepresentations[n, 2, 1]


All these functions yield outputs in different forms; g2, g3 include zeros, in g2 the ordering is valid, e.g.

g1[15]

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

g2[15]

{{0, 15}, {1, 14}, {2, 13}, {3, 12}, {4, 11}, {5, 10}, {6, 9}, {7, 8},
{8, 7}, {9, 6}, {10, 5}, {11, 4}, {12, 3}, {13, 2}, {14, 1}, {15, 0}}

g3[15]

{{0, 15}, {1, 14}, {2, 13}, {3, 12}, {4, 11}, {5, 10}, {6, 9}, {7, 8}}


We can get rid of 0, e.g. wrapping g2 or g3 in DeleteCases, e.g. :

DeleteCases[ g3[15], {___, 0, ___}]

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


A more general approach is PowersRepresentations[n,k,p], which gives the distinct representations of the integer n as a sum of k non-negative p -th integer powers, e.g. PowersRepresentations[n, 2, 3] gives all possible natural pairs {a,b} satisfying : $\; a^3+b^3 = n$, e.g. :

PowersRepresentations[855, 2, 3]

{{7, 8}}


indeed 7^3 + 8^3 == 855.

Using g1 or g3 we needn't to eliminate sets which only differ in order, anyway one can use DeleteDuplicates or Union, e.g. :

Union[{{a, b}, {b, c}, {c, a}, {b, a}, {a, c}}, SameTest -> (Sort[#1] === Sort[#2] &)]


and

DeleteDuplicates[{{a, b}, {b, c}, {c, a}, {b, a}, {a, c}}, Sort[#1] == Sort[#2] &]


yield :

{{a, b}, {a, c}, {b, c}}


For part (b) of your question, there is a built-in function:

  IntegerPartitions[12, {2}]
(* {{11, 1}, {10, 2}, {9, 3}, {8, 4}, {7, 5}, {6, 6}} *)


For the last part,

 deDup1 = DeleteDuplicates[#, #1 == Reverse@#2 &] &;
(* or *)
deDup2 = DeleteDuplicates[#, Union@#1 == Union@#2 &] &;
deDup1@Function[int, {#, int/#} & /@ Divisors[int]][12]
(* {{1, 12}, {2, 6}, {3, 4}} *)


Update: and for part (a) - big thanks to @Rojo for the idea - you can use:

divPairsF1 = Divisors[#] /.
d_ :> Transpose @ MapAt[ Reverse,
Partition[d, Sequence @@ Through @ {Ceiling, Floor}[Length@d/2]],
1  ] &;
(* or *)
Reverse[#[[1 + Floor[Length[#]/2];;]]]}] &[Divisors[#]] &;
(* or *)
divPairsF3 =DeleteDuplicates@(Sort /@ (Thread[{#, Reverse[#]}] &@Divisors[#])) &;

divPairsF1[12]
(* {{1,12},{2,6},{3,4}} *)

• cool, can it also produce the flipped sets, e.g. $\{2,10\}$? Commented Nov 23, 2012 at 11:12
• You could also rely on the Divisors ordering and do something like Divisors[int]/.d_:>Transpose@MapAt[Reverse, Partition[d, Length@d/2], 2]
– Rojo
Commented Nov 23, 2012 at 11:20
• IntegerPartitions gives the partitions in reverse-lex order. To get a list including the flipped sets, you can use Join @@ ({#, Reverse /@ #} &[ IntegerPartitions[12, {2}]]) // DeleteDuplicates
– kglr
Commented Nov 23, 2012 at 11:20
• @Rojo, thank you, great idea. Updated with your suggestion.
– kglr
Commented Nov 23, 2012 at 11:49
• Sorry for my code, but one should beware of the cases with odd number of divisors. Perhaps changing to Partition[d, Sequence @@ Through@{Ceiling, Floor}[Length@d/2]], or in your version, adding a Ceiling to the first Span and a Floor to the second
– Rojo
Commented Nov 23, 2012 at 14:05

For product pairs you might use:

pp = Thread[{#, Reverse@#}][[ ;; Ceiling[Length@#/2] ]] & @ Divisors @ # &;


This is several times faster than your construct on my machine.

You may also be interested in this function which is a generalization of this to n products.

For additive pairs IntegerPartitions has already been recommended.