How to generate this structure of a list without `While` and the like?

Question

I need to create a list that holds, for given integer d, the elements $1,\ldots,d,d+2,\ldots,2d,2d+3,\ldots,3d,3d+4,\ldots,d^2$ where $\ldots$ is just denoting increment by 1 until the next written value is reached (as usual).

My naive attempt is this:

ClearAll[list];
list[d_] := Module[{tmp = {}, n = 0}, While[(n + 1)*d <= d^2, AppendTo[tmp, Range[n*(d + 1) + 1, (n + 1)*d]]; n++]; Flatten@tmp];

which produces what I want, e.g.

list[3]
(* {1,2,3,5,6,9} *)

However, I would be very interested how (or maybe if) this can be achieved without using things like While and For. I guess there is a nice approach for this...

Update

Here are some timings for the current approaches on my machine:

At least for larger d, the second solution by @ciao scales best (although only marginally faster than the one by @gpap). Since ciao's approach is also faster than gpap's for small d, I decided to accept his solution. But all approaches are very nice, so it was a bit difficult to choose the "one" that will be accepted.

Answer 1

This seems pretty quick...

Block[{base = ConstantArray[1, Binomial[# + 1, 2]]},
  base[[Accumulate@Range[#, 2, -1] + 1]] += Range[# - 1];
  Accumulate@base] &

and this seems faster...

Block[{r = Range[#, #^2, #]}, Join @@ Range[Subtract[r, Range[# - 1, 0, -1]], r]] &

Answer 2

Whenever you're building a list with While or For, there's a good chance Table or Array can help. In this case, the solution with Table is quite simple: just use two iterators and make the bounds of the second dependent on the first iterator:

list[d_] := Join @@ Table[i*d + j, {i, 0, d}, {j, i + 1, d}]

The Join @@ is used to flatten the array. Flatten @ would also do, but I prefer the former when I know that I'm only flattening one level.

As you noted this is quite a bit slower than your own solution. If performance is a concern, you can use this slightly less readable form that combines Table with Range and appears to be about 10 to 20 times faster than your code:

list[d_] := Join @@ Table[Range[i*d + i + 1, (i + 1) d], {i, 0, d}]

Answer 3

This works:

f[d_] := Join @@ MapThread[
   Range, 
   Transpose@Table[{(i - 1) d + i, i d}, {i, d}]
   ];

so

f[3]
{1, 2, 3, 5, 6, 9}

and it's pretty fast as well:

AbsoluteTiming[f[10000];]
{0.410494, Null}

same caveat about Join@@ vs Flatten@ as Martin Büttner by whose wise comment this can be simplified to merely:

f[d_] := Join @@ Range @@@ Table[{(i - 1) d + i, i d}, {i, d}]

Answer 4

Another way without Table:

listN[d_]:= Join @@ NestList[d + Rest@# &, Range[d], d - 1]

It performs not so bad but slower than the fastest methods.

Answer 5

different ... but slow :)

f1 = SparseArray[UpperTriangularize[Partition[Range[#^2], #]]][ "NonzeroValues"] &

f1 /@ {3, 4}

{{1, 2, 3, 5, 6, 9},
{1, 2, 3, 4, 6, 7, 8, 11, 12, 16}}

Also different but slower:

f2 = Flatten[UpperTriangularize[Partition[Range[#^2], #]] /. 0 -> (## &[])] &

f3 = Sort[SparseArray[{i_, j_} /; i <= j :> (i - 1) # + j, {#, #}]["NonzeroValues"]] &;
f1 /@ {3, 4} == f2 /@ {3, 4} == f3 /@ {3, 4}

True

Answer 6

This seems a different approach, exchanging Table by ConstantArray and Accumulate

sieve[d_] := 
Module[{u = ConstantArray[1, d (d + 1)/2], o = Range[2, d], index},
  index = 1 + Accumulate[Reverse[o]];
  u[[index]] = o;
  Accumulate[u]
]

However, it does not seem to perform better than the other algorithms in my notebook:

AbsoluteTiming[sieve[10000];]
{0.923706, Null}

The procedural approach using the index table is faster:

proc[d_] := Module[{u = Range[d (d + 1)/2], filling, index},
  filling = Accumulate[ u[[1 ;; d]] ];
  index = 1 + Accumulate[ Reverse[ u[[1 ;; d]] ] ];
  Do[ u[[index[[i]] ;; index[[i + 1]] - 1 ]] += filling[[i]], {i,Length[index] - 1} ];
  u
  ]

AbsoluteTiming[ proc[10000];]
{0.588404, Null}