Generating pairs of additive and multiplicative factors for integers

Question

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)

Since the answers below are from nearly a decade ago: Has Wolfram since introduced a built-in for product pairs? — theorist, Dec 27 '21 at 04:43
@theorist Asking here you probably reach nobody but me and I don't know. — Nikolaj-K, Dec 28 '21 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. — theorist, Dec 28 '21 at 20:25
Pretty sure you only get a notification if it's under your post/writing. — Nikolaj-K, Dec 28 '21 at 20:27

Artes · Accepted Answer · 2012-11-27T18:30:22.257

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

score 3 · Answer 2 · edited Nov 26 '12 at 18:15

3

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 *)
divPairsF2 = Thread[{#[[;; Ceiling[Length[#]/2]]], 
               Reverse[#[[1 + Floor[Length[#]/2];;]]]}] &[Divisors[#]] &;
 (* or *)
divPairsF3 =DeleteDuplicates@(Sort /@ (Thread[{#, Reverse[#]}] &@Divisors[#])) &;

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

edited Nov 26 '12 at 18:15

Artes

57,212
12
157
245

answered Nov 23 '12 at 10:57

kglr

394,356
18
477
896

cool, can it also produce the flipped sets, e.g. ${2,10}$? – Nikolaj-K Nov 23 '12 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 Nov 23 '12 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 Nov 23 '12 at 11:20
@Rojo, thank you, great idea. Updated with your suggestion. – kglr Nov 23 '12 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 Nov 23 '12 at 14:05
@Rojo, thanks again. – kglr Nov 23 '12 at 15:47

score 1 · Answer 3 · edited Apr 13 '17 at 12:41

1

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.

edited Apr 13 '17 at 12:41

Community

1

answered Nov 23 '12 at 13:28

Mr.Wizard

271,378
34
587
1,371

Generating pairs of additive and multiplicative factors for integers

3 Answers3

Linked