4
$\begingroup$

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)

$\endgroup$
5
  • $\begingroup$ Have you seen IntegerPartitions[]? $\endgroup$ Commented Nov 23, 2012 at 10:51
  • $\begingroup$ Since the answers below are from nearly a decade ago: Has Wolfram since introduced a built-in for product pairs? $\endgroup$
    – theorist
    Commented Dec 27, 2021 at 4:43
  • $\begingroup$ @theorist Asking here you probably reach nobody but me and I don't know. $\endgroup$
    – Nikolaj-K
    Commented Dec 28, 2021 at 20:22
  • $\begingroup$ 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. $\endgroup$
    – theorist
    Commented Dec 28, 2021 at 20:25
  • $\begingroup$ Pretty sure you only get a notification if it's under your post/writing. $\endgroup$
    – Nikolaj-K
    Commented Dec 28, 2021 at 20:27

3 Answers 3

4
$\begingroup$

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}}
$\endgroup$
3
$\begingroup$

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}} *)
$\endgroup$
6
  • $\begingroup$ cool, can it also produce the flipped sets, e.g. $\{2,10\}$? $\endgroup$
    – Nikolaj-K
    Commented Nov 23, 2012 at 11:12
  • $\begingroup$ You could also rely on the Divisors ordering and do something like Divisors[int]/.d_:>Transpose@MapAt[Reverse, Partition[d, Length@d/2], 2] $\endgroup$
    – Rojo
    Commented Nov 23, 2012 at 11:20
  • $\begingroup$ 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 $\endgroup$
    – kglr
    Commented Nov 23, 2012 at 11:20
  • $\begingroup$ @Rojo, thank you, great idea. Updated with your suggestion. $\endgroup$
    – kglr
    Commented Nov 23, 2012 at 11:49
  • $\begingroup$ 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 $\endgroup$
    – Rojo
    Commented Nov 23, 2012 at 14:05
1
$\begingroup$

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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