I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

Arithmetic numbers

From Rosetta Code
Task
Arithmetic numbers
You are encouraged to solve this task according to the task description, using any language you may know.
Definition

A positive integer n is an arithmetic number if the average of its positive divisors is also an integer.

Clearly all odd primes p must be arithmetic numbers because their only divisors are 1 and p whose sum is even and hence their average must be an integer. However, the prime number 2 is not an arithmetic number because the average of its divisors is 1.5.

Example

30 is an arithmetic number because its 7 divisors are: [1, 2, 3, 5, 6, 10, 15, 30], their sum is 72 and average 9 which is an integer.

Task

Calculate and show here:

1. The first 100 arithmetic numbers.

2. The xth arithmetic number where x = 1,000 and x = 10,000.

3. How many of the first x arithmetic numbers are composite.

Note that, technically, the arithmetic number 1 is neither prime nor composite.

Stretch

Carry out the same exercise in 2. and 3. above for x = 100,000 and x = 1,000,000.

References




Ada[edit]

with Ada.Text_IO;         use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
 
procedure Main is
procedure divisor_count_and_sum
(n : Positive; divisor_count : out Natural; divisor_sum : out Natural)
is
I : Positive := 1;
J : Natural;
begin
divisor_count := 0;
divisor_sum  := 0;
loop
J := n / I;
exit when J < I;
if I * J = n then
divisor_sum  := divisor_sum + I;
divisor_count := divisor_count + 1;
if I /= J then
divisor_sum  := divisor_sum + J;
divisor_count := divisor_count + 1;
end if;
end if;
I := I + 1;
end loop;
end divisor_count_and_sum;
 
arithmetic_count : Natural  := 0;
composite_count  : Natural  := 0;
div_count  : Natural;
div_sum  : Natural;
mean  : Natural;
n  : Positive := 1;
begin
 
