A330507 a(n) is the smallest number k having for every prime p <= prime(n) at least one prime partition with least part p, and no such partition having least part > prime(n). If no such k exists then a(n) = 0 (see comments).

2, 6, 10, 18, 24, 30, 51, 57, 69, 60, 99, 111, 123, 143, 147, 159, 177, 189, 201, 213, 225, 245, 255, 267, 291, 303, 309, 321, 345, 357, 381, 393, 411, 427, 447, 465, 471, 493, 507, 519, 537, 553, 573, 583, 623, 621, 633, 669, 681, 695, 707, 729, 749, 753, 783

Offset: 1

Author

David James Sycamore, Mar 01 2020

Keywords

• nonn

Comments

Alternatively, a(n) is the smallest number whose product of distinct least part primes from all partitions of n into prime parts, is equal to primorial(n).

2 is the only prime term.

a(n) = 0 for n = 90, 151, 349, 352, 444, ... . - Alois P. Heinz, Mar 12 2020

Examples

			a(1) = 2 because [2] is the only prime partition of prime(1) = 2.
a(2) = 6 because [2,2,2] and [3,3] are the only possible prime partitions of 6, namely with prime(1) and prime(2) the only least parts.
		

Links

• Alois P. Heinz, Table of n, a(n) for n = 1..500
• Michael De Vlieger, Labeled plot of p at (pi(p), n), for 2 <= n <= 240, with k in a(n) shown in red.

Crossrefs

Cf. A000040, A051034, A331634, A332861, A002110, A333238.

Programs

Maple

b:= proc(n, p, t) option remember; `if`(n=0, 1, `if`(p>n, 0, (q->
      add(b(n-p*j, q, 1), j=1..n/p)*t^p+b(n, q, t))(nextprime(p))))
    end:
a:= proc(n) option remember; local f, k, p; p:= ithprime(n);
      for k to 4*p do f:= b(k, 2, x); if degree(f)<= p and andmap(
        h->0Alois P. Heinz, Mar 12 2020

Mathematica

With[{s = Array[Union@ Select[IntegerPartitions[#], AllTrue[#, PrimeQ] &][[All, -1]] &, 70]}, TakeWhile[Map[FirstPosition[s, #][[1]] &, Rest@ NestList[Append[#, Prime[Length@ # + 1]] &, {}, 12]], IntegerQ]] (* Michael De Vlieger, Mar 06 2020 *)
(* Second program: *)
Block[{a, m = 125, s}, a = ConstantArray[{}, m]; s = {Prime@ PrimePi@ m}; Do[If[# <= m, If[FreeQ[a[[#]], Last@ s], a = ReplacePart[a, # -> Union@ Append[a[[#]], Last@ s]], Nothing]; AppendTo[s, Last@ s], If[Last@ s == 2, s = DeleteCases[s, 2]; If[Length@ s == 0, Break[], s = MapAt[Prime[PrimePi[#] - 1] &, s, -1]], s = MapAt[Prime[PrimePi[#] - 1] &, s, -1]]] &@ Total[s], {i, Infinity}]; TakeWhile[Map[FirstPosition[a, #][[1]] &, Rest@ NestList[Append[#, Prime[Length@ # + 1]] &, {}, Max[Length /@ a]]], IntegerQ]] (* Michael De Vlieger, Mar 11 2020 *)

Extensions

a(19)-a(21) from Michael De Vlieger, Mar 12 2020

a(22)-a(55) from Alois P. Heinz, Mar 12 2020