All about flooble | fun stuff | Get a free chatterbox | Free JavaScript | Avatars    
perplexus dot info

Home > Numbers
Weird numbers (Posted on 2014-05-02) Difficulty: 2 of 5
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?

See The Solution Submitted by Math Man    
No Rating

Comments: ( Back to comment list | You must be logged in to post comments.)
Solution computer solution Comment 2 of 2 |
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
Please log in:
Login:
Password:
Remember me:
Sign up! | Forgot password


Search:
Search body:
Forums (0)
Newest Problems
Random Problem
FAQ | About This Site
Site Statistics
New Comments (7)
Unsolved Problems
Top Rated Problems
This month's top
Most Commented On

Chatterbox:
Copyright © 2002 - 2017 by Animus Pactum Consulting. All rights reserved. Privacy Information