while arithmetic_count <= 1_000_000 loop
divisor_count_and_sum (n, div_count, div_sum);
mean := div_sum / div_count;
if mean * div_count = div_sum then
arithmetic_count := arithmetic_count + 1;
if div_count > 2 then
composite_count := composite_count + 1;
end if;
if arithmetic_count <= 100 then
Put (Item => n, Width => 4);
if arithmetic_count mod 10 = 0 then
New_Line;
end if;
end if;
if arithmetic_count = 1_000 or else arithmetic_count = 10_000
or else arithmetic_count = 100_000
or else arithmetic_count = 1_000_000
then
New_Line;
Put (Item => arithmetic_count, Width => 1);
Put_Line ("th arithmetic number is" & n'Image);
Put_Line
("Number of composite arithmetic numbers <=" & n'Image & ":" &
composite_count'Image);
end if;
end if;
n := n + 1;
end loop;
end Main;
Output:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

ALGOL 68[edit]

BEGIN # find arithmetic numbers - numbers whose average divisor is an integer #
# i.e. sum of divisors MOD count of divisors = 0 #
INT max number = 500 000; # maximum number we will consider #
[ 1 : max number ]INT d sum;
[ 1 : max number ]INT d count;
# all positive integers are divisible by 1 and so have at least 1 divisor #
FOR i TO max number DO d sum[ i ] := d count[ i ] := 1 OD;
# construct the divisor sums and counts #
FOR i FROM 2 TO max number DO
FOR j FROM i BY i TO max number DO
d count[ j ] +:= 1;
d sum[ j ] +:= i
OD
OD;
# count arithmetic numbers, and show the first 100, the 1 000th, 10 000th #
# and the 100 000th and show how many are composite #
INT max arithmetic = 100 000;
INT a count := 0;
INT c count := 0;
FOR i TO max number WHILE a count < max arithmetic DO
IF d sum[ i ] MOD d count[ i ] = 0 THEN
# have an arithmetic number #
IF d count[ i ] > 2 THEN
# the number is composite #
c count +:= 1
FI;
a count +:= 1;
IF a count <= 100 THEN
print( ( " ", whole( i, -3 ) ) );
IF a count MOD 10 = 0 THEN print( ( newline ) ) FI
ELIF a count = 1 000
OR a count = 10 000
OR a count = 100 000
THEN
print( ( newline ) );
print( ( "The ", whole( a count, 0 )
, "th arithmetic number is: ", whole( i, 0 )
, newline
)
);
print( ( " There are ", whole( c count, 0 )
, " composite arithmetic numbers up to ", whole( i, 0 )
, newline
)
)
FI
FI
OD
END
Output:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

The 1000th arithmetic number is: 1361
    There are 782 composite arithmetic numbers up to 1361

The 10000th arithmetic number is: 12953
    There are 8458 composite arithmetic numbers up to 12953

The 100000th arithmetic number is: 125587
    There are 88219 composite arithmetic numbers up to 125587

AutoHotkey[edit]

ArithmeticNumbers(n, mx:=0){
c := composite := 0
loop
{
num := A_Index, sum := 0
x := Factors(num)
for i, v in x
sum += v
av := sum / x.Count()
if (av = Floor(av))
{
res .= c++ <= 100 ? SubStr(" " num, -2) (mod(c, 25) ? " " : "`n") : ""
composite += x.Count() > 2 ? 1 : 0
}
if (c = n) || (c = mx)
break
}
return [n?num:res, composite]
}
Factors(n){
Loop, % floor(sqrt(n))
v := A_Index = 1 ? 1 "," n : mod(n,A_Index) ? v : v "," A_Index "," n//A_Index
Sort, v, N U D,
Return StrSplit(v, ",")
}
Examples:
MsgBox % Result := "The first 100 arithmetic numbers:`n"
. ArithmeticNumbers(0, 100).1
. "`nThe 1000th arithmetic number: "
. ArithmeticNumbers(1000).1
. "`tcomposites = "
. ArithmeticNumbers(1000).2
. "`nThe 10000th arithmetic number: "
. ArithmeticNumbers(10000).1
. "`tcomposites = "
. ArithmeticNumbers(10000).2
Output:
The first 100 arithmetic numbers:
  1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33  35  37  38  39  41
 42  43  44  45  46  47  49  51  53  54  55  56  57  59  60  61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113
114 115 116 118 119 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

The 1000th arithmetic number: 1361	composites = 782
The 10000th arithmetic number: 12953	composites = 8458

BASIC[edit]

True BASIC[edit]

Translation of: FreeBASIC
LET n = 1
DO
LET div = 1
LET divcnt = 0
LET sum = 0
DO
LET quot = n/div
IF quot < div THEN EXIT DO
IF REMAINDER(n, div) = 0 THEN
IF quot = div THEN  !n IS a square
LET sum = sum+quot
LET divcnt = divcnt+1
EXIT DO
ELSE
LET sum = sum+div+quot
LET divcnt = divcnt+2
END IF
END IF
LET div = div+1
LOOP
 
IF REMAINDER(sum, divcnt) = 0 THEN  !n IS arithmetic
LET arithcnt = arithcnt+1
IF arithcnt <= 100 THEN
PRINT USING "####": n;
IF REMAINDER(arithcnt, 20) = 0 THEN PRINT
END IF
IF divcnt > 2 THEN LET compcnt = compcnt+1
SELECT CASE arithcnt
CASE 1000
PRINT
PRINT USING "The #######th arithmetic number is #####,### up to which ###,### are composite.": arithcnt, n, compcnt
CASE 10000, 100000, 1000000
PRINT USING "The #######th arithmetic number is #####,### up to which ###,### are composite.": arithcnt, n, compcnt
CASE ELSE
REM
END SELECT
END IF
LET n = n+1
LOOP UNTIL arithcnt >= 1000000
END
Output:
Same as FreeBASIC entry.

XBasic[edit]

Works with: Windows XBasic
Translation of: FreeBASIC
PROGRAM	"ArithmeticNum"
 
DECLARE FUNCTION Entry ()
 
FUNCTION Entry ()
N = 1 : ArithCnt = 0 : CompCnt = 0
 
PRINT "The first 100 arithmetic numbers are:"
DO
Div = 1 : DivCnt = 0 : Sum = 0
DO WHILE 1
Quot = N / Div
IF Quot < Div THEN EXIT DO
IF N MOD Div = 0 THEN
IF Quot = Div THEN 'N is a square
Sum = Sum + Quot
INC DivCnt
EXIT DO
ELSE
Sum = Sum + Div + Quot
DivCnt = DivCnt + 2
END IF
END IF
INC Div
LOOP
 
IF Sum MOD DivCnt = 0 THEN 'N is arithmetic
INC ArithCnt
IF ArithCnt <= 100 THEN
PRINT FORMAT$("####", N);
IF ArithCnt MOD 20 = 0 THEN PRINT
END IF
IF DivCnt > 2 THEN INC CompCnt
SELECT CASE ArithCnt
CASE 1e3
PRINT "\nThe "; FORMAT$("#######", ArithCnt); "th arithmetic number is"; FORMAT$("####,###", N); " up to which"; FORMAT$("###,###", CompCnt); " are composite."
CASE 1e4, 1e5, 1e6
PRINT "The "; FORMAT$("#######", ArithCnt); "th arithmetic number is"; FORMAT$("####,###", N); " up to which"; FORMAT$("###,###", CompCnt); " are composite."
END SELECT
END IF
INC N
LOOP UNTIL ArithCnt >= 1e6
 
END FUNCTION
END PROGRAM
Output:
Same as FreeBASIC entry.

Yabasic[edit]

Translation of: FreeBASIC
// Rosetta Code problem: http://rosettacode.org/wiki/Arithmetic_numbers
// by Jjuanhdez, 06/2022
 
N = 1 : ArithCnt = 0 : CompCnt = 0
 
print "The first 100 arithmetic numbers are:"
repeat
Div = 1 : DivCnt = 0 : Sum = 0
while True
Quot = int( N / Div)
if Quot < Div break
if mod(N, Div) = 0 then
if Quot = Div then //N is a square
Sum = Sum + Quot
DivCnt = DivCnt + 1
break
else
Sum = Sum + Div + Quot
DivCnt = DivCnt + 2
end if
end if
Div = Div + 1
end while
 
if mod(Sum, DivCnt) = 0 then //N is arithmetic
ArithCnt = ArithCnt + 1
if ArithCnt <= 100 then
print N using "####";
if mod(ArithCnt, 20) = 0 print
end if
if DivCnt > 2 CompCnt = CompCnt + 1
switch ArithCnt
case 100
print
case 1000 : case 10000 : case 100000 : case 1e6
print "The ", ArithCnt using "#######", "th arithmetic number is ", N using "####,###", " up to which ", CompCnt using "###,###", " are composite."
end switch
end if
N = N + 1
until ArithCnt >= 1000000
Output:
Similar to FreeBASIC entry.

C[edit]

#include <stdio.h>
 
void divisor_count_and_sum(unsigned int n, unsigned int* pcount,
unsigned int* psum) {
unsigned int divisor_count = 1;
unsigned int divisor_sum = 1;
unsigned int power = 2;
for (; (n & 1) == 0; power <<= 1, n >>= 1) {
++divisor_count;
divisor_sum += power;
}
for (unsigned int p = 3; p * p <= n; p += 2) {
unsigned int count = 1, sum = 1;
for (power = p; n % p == 0; power *= p, n /= p) {
++count;
sum += power;
}
divisor_count *= count;
divisor_sum *= sum;
}
if (n > 1) {
divisor_count *= 2;
divisor_sum *= n + 1;
}
*pcount = divisor_count;
*psum = divisor_sum;
}
 
int main() {
unsigned int arithmetic_count = 0;
unsigned int composite_count = 0;
 
for (unsigned int n = 1; arithmetic_count <= 1000000; ++n) {
unsigned int divisor_count;
unsigned int divisor_sum;
divisor_count_and_sum(n, &divisor_count, &divisor_sum);
if (divisor_sum % divisor_count != 0)
continue;
++arithmetic_count;
if (divisor_count > 2)
++composite_count;
if (arithmetic_count <= 100) {
printf("%3u ", n);
if (arithmetic_count % 10 == 0)
printf("\n");
}
if (arithmetic_count == 1000 || arithmetic_count == 10000 ||
arithmetic_count == 100000 || arithmetic_count == 1000000) {
printf("\n%uth arithmetic number is %u\n", arithmetic_count, n);
printf("Number of composite arithmetic numbers <= %u: %u\n", n,
composite_count);
}
}
return 0;
}
Output:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

C++[edit]

#include <cstdio>
 
void divisor_count_and_sum(unsigned int n,
unsigned int& divisor_count,
unsigned int& divisor_sum)
{
divisor_count = 0;
divisor_sum = 0;
for (unsigned int i = 1;; i++)
{
unsigned int j = n / i;
if (j < i)
break;
if (i * j != n)
continue;
divisor_sum += i;
divisor_count += 1;
if (i != j)
{
divisor_sum += j;
divisor_count += 1;
}
}
}
 
int main()
{
unsigned int arithmetic_count = 0;
unsigned int composite_count = 0;
 
for (unsigned int n = 1; arithmetic_count <= 1000000; n++)
{
unsigned int divisor_count;
unsigned int divisor_sum;
divisor_count_and_sum(n, divisor_count, divisor_sum);
unsigned int mean = divisor_sum / divisor_count;
if (mean * divisor_count != divisor_sum)
continue;
arithmetic_count++;
if (divisor_count > 2)
composite_count++;
if (arithmetic_count <= 100)
{
// would prefer to use <stream> and <format> in C++20
std::printf("%3u ", n);
if (arithmetic_count % 10 == 0)
std::printf("\n");
}
if ((arithmetic_count == 1000) || (arithmetic_count == 10000) ||
(arithmetic_count == 100000) || (arithmetic_count == 1000000))
{
std::printf("\n%uth arithmetic number is %u\n", arithmetic_count, n);
std::printf("Number of composite arithmetic numbers <= %u: %u\n", n, composite_count);
}
}
return 0;
}
Output:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

real	0m4.146s
user	0m4.116s
sys	0m0.003s

Factor[edit]

Works with: Factor version 0.99 2022-04-03
USING: combinators formatting grouping io kernel lists
lists.lazy math math.functions math.primes math.primes.factors
math.statistics math.text.english prettyprint sequences
tools.memory.private ;
 
: arith? ( n -- ? ) divisors mean integer? ;
: larith ( -- list ) 1 lfrom [ arith? ] lfilter ;
: arith ( m -- seq ) larith ltake list>array ;
: composite? ( n -- ? ) dup 1 > swap prime? not and ;
: ordinal ( n -- str ) [ commas ] keep ordinal-suffix append ;
 
: info. ( n -- )
{
[ ordinal "%s arithmetic number: " printf ]
[ arith dup last commas print ]
[ commas "Number of composite arithmetic numbers <= %s: " printf ]
[ drop [ composite? ] count commas print nl ]
} cleave ;
 
 
"First 100 arithmetic numbers:" print
100 arith 10 group simple-table. nl
{ 3 4 5 6 } [ 10^ info. ] each
Output:
First 100 arithmetic numbers:
1   3   5   6   7   11  13  14  15  17
19  20  21  22  23  27  29  30  31  33
35  37  38  39  41  42  43  44  45  46
47  49  51  53  54  55  56  57  59  60
61  62  65  66  67  68  69  70  71  73
77  78  79  83  85  86  87  89  91  92
93  94  95  96  97  99  101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

1,000th arithmetic number: 1,361
Number of composite arithmetic numbers <= 1,000: 782

10,000th arithmetic number: 12,953
Number of composite arithmetic numbers <= 10,000: 8,458

100,000th arithmetic number: 125,587
Number of composite arithmetic numbers <= 100,000: 88,219

1,000,000th arithmetic number: 1,228,663
Number of composite arithmetic numbers <= 1,000,000: 905,043

FreeBASIC[edit]

Translation of: Delphi
' Rosetta Code problem: https://rosettacode.org/wiki/Arithmetic_numbers
' by Jjuanhdez, 06/2022
 
Dim As Double t0 = Timer
Dim As Integer N = 1, ArithCnt = 0, CompCnt = 0
Dim As Integer Div, DivCnt, Sum, Quot
 
Print "The first 100 arithmetic numbers are:"
Do
Div = 1 : DivCnt = 0 : Sum = 0
Do
Quot = N / Div
If Quot < Div Then Exit Do
If Quot = Div AndAlso (N Mod Div) = 0 Then 'N is a square
Sum += Quot
DivCnt += 1
Exit Do
End If
If (N Mod Div) = 0 Then
Sum += Div + Quot
DivCnt += 2
End If
Div += 1
Loop
 
If (Sum Mod DivCnt) = 0 Then 'N is arithmetic
ArithCnt += 1
If ArithCnt <= 100 Then
Print Using "####"; N;
If (ArithCnt Mod 20) = 0 Then Print
End If
If DivCnt > 2 Then CompCnt += 1
Select Case ArithCnt
Case 1e3
Print Using !"\nThe #######th arithmetic number is #####,### up to which ###,### are composite."; ArithCnt; N; CompCnt
Case 1e4, 1e5, 1e6
Print Using "The #######th arithmetic number is #####,### up to which ###,### are composite."; ArithCnt; N; CompCnt
End Select
End If
N += 1
Loop Until ArithCnt >= 1e6
Print !"\nTook"; Timer - t0; " seconds on i5 @3.20 GHz"
Sleep
Output:
The first 100 arithmetic numbers are:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

The    1000th arithmetic number is     1,361 up to which     782 are composite.
The   10000th arithmetic number is    12,953 up to which   8,458 are composite.
The  100000th arithmetic number is   125,587 up to which  88,219 are composite.
The 1000000th arithmetic number is 1,228,663 up to which 905,043 are composite.

Took 38.42344779999985 seconds on i5 @3.20 GHz

Delphi[edit]

 
{{works with| Delphi-6 or better}}
program ArithmeiticNumbers;
 
{$APPTYPE CONSOLE}
 
procedure ArithmeticNumbers;
var N, ArithCnt, CompCnt, DDiv: integer;
var DivCnt, Sum, Quot, Rem: integer;
begin
N:= 1; ArithCnt:= 0; CompCnt:= 0;
repeat
begin
DDiv:= 1; DivCnt:= 0; Sum:= 0;
while true do
begin
Quot:= N div DDiv;
Rem:=N mod DDiv;
if Quot < DDiv then break;
if (Quot = DDiv) and (Rem = 0) then //N is a square
begin
Sum:= Sum+Quot;
DivCnt:= DivCnt+1;
break;
end;
if Rem = 0 then
begin
Sum:= Sum + DDiv + Quot;
DivCnt:= DivCnt+2;
end;
DDiv:= DDiv+1;
end;
if (Sum mod DivCnt) = 0 then //N is arithmetic
begin
ArithCnt:= ArithCnt+1;
if ArithCnt <= 100 then
begin
Write(N:4);
if (ArithCnt mod 20) = 0 then WriteLn;
end;
if DivCnt > 2 then CompCnt:= CompCnt+1;
case ArithCnt of 1000, 10000, 100000, 1000000:
begin
Writeln;
Write(N, #9 {tab} );
Write(CompCnt);
end;
end;
end;
N:= N+1;
end
until ArithCnt >= 1000000;
WriteLn;
end;
 
begin
ArithmeticNumbers;
WriteLn('Hit Any Key');
ReadLn;
end.
 
Output:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

1361    782
12953   8458
125587  88219
1228663 905043
Hit Any Key

Go[edit]

Translation of: Wren
package main
 
import (
"fmt"
"math"
"rcu"
"sort"
)
 
func main() {
arithmetic := []int{1}
primes := []int{}
limit := int(1e6)
for n := 3; len(arithmetic) < limit; n++ {
divs := rcu.Divisors(n)
if len(divs) == 2 {
primes = append(primes, n)
arithmetic = append(arithmetic, n)
} else {
mean := float64(rcu.SumInts(divs)) / float64(len(divs))
if mean == math.Trunc(mean) {
arithmetic = append(arithmetic, n)
}
}
}
fmt.Println("The first 100 arithmetic numbers are:")
rcu.PrintTable(arithmetic[0:100], 10, 3, false)
 
for _, x := range []int{1e3, 1e4, 1e5, 1e6} {
last := arithmetic[x-1]
lastc := rcu.Commatize(last)
fmt.Printf("\nThe %sth arithmetic number is: %s\n", rcu.Commatize(x), lastc)
pcount := sort.SearchInts(primes, last) + 1
if !rcu.IsPrime(last) {
pcount--
}
comp := x - pcount - 1 // 1 is not composite
compc := rcu.Commatize(comp)
fmt.Printf("The count of such numbers <= %s which are composite is %s.\n", lastc, compc)
}
}
Output:
Same as Wren example.

J[edit]

factors=: {{ */@>,{(^ [:i.1+])&.>/__ q:y}}
isArith=: {{ (= <.) (+/%#) factors|y}}"0

Task examples:

   examples=: 1+I.isArith 1+i.2e6
10 10$examples
1 3 5 6 7 11 13 14 15 17
19 20 21 22 23 27 29 30 31 33
35 37 38 39 41 42 43 44 45 46
47 49 51 53 54 55 56 57 59 60
61 62 65 66 67 68 69 70 71 73
77 78 79 83 85 86 87 89 91 92
93 94 95 96 97 99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149
(1e3-1){examples NB. 0 is first
1361
(1e4-1){examples
12953
+/0=1 p: (1e3 {. examples) -. 1
782
+/0=1 p: (1e4 {. examples) -. 1
8458
+/0=1 p: (1e5 {. examples) -. 1
88219
+/0=1 p: (1e6 {. examples) -. 1
905043

Julia[edit]

using Primes
 
function isarithmetic(n)
f = [one(n)]
for (p,e) in factor(n)
f = reduce(vcat, [f*p^j for j in 1:e], init=f)
end
return rem(sum(f), length(f)) == 0
end
 
function arithmetic(n)
i, arr = 1, Int[]
while length(arr) < n
isarithmetic(i) && push!(arr, i)
i += 1
end
return arr
end
 
a1M = arithmetic(1_000_000)
composites = [!isprime(i) for i in a1M]
 
println("The first 100 arithmetic numbers are:")
foreach(p -> print(lpad(p[2], 5), p[1] % 20 == 0 ? "\n" : ""), enumerate(a1M[1:100]))
 
println("\n X Xth in Series Composite")
for n in [1000, 10_000, 100_000, 1_000_000]
println(lpad(n, 9), lpad(a1M[n], 12), lpad(sum(composites[2:n]), 14))
end
 
Output:
The first 100 arithmetic numbers are:
    1    3    5    6    7   11   13   14   15   17   19   20   21   22   23   27   29   30   31   33
   35   37   38   39   41   42   43   44   45   46   47   49   51   53   54   55   56   57   59   60
   61   62   65   66   67   68   69   70   71   73   77   78   79   83   85   86   87   89   91   92
   93   94   95   96   97   99  101  102  103  105  107  109  110  111  113  114  115  116  118  119
  123  125  126  127  129  131  132  133  134  135  137  138  139  140  141  142  143  145  147  149

        X    Xth in Series  Composite
     1000        1361           782
    10000       12953          8458
   100000      125587         88219
  1000000     1228663        905043

Lua[edit]

Translated from Python

local function factors (n)
local f, i = {1, n}, 2
while true do
local j = n//i -- floor division by Lua 5.3
if j < i then
break
elseif j == i and i * j == n then
table.insert (f, i)
break
elseif i * j == n then
table.insert (f, i)
table.insert (f, j)
end
i = i + 1
end
return f
end
 
local function sum (f)
local s = 0
for i, value in ipairs (f) do
s = s + value
end
return s
end
 
local arithmetic_count = 1
local composite_count = 0
local hundr = {1}
 
for n = 2, 1228663 do
local f = factors (n)
local s = sum (f)
local l = #f
if (s/l)%1 == 0 then
arithmetic_count = arithmetic_count + 1
if l > 2 then
composite_count = composite_count + 1
end
if arithmetic_count <= 100 then
table.insert (hundr, n)
end
if arithmetic_count == 100 then
for i = 0, 9 do
print (table.concat(hundr, ', ', 10*i+1, 10*i+10))
end
elseif arithmetic_count == 1000
or arithmetic_count == 10000
or arithmetic_count == 100000 then
print (arithmetic_count..'th arithmetic number is '..(n))
print ('Number of composite arithmetic numbers <= '..(n)..': '..composite_count)
elseif arithmetic_count == 1000000 then
print (arithmetic_count..'th arithmetic number is '..(n))
print ('Number of composite arithmetic numbers <= '..(n)..': '..composite_count)
return
end
end
end
Output:
1,	3,	5,	6,	7,	11,	13,	14,	15,	17
19,	20,	21,	22,	23,	27,	29,	30,	31,	33
35,	37,	38,	39,	41,	42,	43,	44,	45,	46
47,	49,	51,	53,	54,	55,	56,	57,	59,	60
61,	62,	65,	66,	67,	68,	69,	70,	71,	73
77,	78,	79,	83,	85,	86,	87,	89,	91,	92
93,	94,	95,	96,	97,	99,	101,	102,	103,	105
107,	109,	110,	111,	113,	114,	115,	116,	118,	119
123,	125,	126,	127,	129,	131,	132,	133,	134,	135
137,	138,	139,	140,	141,	142,	143,	145,	147,	149
1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782
10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458
100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219
1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

(Done in 56.17 seconds)

Mathematica/Wolfram Language[edit]

ClearAll[ArithmeticNumberQ]
ArithmeticNumberQ[n_Integer] := IntegerQ[Mean[Divisors[n]]]
ArithmeticNumberQ[30]
 
an = {};
PrintTemporary[Dynamic[{i, Length[an]}]];
Do[
If[ArithmeticNumberQ[i],
AppendTo[an, i];
If[Length[an] >= 100, Break[]]
]
,
{i, 1, \[Infinity]}
];
an
 
an = {};
Do[
If[ArithmeticNumberQ[i],
AppendTo[an, i];
If[Length[an] >= 1000, Break[]]
]
,
{i, 1, \[Infinity]}
];
a1 = {Length[an], Last[an], Count[CompositeQ[an], True]};
 
an = {};
Do[
If[ArithmeticNumberQ[i],
AppendTo[an, i];
If[Length[an] >= 10000, Break[]]
]
,
{i, 1, \[Infinity]}
];
a2 = {Length[an], Last[an], Count[CompositeQ[an], True]};
 
an = {};
Do[
If[ArithmeticNumberQ[i],
AppendTo[an, i];
If[Length[an] >= 100000, Break[]]
]
,
{i, 1, \[Infinity]}
];
a3 = {Length[an], Last[an], Count[CompositeQ[an], True]};
 
TableForm[{a1, a2, a3}, TableHeadings -> {None, {"X", "Xth in series", "composite"}}]
Output:
{1, 3, 5, 6, 7, 11, 13, 14, 15, 17, 19, 20, 21, 22, 23, 27, 29, 30, 31, 33, 35, 37, 38, 39, 41, 42, 43, 44, 45, 46, 47, 49, 51, 53, 54, 55, 56, 57, 59, 60, 61, 62, 65, 66, 67, 68, 69, 70, 71, 73, 77, 78, 79, 83, 85, 86, 87, 89, 91, 92, 93, 94, 95, 96, 97, 99, 101, 102, 103, 105, 107, 109, 110, 111, 113, 114, 115, 116, 118, 119, 123, 125, 126, 127, 129, 131, 132, 133, 134, 135, 137, 138, 139, 140, 141, 142, 143, 145, 147, 149}

X	Xth in series	composite
1000	1361	782
10000	12953	8458
100000	125587	88219

Pascal[edit]

Works with: GNU Pascal
and Free Pascal too.
 
program ArithmeiticNumbers;
 
procedure ArithmeticNumbers;
var N, ArithCnt, CompCnt, DDiv: longint;
var DivCnt, Sum, Quot, Rem: longint;
begin
N:= 1; ArithCnt:= 0; CompCnt:= 0;
repeat
begin
DDiv:= 1; DivCnt:= 0; Sum:= 0;
while true do
begin
Quot:= N div DDiv;
Rem:=N mod DDiv;
if Quot < DDiv then break;
if (Quot = DDiv) and (Rem = 0) then //N is a square
begin
Sum:= Sum+Quot;
DivCnt:= DivCnt+1;
break;
end;
if Rem = 0 then
begin
Sum:= Sum + DDiv + Quot;
DivCnt:= DivCnt+2;
end;
DDiv:= DDiv+1;
end;
if (Sum mod DivCnt) = 0 then //N is arithmetic
begin
ArithCnt:= ArithCnt+1;
if ArithCnt <= 100 then
begin
Write(N:4);
if (ArithCnt mod 20) = 0 then WriteLn;
end;
if DivCnt > 2 then CompCnt:= CompCnt+1;
case ArithCnt of 1000, 10000, 100000, 1000000:
begin
Writeln;
Write(N, #9 {tab} );
Write(CompCnt);
end;
end;
end;
N:= N+1;
end
until ArithCnt >= 1000000;
WriteLn;
end;
 
begin
ArithmeticNumbers;
WriteLn('Hit Any Key');
{$IFDEF WINDOWS}ReadLn;{$ENDIF}
end.
 
@TIO.RUN:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

1361    782
12953   8458
125587  88219
1228663 905043
Hit Any Key

Real time: 19.847 s CPU share: 99.36 %

Free Pascal[edit]

using prime decomposition is lengthy, but much faster.
Change last lines of Factors_of_an_integer#using_Prime_decomposition even more.

 
program ArithmeticNumbers;
{$OPTIMIZATION ON,ALL}
type
tPrimeFact = packed record
pfSumOfDivs,
pfRemain : Uint64;
pfDivCnt : Uint32;
pfMaxIdx : Uint32;
pfpotPrimIdx : array[0..9] of word;
pfpotMax : array[0..11] of byte;//11 instead of 9 for alignment
end;
var
SmallPrimes : array[0..6541] of word;
 
procedure InitSmallPrimes;
var
testPrime,j,p,idx:Uint32;
begin
SmallPrimes[0] := 2;
SmallPrimes[1] := 3;
idx := 1;
testPrime := 5;
repeat
For j := 1 to idx do
begin
p := SmallPrimes[j];
if p*p>testPrime then
BREAK;
if testPrime mod p = 0 then
Begin
p := 0;
BREAK;
end;
end;
if p <> 0 then
begin
inc(idx);
SmallPrimes[idx]:= testPrime;
end;
inc(testPrime,2);
until testPrime >= 65535;
end;
 
procedure smplPrimeDecomp(var PrimeFact:tPrimeFact;n:Uint32);
var
pr,i,pot,fac,q :NativeUInt;
Begin
with PrimeFact do
Begin
pfDivCnt := 1;
pfSumOfDivs := 1;
pfRemain := n;
pfMaxIdx := 0;
pfpotPrimIdx[0] := 1;
pfpotMax[0] := 0;
 
i := 0;
while i < High(SmallPrimes) do
begin
pr := SmallPrimes[i];
q := n DIV pr;
//if n < pr*pr
if pr > q then
BREAK;
if n = pr*q then
Begin
pfpotPrimIdx[pfMaxIdx] := i;
pot := 0;
fac := pr;
repeat
n := q;
q := n div pr;
pot+=1;
fac *= pr;
until n <> pr*q;
pfpotMax[pfMaxIdx] := pot;
pfDivCnt *= pot+1;
pfSumOfDivs *= (fac-1)DIV(pr-1);
inc(pfMaxIdx);
end;
inc(i);
end;
pfRemain := n;
if n > 1 then
Begin
pfDivCnt *= 2;
pfSumOfDivs *= n+1
end;
end;
end;
 
function IsArithmetic(const PrimeFact:tPrimeFact):boolean;inline;
begin
with PrimeFact do
IsArithmetic := pfSumOfDivs mod pfDivCnt = 0;
end;
 
var
pF :TPrimeFact;
i,cnt,primeCnt,lmt : Uint32;
begin
InitSmallPrimes;
 
writeln('First 100 arithemetic numbers');
cnt := 0;
i := 1;
repeat
smplPrimeDecomp(pF,i);
if IsArithmetic(pF) then
begin
write(i:4);
inc(cnt);
if cnt MOD 20 =0 then
writeln;
end;
inc(i);
until cnt = 100;
writeln;
 
writeln(' Arithemetic numbers');
writeln(' Index number composite');
cnt := 0;
primeCnt := 0;
lmt := 10;
i := 1;
repeat
smplPrimeDecomp(pF,i);
if IsArithmetic(pF) then
begin
inc(cnt);
if pF.pfRemain = i then
inc(primeCnt);
end;
if cnt = lmt then
begin
writeln(lmt:8,i:9,lmt-primeCnt:10);
lmt := lmt*10;
end;
inc(i);
until lmt>1000000;
{$IFdef WINDOWS}
WriteLn('Hit <ENTER>');ReadLn;
{$ENDIF}
end.
@TIO.RUN:
First 100 arithemetic numbers
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

   Arithemetic numbers
   Index   number composite
      10       17         3
     100      149        65
    1000     1361       782
   10000    12953      8458
  100000   125587     88219
 1000000  1228663    905043
Real time: 0.678 s CPU share: 99.40 %

Factors_of_an_integer#using_Prime_decomposition added function and change main routine.

 
const
//make size of sieve using 11 MB of 16MB Level III cache
SizePrDeFe = 192*1024;
.....
function IsArithmetic(const PrimeFact:tPrimeFac):boolean;inline;
begin
with PrimeFact do
IsArithmetic := pfSumOfDivs mod pfDivCnt = 0;
end;
 
var
pPrimeDecomp :tpPrimeFac;
T0:Int64;
n,lmt,cnt,primeCnt : NativeUInt;
Begin
InitSmallPrimes;
 
T0 := GetTickCount64;
cnt := 1;
primeCnt := 1;
lmt := 10;
n := 2;
Init_Sieve(n);
repeat
pPrimeDecomp:= GetNextPrimeDecomp;
if IsArithmetic(pPrimeDecomp^) then
begin
inc(cnt);
if pPrimeDecomp^.pfDivCnt = 2 then
inc(primeCnt);
end;
if cnt = lmt then
begin
writeln(lmt:14,n:14,lmt-primeCnt:14);
lmt := lmt*10;
end;
inc(n);
until lmt>1000*1000*1000;
T0 := GetTickCount64-T0;
writeln;
end.
@Home AMD 5600G:
            10            17             3
           100           149            65
          1000          1361           782
         10000         12953          8458
        100000        125587         88219
       1000000       1228663        905043
      10000000      12088243       9206547
     100000000     119360473      93192812
    1000000000    1181451167     940432725
20.78user 0.00 system 0:20.79 elapsed 99%CPU 

Perl[edit]

Translation of: Raku
Library: ntheory
use strict;
use warnings;
use feature 'say';
 
use List::Util <max sum>;
use ntheory <is_prime divisors>;
use Lingua::EN::Numbers qw(num2en num2en_ordinal);
 
sub comma { reverse ((reverse shift) =~ s/(.{3})/$1,/gr) =~ s/^,//r }
sub table { my $t = 10 * (my $c = 1 + length max @_); ( sprintf( ('%'.$c.'d')x@_, @_) ) =~ s/.{1,$t}\K/\n/gr }
 
my @A = 0;
for my $n (1..2E6) {
my @div = divisors $n;
push @A, $n if 0 == sum(@div) % @div;
}
 
say "The first @{[num2en 100]} arithmetic numbers:";
say table @A[1..100];
 
for my $x (1E3, 1E4, 1E5, 1E6) {
say "\nThe @{[num2en_ordinal $x]}: " . comma($A[$x]) .
"\nComposite arithmetic numbers ≤ @{[comma $A[$x]]}: " . comma -1 + grep { not is_prime($_) } @A[1..$x];
}
Output:
The first one hundred arithmetic numbers:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

The one thousandth: 1,361
Composite arithmetic numbers ≤ 1,361: 782

The ten thousandth: 12,953
Composite arithmetic numbers ≤ 12,953: 8,458

The one hundred thousandth: 125,587
Composite arithmetic numbers ≤ 125,587: 88,219

The one millionth: 1,228,663
Composite arithmetic numbers ≤ 1,228,663: 905,043

Phix[edit]

with javascript_semantics
sequence arithmetic = {1}
integer composite = 0

function get_arithmetic(integer nth)
    integer n = arithmetic[$]+1
    while length(arithmetic)<nth do
        sequence divs = factors(n,1)
        if remainder(sum(divs),length(divs))=0 then
            composite += length(divs)>2
            arithmetic &= n
        end if
        n += 1
    end while
    return arithmetic[nth]
end function

{} = get_arithmetic(100)
printf(1,"The first 100 arithmetic numbers are:\n%s\n",
         {join_by(arithmetic,1,10," ",fmt:="%3d")})
constant fmt = "The %,dth arithmetic number is %,d up to which %,d are composite.\n"
for n in {1e3,1e4,1e5,1e6} do
    integer nth = get_arithmetic(n)
    printf(1,fmt,{n,nth,composite})
end for

Aside: You could inline the get_arithmetic() call inside the loop, however the formal language specification does not actually guarantee that the value of composite won't be output as it was before the function call is made. You certainly would not expect get_arithmetic(n,composite) to do anything other than pass the prior value into the function, so for your own sanity you should in general avoid using the visually rather similar get_arithmetic(n),composite, and suchlike, in order to collect/output the completely different post-invocation value. Or and perhaps even better, just simply avoid writing functions with side-effects, and of course were get_arithmetic() a procedure [with side-effects] rather than a function, you would not be tempted to invoke it inline or use any other form of doubtful execution order anyway.

Output:
The first 100 arithmetic numbers are:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

The 1,000th arithmetic number is 1,361 up to which 782 are composite.
The 10,000th arithmetic number is 12,953 up to which 8,458 are composite.
The 100,000th arithmetic number is 125,587 up to which 88,219 are composite.
The 1,000,000th arithmetic number is 1,228,663 up to which 905,043 are composite.

PL/M[edit]

Translation of: ALGOL 68

The original PL/M compiler only supports unsigned integers up to 65535, so this sample doesn't consider arithmetic numbers above the 10 000th.
As machines running CP/M probably didn't have large memories, the tables of divisor counts and sums are restricted to 4000 elements each and the next 4000 values are calculated when the previous 4000 have been examined.

Works with: 8080 PL/M Compiler
... under CP/M (or an emulator)
100H: /* FIND SOME ARITHMETIC NUMBERS: NUMBERS WHOSE AVERAGE DIVISOR IS AN   */
/* IS AN INTEGER - I.E. DIVISOR SUM MOD DIVISOR COUNT = 0 */
 
/* CP/M BDOS SYSTEM CALL, IGNORE THE RETURN VALUE */
BDOS: PROCEDURE( FN, ARG ); DECLARE FN BYTE, ARG ADDRESS; GOTO 5; END;
PR$CHAR: PROCEDURE( C ); DECLARE C BYTE; CALL BDOS( 2, C ); END;
PR$STRING: PROCEDURE( S ); DECLARE S ADDRESS; CALL BDOS( 9, S ); END;
PR$NL: PROCEDURE; CALL PR$STRING( .( 0AH, 0DH, '$' ) ); END;
PR$NUMBER: PROCEDURE( N ); /* PRINTS A NUMBER IN THE MINIMUN FIELD WIDTH */
DECLARE N ADDRESS;
DECLARE V ADDRESS, N$STR ( 6 )BYTE, W BYTE;
V = N;
W = LAST( N$STR );
N$STR( W ) = '$';
N$STR( W := W - 1 ) = '0' + ( V MOD 10 );
DO WHILE( ( V := V / 10 ) > 0 );
N$STR( W := W - 1 ) = '0' + ( V MOD 10 );
END;
CALL PR$STRING( .N$STR( W ) );
END PR$NUMBER;
PR$NUMBER4: PROCEDURE( N ); /* PRINT A NUMBER IN AT LEAST 4 CHARACTERS */
DECLARE N ADDRESS;
IF N < 10 THEN CALL PR$CHAR( ' ' );
IF N < 100 THEN CALL PR$CHAR( ' ' );
IF N < 1000 THEN CALL PR$CHAR( ' ' );
CALL PR$NUMBER( N );
END PR$NUMBER4;
 
DECLARE ( D$COUNT, D$SUM ) ( 4001 )ADDRESS;
DECLARE ( I, J, D$POS, I$POS, J$POS ) ADDRESS;
/* SHOW THE FIRST 100TH ARITHMETIC NUMBER AND THE 1000TH AND THE 10000TH */
/* ALSO SHOW HOW MANY ARE COMPOSITE */
DECLARE ( DIVISOR$START, DIVISOR$END ) ADDRESS;
DECLARE ( A$COUNT, C$COUNT ) ADDRESS;
A$COUNT, C$COUNT, DIVISOR$START, DIVISOR$END = 0;
I, D$POS = 1;
DO WHILE( I <= 60000 AND A$COUNT < 10000 );
IF I > DIVISOR$END THEN DO;
/* PAST THE END OF THE DIGIT SUMS AND COUNTS - GET THE NEXT BATCH */
DIVISOR$START = DIVISOR$END + 1;
DIVISOR$END = DIVISOR$START + ( LAST( D$COUNT ) ) - 1;
DO I$POS = 1 TO LAST( D$COUNT );
D$COUNT( I$POS ), D$SUM( I$POS ) = 1;
END;
DO I = 2 TO DIVISOR$END;
DO J = I TO DIVISOR$END BY I;
IF J >= DIVISOR$START AND J <= DIVISOR$END THEN DO;
J$POS = J - ( DIVISOR$START - 1 );
D$COUNT( J$POS ) = D$COUNT( J$POS ) + 1;
D$SUM( J$POS ) = D$SUM( J$POS ) + I;
END;
END;
END;
I = DIVISOR$START;
D$POS = 1;
END;
IF D$SUM( D$POS ) MOD D$COUNT( D$POS ) = 0 THEN DO; /* I IS ARITHMETIC */
IF D$COUNT( D$POS ) > 2 THEN DO; /* I IS COMPOSITE */
C$COUNT = C$COUNT + 1;
END;
A$COUNT = A$COUNT + 1;
IF A$COUNT <= 100 THEN DO;
CALL PR$NUMBER4( I );
IF A$COUNT MOD 10 = 0 THEN CALL PR$NL;
END;
ELSE IF A$COUNT = 1000 OR A$COUNT = 10000 THEN DO;
CALL PR$NL;
CALL PR$STRING( .'THE $' );
CALL PR$NUMBER( A$COUNT );
CALL PR$STRING( .'TH ARITHMETIC NUMBER IS: $' );
CALL PR$NUMBER( I );
CALL PR$NL;
CALL PR$STRING( .' THERE ARE $' );
CALL PR$NUMBER( C$COUNT );
CALL PR$STRING( .' COMPOSITE NUMBERS UP TO $' );
CALL PR$NUMBER( I );
CALL PR$NL;
END;
END;
I = I + 1;
D$POS = D$POS + 1;
END;
 
EOF
Output:
   1   3   5   6   7  11  13  14  15  17
  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46
  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73
  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105
 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135
 137 138 139 140 141 142 143 145 147 149

THE 1000TH ARITHMETIC NUMBER IS: 1361
    THERE ARE 782 COMPOSITE NUMBERS UP TO 1361

THE 10000TH ARITHMETIC NUMBER IS: 12953
    THERE ARE 8458 COMPOSITE NUMBERS UP TO 12953

Python[edit]

def factors(n: int):
f = set([1, n])
i = 2
while True:
j = n // i
if j < i:
break
if i * j == n:
f.add(i)
f.add(j)
i += 1
return f
 
arithmetic_count = 0
composite_count = 0
n = 1
while arithmetic_count <= 1000000:
f = factors(n)
if (sum(f)/len(f)).is_integer():
arithmetic_count += 1
if len(f) > 2:
composite_count += 1
if arithmetic_count <= 100:
print(f'{n:3d} ', end='')
if arithmetic_count % 10 == 0:
print()
if arithmetic_count in (1000, 10000, 100000, 1000000):
print(f'\n{arithmetic_count}th arithmetic number is {n}')
print(f'Number of composite arithmetic numbers <= {n}: {composite_count}')
n += 1

Output:

  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

real	1m14.220s
user	1m13.952s
sys	0m0.005s

Raku[edit]

use Prime::Factor;
use Lingua::EN::Numbers;
 
my @arithmetic = lazy (1..).hyper.grep: { my @div = .&divisors; @div.sum %% @div }
 
say "The first { .Int.&cardinal } arithmetic numbers:\n", @arithmetic[^$_].batch(10)».fmt("%{.chars}d").join: "\n" given 1e2;
 
for 1e3, 1e4, 1e5, 1e6 {
say "\nThe { .Int.&ordinal }: { comma @arithmetic[$_-1] }";
say "Composite arithmetic numbers ≤ { comma @arithmetic[$_-1] }: { comma [email protected][^$_].grep({!.is-prime}) - 1 }";
}
The first one hundred arithmetic numbers:
  1   3   5   6   7  11  13  14  15  17
 19  20  21  22  23  27  29  30  31  33
 35  37  38  39  41  42  43  44  45  46
 47  49  51  53  54  55  56  57  59  60
 61  62  65  66  67  68  69  70  71  73
 77  78  79  83  85  86  87  89  91  92
 93  94  95  96  97  99 101 102 103 105
107 109 110 111 113 114 115 116 118 119
123 125 126 127 129 131 132 133 134 135
137 138 139 140 141 142 143 145 147 149

The one thousandth: 1,361
Composite arithmetic numbers ≤ 1,361: 782

The ten thousandth: 12,953
Composite arithmetic numbers ≤ 12,953: 8,458

The one hundred thousandth: 125,587
Composite arithmetic numbers ≤ 125,587: 88,219

The one millionth: 1,228,663
Composite arithmetic numbers ≤ 1,228,663: 905,043

Rust[edit]

Translation of: C
fn divisor_count_and_sum(mut n: u32) -> (u32, u32) {
let mut divisor_count = 1;
let mut divisor_sum = 1;
let mut power = 2;
while (n & 1) == 0 {
divisor_count += 1;
divisor_sum += power;
power <<= 1;
n >>= 1;
}
let mut p = 3;
while p * p <= n {
let mut count = 1;
let mut sum = 1;
power = p;
while n % p == 0 {
count += 1;
sum += power;
power *= p;
n /= p;
}
divisor_count *= count;
divisor_sum *= sum;
p += 2;
}
if n > 1 {
divisor_count *= 2;
divisor_sum *= n + 1;
}
(divisor_count, divisor_sum)
}
 
fn main() {
let mut arithmetic_count = 0;
let mut composite_count = 0;
let mut n = 1;
while arithmetic_count <= 1000000 {
let (divisor_count, divisor_sum) = divisor_count_and_sum(n);
if divisor_sum % divisor_count != 0 {
n += 1;
continue;
}
arithmetic_count += 1;
if divisor_count > 2 {
composite_count += 1;
}
if arithmetic_count <= 100 {
print!("{:3} ", n);
if arithmetic_count % 10 == 0 {
println!();
}
}
if arithmetic_count == 1000
|| arithmetic_count == 10000
|| arithmetic_count == 100000
|| arithmetic_count == 1000000
{
println!("\n{}th arithmetic number is {}", arithmetic_count, n);
println!(
"Number of composite arithmetic numbers <= {}: {}",
n, composite_count
);
}
n += 1;
}
}
Output:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

1000th arithmetic number is 1361
Number of composite arithmetic numbers <= 1361: 782

10000th arithmetic number is 12953
Number of composite arithmetic numbers <= 12953: 8458

100000th arithmetic number is 125587
Number of composite arithmetic numbers <= 125587: 88219

1000000th arithmetic number is 1228663
Number of composite arithmetic numbers <= 1228663: 905043

Wren[edit]

Library: Wren-math
Library: Wren-fmt
Library: Wren-sort
import "./math" for Int, Nums
import "./fmt" for Fmt
import "./sort" for Find
 
var arithmetic = [1]
var primes = []
var limit = 1e6
var n = 3
while (arithmetic.count < limit) {
var divs = Int.divisors(n)
if (divs.count == 2) {
primes.add(n)
arithmetic.add(n)
} else {
var mean = Nums.mean(divs)
if (mean.isInteger) arithmetic.add(n)
}
n = n + 1
}
System.print("The first 100 arithmetic numbers are:")
Fmt.tprint("$3d", arithmetic[0..99], 10)
 
for (x in [1e3, 1e4, 1e5, 1e6]) {
var last = arithmetic[x-1]
Fmt.print("\nThe $,dth arithmetic number is: $,d", x, last)
var pcount = Find.nearest(primes, last) + 1
if (!Int.isPrime(last)) pcount = pcount - 1
var comp = x - pcount - 1 // 1 is not composite
Fmt.print("The count of such numbers <= $,d which are composite is $,d.", last, comp)
}
Output:
The first 100 arithmetic numbers are:
  1   3   5   6   7  11  13  14  15  17 
 19  20  21  22  23  27  29  30  31  33 
 35  37  38  39  41  42  43  44  45  46 
 47  49  51  53  54  55  56  57  59  60 
 61  62  65  66  67  68  69  70  71  73 
 77  78  79  83  85  86  87  89  91  92 
 93  94  95  96  97  99 101 102 103 105 
107 109 110 111 113 114 115 116 118 119 
123 125 126 127 129 131 132 133 134 135 
137 138 139 140 141 142 143 145 147 149 

The 1,000th arithmetic number is: 1,361
The count of such numbers <= 1,361 which are composite is 782.

The 10,000th arithmetic number is: 12,953
The count of such numbers <= 12,953 which are composite is 8,458.

The 100,000th arithmetic number is: 125,587
The count of such numbers <= 125,587 which are composite is 88,219.

The 1,000,000th arithmetic number is: 1,228,663
The count of such numbers <= 1,228,663 which are composite is 905,043.

XPL0[edit]

int N, ArithCnt, CompCnt, Div, DivCnt, Sum, Quot;
[Format(4, 0);
N:= 1; ArithCnt:= 0; CompCnt:= 0;
repeat Div:= 1; DivCnt:= 0; Sum:= 0;
loop [Quot:= N/Div;
if Quot < Div then quit;
if Quot = Div and rem(0) = 0 then \N is a square
[Sum:= Sum+Quot; DivCnt:= DivCnt+1; quit];
if rem(0) = 0 then
[Sum:= Sum + Div + Quot;
DivCnt:= DivCnt+2;
];
Div:= Div+1;
];
if rem(Sum/DivCnt) = 0 then \N is arithmetic
[ArithCnt:= ArithCnt+1;
if ArithCnt <= 100 then
[RlOut(0, float(N));
if rem(ArithCnt/20) = 0 then CrLf(0);
];
if DivCnt > 2 then CompCnt:= CompCnt+1;
case ArithCnt of 1000, 10_000, 100_000, 1_000_000:
[CrLf(0);
IntOut(0, N); ChOut(0, 9\tab\);
IntOut(0, CompCnt);
]
other;
];
N:= N+1;
until ArithCnt >= 1_000_000;
]
Output:
   1   3   5   6   7  11  13  14  15  17  19  20  21  22  23  27  29  30  31  33
  35  37  38  39  41  42  43  44  45  46  47  49  51  53  54  55  56  57  59  60
  61  62  65  66  67  68  69  70  71  73  77  78  79  83  85  86  87  89  91  92
  93  94  95  96  97  99 101 102 103 105 107 109 110 111 113 114 115 116 118 119
 123 125 126 127 129 131 132 133 134 135 137 138 139 140 141 142 143 145 147 149

1361    782
12953   8458
125587  88219
1228663 905043