A072701 Number of ways to write n as the arithmetic mean of a set of distinct primes.
0, 1, 1, 2, 3, 4, 5, 10, 9, 18, 19, 40, 37, 80, 79, 188, 163, 385, 355, 855, 738, 1815, 1555, 3796, 3237, 8281, 6682, 17207, 13967, 35370, 28575, 74385, 58831, 153816, 119948, 312288, 244499, 643535, 495011, 1309267, 997381, 2629257, 2004295, 5334522
Offset: 1
Keywords
Examples
a(6) = 4, as 6 = (5+7)/2 = (2+3+13)/3 = (2+5+11)/3 = (2+3+5+7+13)/5; a(7) = 5, as 7 = 7/1 = (3+11)/2 = (3+5+13)/3 = (3+7+11)/3 = (3+5+7+13)/4.
Links
- Alois P. Heinz, Table of n, a(n) for n = 1..100
- Reinhard Zumkeller, Representing integers as arithmetic means of primes
Programs
-
Haskell
a072701 n = f a000040_list 1 n 0 where f (p:ps) l nl x | y > nl = 0 | y < nl = f ps (l + 1) (nl + n) y + f ps l nl x | otherwise = if y `mod` l == 0 then 1 else 0 where y = x + p -- Reinhard Zumkeller, Feb 13 2013 -
Maple
sp:= proc(i) option remember; `if`(i=1, 2, sp(i-1) +ithprime(i)) end: b:= proc(n,i,t) if n<0 then 0 elif n=0 then `if`(t=0, 1, 0) elif i=2 then `if`(n=2 and t=1, 1, 0) else b(n,i,t):= b(n, prevprime(i), t) +b(n-i, prevprime(i), t-1) fi end: a:= proc(n) local s, k; s:= `if`(isprime(n), 1, 0); for k from 2 while sp(k)/k<=n do s:= s +b(k*n, nextprime(k*n -sp(k-1)-1), k) od; s end: seq(a(n), n=1..28); # Alois P. Heinz, Jul 20 2009
-
Mathematica
Needs["DiscreteMath`Combinatorica`"]; a = Drop[ Sort[ Subsets[ Table[ Prime[i], {i, 1, 20}]]], 1]; b = {}; Do[c = Apply[Plus, a[[n]]]/Length[a[[n]]]; If[ IntegerQ[c], b = Append[b, c]], {n, 1, 2^20 - 1}]; b = Sort[b]; Table[ Count[b, n], {n, 1, 20}] t = Table[0, {200}]; k = 2; lst = Prime@Range@25; While[k < 2^25+1, slst = Flatten@Subsets[lst, All, {k}]; If[Mod[Plus @@ slst, Length@slst] == 0, t[[(Plus @@ slst)/(Length@slst)]]++ ]; k++ ]; t (* Robert G. Wilson v *) sp[i_] := sp[i] = If[i == 1, 2, sp[i - 1] + Prime[i]]; b[n_, i_, t_] := b[n, i, t] = Which[n < 0, 0, n == 0, If[t == 0, 1, 0], i == 2, If[n == 2 && t == 1, 1, 0], True, b[n, NextPrime[i, -1], t] + b[n - i, NextPrime[i, -1], t - 1]]; a[n_] := Module[{s, k}, s = If[PrimeQ[n], 1, 0]; For[k = 2, sp[k]/k <= n, k++, s = s + b[k*n, NextPrime[k*n - sp[k - 1] - 1], k]]; s]; Table[a[n], {n, 1, 44}] (* Jean-François Alcover, Feb 13 2018, after Alois P. Heinz *)
Extensions
Corrected by John W. Layman, Jul 11 2002
More terms from Alois P. Heinz, Jul 20 2009
Comments