4
$\begingroup$

I have a list of numbers:

allNums = 
 {2, 5, 10, 17, 26, 1, 3, 7, 13, 21, 31, 1, 2, 11, 28, 53, 1, 6, 19, 40, 69}

I calculate all possible pairs of two numbers from the values in this list:

allCombs = Permutations[allNums, {2}]

and the sums of all those possible pairs

allSums = Total /@ allCombs

Now I'm choosing a number, let's say 61, and look if this numbers is a sum of the possible pairs in allCombs and extract the values

Num = 61; Extract[allCombs, Position[allSums, Num]]

which gives me:

{{21, 40}, {40, 21}}

My problem is to do the same process again for the retrieved values above until no longer possible, i.e., selecting a number and looking if this number can be represented as the sum of a pair in allCombs. I'm unable to find an elegant solution for this.

For example, now I would take the values 21, 40, 40, 21 and calculate

Num = 21; Extract[allCombs, Position[allSums, Num]]

and

Num = 40; Extract[allCombs, Position[allSums, Num]]

and the same for 40 and 21 (which yields the same values after all, but I also don't know how to remove those duplicate values since they are in reverse order).

Now I would like to repeat this process again and again until no longer possible, e.g. for 21 I extract:

{{2, 19}, {10, 11}, {11, 10}, {19, 2}}

then I would repeat the process for 2,19,10,11 and so on. I hope what I mean is clear :).

I was trying to play around with the Nest, NestList and NestWhileList`, but I didn't manage to make it work.

Any help appreciated!

$\endgroup$
  • $\begingroup$ Also, what is the format of the data you want as a result? All of the lists? A list of the numbers? $\endgroup$ – march Dec 2 '15 at 16:45
  • 2
    $\begingroup$ I take that back. You do want to use Nest and NestList. The trick is to create the right function. $\endgroup$ – march Dec 2 '15 at 16:46
8
$\begingroup$

You can use allCombs = Select[Permutations[allNums, {2}], OrderedQ] to check only ordered permutations.

Using this:

findSum[num_] := Extract[allCombs, Position[allSums, num]]
findSums[nums_] := Flatten[findSum /@ DeleteDuplicates[Flatten[nums]], 1]

FixedPointList[findSums, {61}, 100] // Column

{

{{61}},

{{{21, 40}}},

{{{2, 19}, {10, 11}, {19, 21}}},

{{{1, 1}, {2, 17}, {6, 13}, {3, 7}, {5, 6}, {1, 10}, {2, 19}, {10, 11}}},

{{{1, 1}, {7, 10}, {6, 11}, {1, 5}, {2, 11}, {3, 10}, {6, 7}, {1, 2}, {2, 5}, {1, 6}, {2, 3}, {3, 7}, {2, 17}, {6, 13}, {5, 6}, {1, 10}}},

{{{2, 5}, {1, 6}, {3, 7}, {1, 5}, {5, 6}, {1, 10}, {2, 3}, {1, 1}, {1, 2}, {7, 10}, {6, 11}, {2, 11}, {3, 10}, {6, 7}}},

{{{1, 1}, {2, 3}, {1, 5}, {1, 2}, {2, 5}, {1, 6}, {3, 7}, {5, 6}, {1, 10}}},

{{{1, 1}, {1, 2}, {2, 3}, {1, 5}, {2, 5}, {1, 6}, {3, 7}}},

{{{1, 1}, {1, 2}, {2, 3}, {1, 5}, {2, 5}, {1, 6}}},

{{{1, 1}, {1, 2}, {2, 3}, {1, 5}}},

{{{1, 1}, {1, 2}, {2, 3}}},

{{{1, 1}, {1, 2}}},

{{{1, 1}}},

{{}},

{{}} }

(FixedPointList is like NestList, except that it stops when the result doesn't change any more, when it found the fixed point)

$\endgroup$
  • $\begingroup$ Thanks! is it possible to order the pairs (maybe without removing duplicates) in order to know which pairs sum up to the higher number. For example {{{2,19},{10,11}},{{21,19}}. Otherwise it becomes quite difficult to sort out which numbers belong together. $\endgroup$ – holistic Dec 2 '15 at 18:32
  • $\begingroup$ @holistic: Sure, just apply Flatten and DeleteDuplicates earlier $\endgroup$ – Niki Estner Dec 2 '15 at 18:53
  • $\begingroup$ awesome, thanks! $\endgroup$ – holistic Dec 2 '15 at 19:19
4
$\begingroup$

First, let's find all the numbers that are part of possible pairs, which we can do in a more direct fashion using Pick.

 selectTotals[combos : {___List}, totals : {___?NumericQ}, nums_List] :=
   DeleteDuplicates@Flatten@Pick[combos, totals, Alternatives @@ nums];

Then we can find all the combinations using Subset (since order doesn't matter, this will check half as many pairs as using Permutations) and use FixedPointList (as in [nixie's answer][1]) to go until the list of results stops changing (on the off chance that the list doesn't collapse into an empty list, this is more robust):

iteratedTotals[nums_, init_] :=
 Module[{combos = Subsets[nums, {2}], totals},
  totals = Total[combos, {2}];

  Most@FixedPointList[selectTotals[combos, totals, #] &, 
    Flatten[{init}]]];

I used Most to get rid of the extra duplicated result at the end. Calling the function on allNums yields the following:

iteratedTotals[allNums, 61]
(* {{61}, {21, 40}, {2, 19, 10, 11, 21}, 
    {2, 17, 19, 5, 6, 10, 1, 11, 3, 7, 13}, 
    {2, 5, 17, 1, 3, 11, 6, 10, 7, 13}, 
    {2, 5, 1, 3, 11, 6, 10, 7}, 
    {2, 5, 1, 3, 6, 10, 7}, 
    {2, 5, 1, 3, 6, 7}, {2, 5, 1, 3, 6}, 
    {2, 1, 3, 5}, {2, 1, 3}, {2, 1}, {1}, {}} *)

Update:

Changing things to preserve the pairs is actually pretty straightforward; you just Flatten at a different time, like so:

 selectCombinations[combos : {___List}, totals : {___?NumericQ}, nums_List] := 
   DeleteDuplicates@Pick[combos, totals, Alternatives @@ Flatten[nums]];

 iteratedCombinations[nums_, init_] :=
  Module[{combos = Subsets[nums, {2}], totals}, 
    totals = Total[combos, {2}];
    Most@FixedPointList[
     selectCombinations[combos, totals, #] &, {init}]];

iteratedCombinations[allNums, 61]
(* {{61}, {{21, 40}}, ...} *) 
$\endgroup$
  • $\begingroup$ Thanks..very helpful! The problem is, that by removing the duplicates the numbers get kind of mixed up, so that it is not clear which numbers sum to e.g. 21 and 40. A list of the form {{{2,19},{10,11}},{{21,19}}} would be better, but I'm not sure how to adapt your code. $\endgroup$ – holistic Dec 2 '15 at 18:28

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.