A248513 Rectangular array by antidiagonals: the dispersion of A181155 ("odious numbers").

1, 2, 4, 3, 8, 6, 5, 15, 12, 7, 9, 29, 23, 14, 10, 17, 57, 45, 27, 20, 11, 33, 113, 89, 53, 39, 22, 13, 65, 225, 177, 105, 77, 43, 26, 16, 129, 449, 353, 209, 153, 85, 51, 32, 18, 257, 897, 705, 417, 305, 169, 101, 63, 36, 19, 513, 1793, 1409, 833, 609, 337

Offset: 1

Author

Clark Kimberling, Oct 08 2014

Keywords

• nonn
• tabl
• easy

Comments

Background discussion: Suppose that s is an increasing sequence of positive integers, that the complement t of s is infinite, and that t(1) = 1. The dispersion of s is the array D whose n-th row is (t(n), s(t(n)), s(s(t(n))), s(s(s(t(n)))), ...). Every positive integer occurs exactly once in D, so that, as a sequence, D is a permutation of the positive integers. The sequence u given by u(n) = (number of the row of D that contains n) is a fractal sequence, as in A248514.

The n-th term of column 1 is A001969(n) + 1, where A001969 are the "evil numbers".

Examples

			Northwest corner:
  1 ... 2 ... 3 ... 5 ... 9 .... 17 ... 33
  4 ... 8 ... 15 .. 29 .. 57 ... 113 .. 225
  6 ... 12 .. 23 .. 45 .. 89 ... 177 .. 353
  7 ... 14 .. 27 .. 53 .. 105 .. 209 .. 417
  10 .. 20 .. 39 .. 77 .. 153 .. 305 .. 609
		

References

• Clark Kimberling, Fractal sequences and interspersions, Ars Combinatoria 45 (1997) 157-168.

Links

• Clark Kimberling, Antidiagonals n = 1..60, flattened
• Clark Kimberling, Interspersions and dispersions, Proceedings of the American Mathematical Society, 117 (1993) 313-321.

Crossrefs

Cf. A248514.

Programs

Mathematica

r = 40; r1 = 10; (* r = # rows of T, r1 = # rows to show *);
c = 40; c1 = 12; (* c = # cols of T, c1 = # cols to show *);
x = GoldenRatio;
s[n_] := s[n] = If[n < 1, 0, 2 n - Mod[Total[IntegerDigits[n - 1, 2]], 2]];
mex[list_] := NestWhile[#1 + 1 &, 1, Union[list][[#1]] <= #1 &, 1,   Length[Union[list]]]; rows = {NestList[s, 1, c]};
Do[rows = Append[rows, NestList[s, mex[Flatten[rows]], r]], {r}];
t[i_, j_] := rows[[i, j]]; TableForm[Table[t[i, j], {i, 1, r1}, {j, 1, c1}]]
u = Flatten[Table[t[k, n - k + 1], {n, 1, c1}, {k, 1, n}]] (* A248513 *)
row[i_] := row[i] = Table[t[i, j], {j, 1, c}]
f[n_] := Select[Range[r], MemberQ[row[#], n] &]
v = Flatten[Table[f[n], {n, 1, 200}]]  (* A248514 *)