A weird number is a positive integer n such that the sum of the proper divisors of n is greater than n, but no subset of its proper divisors add up to n. What is the smallest weird number?
DefDbl A-Z
Dim fct(20, 1), good, f, fcnt, fcntd, n, tot, prod, maxf, fctrs(100), fctrcnt, ftot
Private Sub Form_Load()
Text1.Text = ""
crlf$ = Chr(13) + Chr(10)
For n = 2 To 25000
DoEvents
f = factor(n)
fcnt = 0
For i = 1 To f: fcnt = fcnt + fct(i, 1): Next
fcntx = 1
For i = 1 To f: fcntx = fcntx * fct(i, 1): Next
good = 1: tot = 0: fcntd = 0: prod = 1: fctrcnt = 0
sumIt 1
If tot > n And good = 1 Then
ftot = 0
addf 1
If good Then
Form1.Visible = True
Text1.Text = Text1.Text & Str(n) & " "
For ix = 1 To fctrcnt
Text1.Text = Text1.Text & Str(fctrs(ix))
Next
Text1.Text = Text1.Text & crlf$
DoEvents
End If
End If
Next n
End Sub
Sub addf(wh)
For countit = 0 To 1
If good = 0 Then Exit Sub
ftot = ftot + fctrs(wh) * countit
If wh = fctrcnt Then
If ftot = n Then good = 0: Exit Sub
Else
addf wh + 1
End If
ftot = ftot - fctrs(wh) * countit
Next
End Sub
Function sumIt(wh)
For inc = 0 To fct(wh, 1)
For mct = 1 To inc: prod = prod * fct(wh, 0): Next
fcntd = fcntd + inc
If wh < f Then
sumIt wh + 1
Else
If fcntd < fcnt Then
tot = tot + prod:
fctrcnt = fctrcnt + 1: fctrs(fctrcnt) = prod:
End If
End If
If inc <> 0 Then
For mct = 1 To inc: prod = prod / fct(wh, 0): Next
End If
fcntd = fcntd - inc
Next
End Function
Function factor(num)
diffCt = 0: good = 1
nm1 = Abs(num): If nm1 > 0 Then limit = Sqr(nm1) Else limit = 0
If limit <> Int(limit) Then limit = Int(limit + 1)
dv = 2: GoSub DivideIt
dv = 3: GoSub DivideIt
dv = 5: GoSub DivideIt
dv = 7
Do Until dv > limit
GoSub DivideIt: dv = dv + 4 '11
GoSub DivideIt: dv = dv + 2 '13
GoSub DivideIt: dv = dv + 4 '17
GoSub DivideIt: dv = dv + 2 '19
GoSub DivideIt: dv = dv + 4 '23
GoSub DivideIt: dv = dv + 6 '29
GoSub DivideIt: dv = dv + 2 '31
GoSub DivideIt: dv = dv + 6 '37
If INKEY$ = Chr$(27) Then s$ = Chr$(27): Exit Function
Loop
If nm1 > 1 Then diffCt = diffCt + 1: fct(diffCt, 0) = nm1: fct(diffCt, 1) = 1
factor = diffCt
Exit Function
DivideIt:
cnt = 0
Do
q = Int(nm1 / dv)
If q * dv = nm1 And nm1 > 0 Then
nm1 = q: cnt = cnt + 1: If nm1 > 0 Then limit = Sqr(nm1) Else limit = 0
If limit <> Int(limit) Then limit = Int(limit + 1)
Else
Exit Do
End If
Loop
If cnt > 0 Then
diffCt = diffCt + 1
fct(diffCt, 0) = dv
fct(diffCt, 1) = cnt
End If
Return
End Function
finds
number its divisors less than the number itself
70 1 7 5 35 2 14 10
836 1 19 11 209 2 38 22 418 4 76 44
4030 1 31 13 403 5 155 65 2015 2 62 26 806 10 310 130
5830 1 53 11 583 5 265 55 2915 2 106 22 1166 10 530 110
7192 1 31 29 899 2 62 58 1798 4 124 116 3596 8 248 232
7912 1 43 23 989 2 86 46 1978 4 172 92 3956 8 344 184
9272 1 61 19 1159 2 122 38 2318 4 244 76 4636 8 488 152
10430 1 149 7 1043 5 745 35 5215 2 298 14 2086 10 1490 70
10570 1 151 7 1057 5 755 35 5285 2 302 14 2114 10 1510 70
10792 1 71 19 1349 2 142 38 2698 4 284 76 5396 8 568 152
10990 1 157 7 1099 5 785 35 5495 2 314 14 2198 10 1570 70
11410 1 163 7 1141 5 815 35 5705 2 326 14 2282 10 1630 70
11690 1 167 7 1169 5 835 35 5845 2 334 14 2338 10 1670 70
12110 1 173 7 1211 5 865 35 6055 2 346 14 2422 10 1730 70
12530 1 179 7 1253 5 895 35 6265 2 358 14 2506 10 1790 70
12670 1 181 7 1267 5 905 35 6335 2 362 14 2534 10 1810 70
13370 1 191 7 1337 5 955 35 6685 2 382 14 2674 10 1910 70
13510 1 193 7 1351 5 965 35 6755 2 386 14 2702 10 1930 70
13790 1 197 7 1379 5 985 35 6895 2 394 14 2758 10 1970 70
13930 1 199 7 1393 5 995 35 6965 2 398 14 2786 10 1990 70
14770 1 211 7 1477 5 1055 35 7385 2 422 14 2954 10 2110 70
15610 1 223 7 1561 5 1115 35 7805 2 446 14 3122 10 2230 70
15890 1 227 7 1589 5 1135 35 7945 2 454 14 3178 10 2270 70
16030 1 229 7 1603 5 1145 35 8015 2 458 14 3206 10 2290 70
16310 1 233 7 1631 5 1165 35 8155 2 466 14 3262 10 2330 70
16730 1 239 7 1673 5 1195 35 8365 2 478 14 3346 10 2390 70
16870 1 241 7 1687 5 1205 35 8435 2 482 14 3374 10 2410 70
17272 1 127 17 2159 2 254 34 4318 4 508 68 8636 8 1016 136
17570 1 251 7 1757 5 1255 35 8785 2 502 14 3514 10 2510 70
17990 1 257 7 1799 5 1285 35 8995 2 514 14 3598 10 2570 70
18410 1 263 7 1841 5 1315 35 9205 2 526 14 3682 10 2630 70
18830 1 269 7 1883 5 1345 35 9415 2 538 14 3766 10 2690 70
18970 1 271 7 1897 5 1355 35 9485 2 542 14 3794 10 2710 70
19390 1 277 7 1939 5 1385 35 9695 2 554 14 3878 10 2770 70
19670 1 281 7 1967 5 1405 35 9835 2 562 14 3934 10 2810 70
19810 1 283 7 1981 5 1415 35 9905 2 566 14 3962 10 2830 70
20510 1 293 7 2051 5 1465 35 10255 2 586 14 4102 10 2930 70
21490 1 307 7 2149 5 1535 35 10745 2 614 14 4298 10 3070 70
21770 1 311 7 2177 5 1555 35 10885 2 622 14 4354 10 3110 70
21910 1 313 7 2191 5 1565 35 10955 2 626 14 4382 10 3130 70
22190 1 317 7 2219 5 1585 35 11095 2 634 14 4438 10 3170 70
23170 1 331 7 2317 5 1655 35 11585 2 662 14 4634 10 3310 70
23590 1 337 7 2359 5 1685 35 11795 2 674 14 4718 10 3370 70
24290 1 347 7 2429 5 1735 35 12145 2 694 14 4858 10 3470 70
24430 1 349 7 2443 5 1745 35 12215 2 698 14 4886 10 3490 70
24710 1 353 7 2471 5 1765 35 12355 2 706 14 4942 10 3530 70
|
|
Posted by Charlie
on 2014-05-02 16:50:42 |
computer solution
