Groups > comp.soft-sys.math.mathematica > #16776

weird numbers

Path	csiph.com!v102.xanadu-bbs.net!xanadu-bbs.net!news.glorb.com!newspump.sol.net!posts.news.twtelecom.net!nnrp3.twtelecom.net!not-for-mail
From	dimanag78@gmail.com
Newsgroups	comp.soft-sys.math.mathematica
Subject	weird numbers
Date	Fri, 11 Apr 2014 06:11:59 +0000 (UTC)
Sender	steve@smc.vnet.net
Approved	Steven M. Christensen <steve@smc.vnet.net>, Moderator
Message-ID	<li813f$ae5$1@smc.vnet.net> (permalink)
Lines	60
Organization	Time-Warner Telecom
NNTP-Posting-Date	11 Apr 2014 06:17:58 GMT
NNTP-Posting-Host	75ca9f1c.news.twtelecom.net
X-Trace	DXC=Ulh@R[jA@0V56R`ci4O@<_C_A=>8kQj6];[h;PUXBgbTj4eD5l`OG?_EFiONJ7[GoVc@i;GFL;e>\
X-Complaints-To	abuse@twtelecom.net
Xref	csiph.com comp.soft-sys.math.mathematica:16776

Show key headers only | View raw

Hello to all.

I found the following problem in a book about Mathematica.

"A weird number is a number such that the sum of the proper divisors (divisors including 1 but not itself) of the number is greater than the number, but no subset of these divisors sums to to number itself. Find all the weird numbers up to 10000."

Unfortunately, the author does not provide an answer for this problem.


My first attempt.

In[74]:= Timing[
 Select[Range[300], 
  Total[Most[Divisors[#1]]] > #1 &&  ! 
     MemberQ[Total /@ Subsets[Most[Divisors[#1]]], #1] & ]]

Out[74]= {11.938, {70}}

A result possibly explained by the fact that there are in this range numbers whose proper divisors make more 100000 subsets.

In[75]:= Select[Range[300], 
 Length[Subsets[Most[Divisors[#1]]]] > 100000 & ]

Out[75]= {180, 240, 252, 288, 300}


Now from number theory we learn that because 6 is a perfect number (its proper divisors sum to the number itself) its multiplies are pseudoperfect numbers and hence no weird.

I use this fact in my second attempt which is much better.

In[76]:= Timing[
 Select[Range[300], 
  Total[Most[Divisors[#1]]] > #1 && 
    Mod[#1, 6] != 0 &&  ! 
     MemberQ[Total /@ Subsets[Most[Divisors[#1]]], #1] & ]]

Out[76]= {0.594, {70}}

Nevertheless, even for numbers up to 2000 there is a big time use.

Table[Timing[{{100*k, 100*(k + 1)}, 
   Select[Range[100*k, 100*(k + 1)], 
    Total[Most[Divisors[#1]]] > #1 && Mod[#1, 6] != 0 && 
              ! 
       MemberQ[Total /@ Subsets[Most[Divisors[#1]]], #1] & ]}], {k, 
  13, 20}]

{{79.75, {{1300, 1400}, {}}}, {81.406, {{1400, 
    1500}, {}}}, {103.891, {{1500, 1600}, {}}}, {10.937, {{1600, 
    1700}, {}}}, {77.438, {{1700, 1800}, {}}}, {83.687, {{1800, 
    1900}, {}}}, {90.25, {{1900, 2000}, {}}}, {83.969, {{2000, 
    2100}, {}}}}

My point of view is that the problem asks too much from a simple program.
But I would like to see your thoughts about this issue.

Thank you very much.

Dimitris Anagnostou

Back to comp.soft-sys.math.mathematica | Previous | Next | Find similar

Thread

weird numbers dimanag78@gmail.com - 2014-04-11 06:11 +0000

csiph-web