# Create a list of the first 100 deficient numbers

For the purposes of the assignment, I need these values in a table. We have so far only used for/while loops to check the deficiency or abundance of certain types of numbers. I initially tried using a for loop and AppendTo at my instructor's suggestion, but I couldn't get it to work.

I briefly dabbled with sow and reap, but I had no idea where to start with it. Then I found the TakeWhile function and thought that would work. But it didn't seem to know what to do with DivisorSum in the criteria. Is there a way to make TakeWhile[list,#

Here's what I've tried, sorry it's a such a mess.

    n = 100;
(*While[x\[LessEqual]n,Print[StringForm["Divisors of  = ; sum of \
divisors =    ()" \
,x,Most[Divisors[x]],ds=DivisorSum[(x),#&,#<x&],Piecewise[{{">",ds>x},\
{"<",ds<x},{"=",ds=x}}],x,Piecewise[{{"abundant",ds>x},{"deficient",\
ds<x},{"perfect",ds=x}}]]];x=x+1;i=x]*)
def = {}
(*Array[def,n]*)
\
(*AppendTo[def,For[i=1,i\[LessEqual]n,i++,Print[{i,DivisorSum[i,#&,#<\
i&]}]]]*)
\
(*For[i=1,i\[LessEqual]n,i++,Print[{i,DivisorSum[i,#&,#<i&]}]]*)
\
(*For[i=1,i\[LessEqual]n,i++,Print[StringForm["Sum of proper divisors \
for  =  this is   \
()",i,ds=DivisorSum[i,#&,#<i&],Piecewise[{{">",ds>i},{"<",ds<i},{"=\
",ds=i}}],i,Piecewise[{{"abundant",ds>i},{"deficient",ds<i},{\
"perfect",ds=i}}]]]]*)
div =
For[i = 1, i <= n, i++, Print[{i, a = DivisorSum[i, # &, # < i &]}]]
TakeWhile[{div}, # < a]
num = Table[i + 1, {i, 0, 99}]
divtb = Table[DivisorSum[i, # &, # < i &], {i, n}]
TakeWhile[num, # < DivisorSum[#, # &, # < i &]]


Any and all suggestions appreciated. Thanks.

• It would be helpful if you included only relevant code. (A whole bunch of commented code makes it harder to parse what you have.) In addition, it would be useful to describe the mathematical problem you are trying to solve rather than having us try to infer it from your code. Oct 21, 2019 at 22:34

You can use ILDDeficientNumberQ:

i=0; k=1;
Reap[While[k <= 100, If[ILDDeficientNumberQ[++i], k++; Sow[i]]]][[2,1]]


{1, 2, 3, 4, 5, 7, 8, 9, 10, 11, 13, 14, 15, 16, 17, 19, 21, 22, 23, 25, 26, 27, 29, 31, 32, 33, 34, 35, 37, 38, 39, 41, 43, 44, 45, 46, 47, 49, 50, 51, 52, 53, 55, 57, 58, 59, 61, 62, 63, 64, 65, 67, 68, 69, 71, 73, 74, 75, 76, 77, 79, 81, 82, 83, 85, 86, 87, 89, 91, 92, 93, 94, 95, 97, 98, 99, 101, 103, 105, 106, 107, 109, 110, 111, 113, 115, 116, 117, 118, 119, 121, 122, 123, 124, 125, 127, 128, 129, 130, 131}

or use the definition of ILDDeficientNumberQ directly:

i = 0; k = 1;
Reap[While[k <= 100, If[DivisorSigma[1, ++i] < 2 i, k++; Sow[i]]]][[2, 1]]


same result

Alternatively, use DivisorSum:

i = 0; k = 1;
Reap[While[k <= 100,  If[DivisorSum[++i, # &] < 2 i, k++; Sow[i]]]][[2, 1]]


same result

• I had searched the documentation for anything to do with deficient numbers, but I couldn't find anything. The only thing I knew for sure was PerfectNumber and PerfectNumberQ, but I didn't see how that would help. This elegantly simple code does exactly what I need, but where can I find more to read about ILDDeficientNumberQ? Oct 22, 2019 at 17:20
• @hemicyon, it is not documented. I found it using Names["**Deficient*"]. You (btw, there is also ILDAbundantNumberQ.) You can see its definition using Needs["GeneralUtilities"]; PrintDefinitions[ILDDeficientNumberQ].
– kglr
Oct 22, 2019 at 17:36

According to Sloane's A005100, the n^th deficient number is asymptotic to between 1.3287*n and 1.3298*n. Use a slightly larger limit to capture exceptions.

nFirstDeficientNumbers[n_] :=
With[{r = Range[1.35 n]},
Take[Pick[r, UnitStep[DivisorSigma[1, r] - 2 r], 0], n]
]