Perfect numbers
A faster approach to finding Perfect numbers using DivisorSigma
Select[Range[10^6], DivisorSigma[1, #] == 2 # &]
{6, 28, 496, 8128}
Here's an even faster approach:
Pick[#, MapThread[Equal, {DivisorSigma[1, #], 2 #}], True] &[Range[10^6]]
and a little bit faster:
Pick[#, DivisorSigma[1, #] - 2 #, 0] &@Range[10^6]
For Abundant numbers do:
Select[Range[10^6], (DivisorSigma[1, #] - #) > # &]
and a faster approach as above:
Pick[#, MapThread[Greater, {DivisorSigma[1, #] - #, #}], True] &[Range[10^6]]
By giving Greater
the Listable
Attribute
we can squeeze out some more performance:
SetAttributes[Greater, Listable]
Pick[#, DivisorSigma[1, #] > 2 #, True] &@Range[10^6]
Edit :
For this particular problem since we know that the largest Perfect number is less than 10000
, we can begin to hit miliseconds regime using ParallelMap
:
ParallelMap[Pick[#, DivisorSigma[1, #] - 2 #, 0] &, {Range[2, 5*^3, 2],
Range[5*^3 + 2, 1*^4, 2]}] // Flatten // AbsoluteTiming
{0.015627, {6, 28, 496, 8128}}
Of course this will also give us speed up if we scan the entire range.
Perfect numbers:
Select[ Range[10^6], Total[Divisors @ #] == 2 # &]
{6, 28, 496, 8128}
abundant numbers:
Select[ Range[10^3], Total[ Most @ Divisors @ #] > # &]//Short
{ 12, 18, 20, 24, 30, 36, 40, 42, 48, <<228>>, 968, 972, 978, 980, 984, 990, 992, 996, 1000}
I used Short
to to get only a few since there are:
Count[ Range[10^3], _?(Total[Most@Divisors@#] > # &)]
246
of them.
Edit
As RunnyKine pointed out that using DivisorSigma[1, #] &
is more efficient than Total @ Divisors @ # &
. Another improvement might be exploiting the fact that there are no known odd perfect numbers, it was verified that there is none below 10^1500
. The largest known perfect number (48
-th) has only 34850340
digits i.e. IntegerLength[2^(57885161 - 1) (2^57885161 - 1)]
. Taking the above into account we get 2
times speed up with:
Pick[ #, DivisorSigma[1, #] - 2 #, 0]& @ Range[2, 10^6, 2]
However we can observe there are odd abundant numbers, but they are sparsely distributed among even ones. Below 1000
there is only one ( while there are 245
even ones):
Pick[ #, UnitStep[ DivisorSigma[1, #] - 2 # - 1], 1]& @ Range[1, 10^3, 2]
{945}
Below 10^6
there are
Length @ Pick[ #, UnitStep[ DivisorSigma[1, #] - 2 # - 1], 1] & /@
{Range[ 2, 10^6, 2], Range[ 1, 10^6, 2]}
{245549, 1996}
even and odd abundant numbers respectively.
It is remarkable that Length @ Pick[ Range[10^6], UnitStep[ DivisorSigma[1, #] - 2 # - 1], 1]]
is faster than : Count[ Range[10^6], _?(DivisorSigma[1, #] > 2 # &)]
.
Or how about the connection between even perfect numbers and Mersenne primes?
With[{p = Prime[Range[20]]},
Pick[p, PrimeQ[2^p - 1]] /. q_ -> 2^(q - 1) (2^q - 1)]
Update for perfect numbers only.
As noted in previous answers, DivisorSigma[1,n]
is faster than summing Divisors
, and Pick
is faster than Select
. So even perfect numbers may be found by using
RepeatedTiming[Pick[#, DivisorSigma[1, #] - 2 #, 0] &@Range[2, 10^6, 2]]
which gives a timing of 1.34 s on my machine. These approaches are slow compared to the clever divisor sum by @MichaelE2. The repeated timing of his function is a tiny 0.056 s.
@QuantumDot points out the new v10.4 functions PerfectNumber[n]
and PerfectNumberQ[n]
. However, the following takes a glacial 4 seconds! Why?
RepeatedTiming[Pick[#, Map[PerfectNumberQ, #]] &@Range[2, 10^6, 2]]
The Help page for the new v10.4 function MersennePrimeExponent
shows how to instantly calculate even perfect numbers.
RepeatedTiming[2^(# - 1)*(2^# - 1) &[MersennePrimeExponent[Range[4]]]]