# Partitioning a number into consecutive integers

Consider n=45; then

$$1+2+3+4+5+6+7+8+9=45$$ $$5+6+7+8+9+10=45$$ $$7+8+9+10+11=45$$ $$14+15+16=45$$ $$22+23=45$$

Question: how to find all representations of a given positive integer n as a sum of consecutive positive integers smaller than n with an efficient Mathematica implementation? A brute-force method is straightforward, but it's likely to fail for big n, so a more clever idea is required.

It is sufficient (and concise) to provide only the start and end values of each sequence, i.e. {1, 9}, {5, 10} etc.

• Why the close vote? This is a question about how to efficiently implement any algorithm in MMA. Dec 25, 2016 at 20:20
• Reason to close: There is nothing in the question that relates directly to the Mathematica computer language; the "representation" of a sequence of consecutive integers as the first and last integer is of course trivial and unworthy of a question; very closely related questions are posted on mathematics.stackexchange.com e.g., math.stackexchange.com/questions/611135/… (showing this question belongs on that site). Dec 26, 2016 at 5:12
• @DavidG.Stork I disagree. In my answer I showed 3 different implementations with different efficiencies. I find this question similar to this one, which arose to a simple mistake, but lead to great answers exploiting MMA abilities. About the question here, I found it surprising that Solve works so well. Finally, it gained votes and obtained also two other answers, what I take as an indicator that this Q&A is not off topic. I'm not arguing, just presenting my motivation and opinion, to be clear. Dec 26, 2016 at 8:00
• See also this oldie from Math.SE Dec 26, 2016 at 12:56
• Dec 26, 2016 at 18:12

I took it as a challenge to avoid using Solve, which can be slower than a direct assault. If $a$ is the first number in the sum of consecutive positive integers, and $k$ is the count of integers summing to $n$, then $n=k*a+k(k-1)/2$. Solve this for $a=n/k-(k-1)/2$, with bounds $1 \le k \le {\rm Floor}[(\sqrt{8n+1}-1)/2]$. Consider the odd and even divisors of $n$ and $2n$, respectively, to give the following. This includes the $k=1$ case of the sum of one number, just $n$.

CoreyPartition[n_] :=
Block[{bound = Floor[(Sqrt[1 + 8 n] - 1)/2], oddk, evenk, k, e},
oddk = Pick[#,OddQ[#]] &[Pick[#, UnitStep[bound - #], 1]&[Divisors[n]]];
evenk = Pick[#, UnitStep[bound - #], 1] &[Divisors[2 n]];
e = IntegerExponent[n, 2];
evenk = Pick[evenk, IntegerExponent[evenk, 2], 1 + e];
k = Reverse[Sort[Join[oddk, evenk]]];
Transpose[{n/k - (k - 1)/2, n/k + (k - 1)/2}]]


A slight modification to f[n] for cases with no solution, such as $n=1,2,4,8,\ldots$.

f[n_] := If[# == {}, {}, {a, b} /. #]&[
Solve[(a + b) (b - a + 1)/2 == n && 0 < a < n && 0 < b < n,
{a, b}, Integers]]


The two solutions agree, for example:

Sum[Total[Most[CoreyPartition[n]] - f[n]], {n, 1, 200}]


However, testing with large integers such as n=10^40 showed CoreyPartition[n] was over 200 times faster.

Update

Given DivisorPairs from Mr.Wizard:

DivisorPairs[n_] :=


there is the following one-liner which is twice as fast as CoreyPartition.

CoreyFastPartition[n_] :=
Reverse[Pick[#, Total[Mod[#, 4], {2}], 2]] &[ DivisorPairs[8 n]] /.
{r_Integer, s_Integer} -> {(s - r + 2)/4, (s + r - 2)/4}


This code returns the trivial solution {n,n}, which may be removed with Most.

The sum of consecutive numbers from $a$ to $b$ is

$$\frac{(a+b)(b-a+1)}{2}$$

hence simply

f[n_] := {a, b} /.
Solve[(a + b) (b - a + 1)/2 == n && 0 < a < n && 0 < b < n, {a, b}, Integers]

f // AbsoluteTiming


{0.019466, {{1, 9}, {5, 10}, {7, 11}, {14, 16}, {22, 23}}}

It is straightforward and rather fast. As a test case:

f // AbsoluteTiming


{0.063403, {{23, 97}, {27, 98}, {78, 122}, {93, 132}, {168, 192}, {176, 199}, {293, 307}, {496, 504}, {559, 566}, {898, 902}, {1499, 1501}}}

This distribution is interesting:

ListPlot[tab = Table[{i, Length @ f[i]}, {i, 1000}], Filling -> Axis,
Frame -> True, PlotRange -> All,
FrameLabel -> {"n", "Length@f[n]"}]; // AbsoluteTiming


{12.3098, Null} The biggest number of partitions (Length@f[n] == 15) for n <= 1000 is for n = 945:

Select[tab, #[] == Max @ tab[[All,2]] &]


{{945, 15}}

while Length@f == 1 and Length@f == 3.

It works also with huge numbers:

f[10^11] // AbsoluteTiming


{0.149738, {{60688, 451312}, {925363, 1027762}, {1240938, 1319062}, {4872573, 4893052}, {6392188, 6407812}, {24412015, 24416110}, {31998438, 32001562}, {159999688, 160000312}, {799999938, 800000062}, {3999999988, 4000000012}, {19999999998, 20000000002}}}

f[10^40] // AbsoluteTiming // Short


{1.55024,{{39445166261547851563,146819348661547851562},<<38>>,{<<1>>}}}

(I'm surprised it works so well, and I think that the timing is quite acceptable too.)

A sample rejection method (brute force, with just a little trick to use Ceiling[n/2]):

n = 45;
MinMax /@
First /@ Select[
Flatten[#, 1] & @
Table[{Range[i, j], Total @ Range[i, j]}, {j, 1, Ceiling[n/2]}, {i, 1, j}],
#[] == n &]; // AbsoluteTiming


{0.000803, Null}

works well for this simple case (however, on my laptop it needs 14 sec for n = 4000) , but when

n = 4500;


it crashes the kernel.

g[n_] := Cases[FrobeniusSolve[Range @ n, n], {0 ..., 1 .., 0 ..}, Infinity]


is very slow:

(o = g); // AbsoluteTiming


{43.871, Null}

although works:

MinMax /@ (Pick[Range@45, #, 1] & /@ o) // Sort


{{1, 9}, {5, 10}, {7, 11}, {14, 16}, {22, 23}}

d[n_] := With[{dv = Divisors[n]}, {#, n/#} & /@
Pick[dv, # < Sqrt[n] & /@ dv]]
f[a_, b_] := With[{p = a - 1, q = b}, {(q - p)/2, (p + q)/2}]
res[n_] := Rest@Cases[f @@@ d[2 n], {_Integer, _Integer}]


So,

ListPlot[{#, Length[res[#]]} & /@ Range, Filling -> Axis]
ListPlot[DeleteCases[{#, #2 - #1 + 1 & @@ (res[#][[-1]])} & /@
Range, {_, {}}], Filling -> Axis,
Epilog -> {Red, Point[{# (# + 1)/2, #} & /@ Range]},
PlotLabel -> "Maximum Length of run"]
Cases[{#, res@#} & /@ Range, {x_, {}} :> x] Powers of 2 no non-trivial representation. Triangular numbers shown as red points.